generator/generator_perl.ml

   1 (* libguestfs
   2  * Copyright (C) 2009-2010 Red Hat Inc.
   3  *
   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.
   8  *
   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.
  13  *
  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
  17  *)
  18
  19 (* Please read generator/README first. *)
  20
  21 open Printf
  22
  23 open Generator_types
  24 open Generator_utils
  25 open Generator_pr
  26 open Generator_docstrings
  27 open Generator_optgroups
  28 open Generator_actions
  29 open Generator_structs
  30 open Generator_c
  31
  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;
  35
  36   pr "\
  37 #include \"EXTERN.h\"
  38 #include \"perl.h\"
  39 #include \"XSUB.h\"
  40
  41 #include <guestfs.h>
  42
  43 #ifndef PRId64
  44 #define PRId64 \"lld\"
  45 #endif
  46
  47 static SV *
  48 my_newSVll(long long val) {
  49 #ifdef USE_64_BIT_ALL
  50   return newSViv(val);
  51 #else
  52   char buf[100];
  53   int len;
  54   len = snprintf(buf, 100, \"%%\" PRId64, val);
  55   return newSVpv(buf, len);
  56 #endif
  57 }
  58
  59 #ifndef PRIu64
  60 #define PRIu64 \"llu\"
  61 #endif
  62
  63 static SV *
  64 my_newSVull(unsigned long long val) {
  65 #ifdef USE_64_BIT_ALL
  66   return newSVuv(val);
  67 #else
  68   char buf[100];
  69   int len;
  70   len = snprintf(buf, 100, \"%%\" PRIu64, val);
  71   return newSVpv(buf, len);
  72 #endif
  73 }
  74
  75 /* http://www.perlmonks.org/?node_id=680842 */
  76 static char **
  77 XS_unpack_charPtrPtr (SV *arg) {
  78   char **ret;
  79   AV *av;
  80   I32 i;
  81
  82   if (!arg || !SvOK (arg) || !SvROK (arg) || SvTYPE (SvRV (arg)) != SVt_PVAV)
  83     croak (\"array reference expected\");
  84
  85   av = (AV *)SvRV (arg);
  86   ret = malloc ((av_len (av) + 1 + 1) * sizeof (char *));
  87   if (!ret)
  88     croak (\"malloc failed\");
  89
  90   for (i = 0; i <= av_len (av); i++) {
  91     SV **elem = av_fetch (av, i, 0);
  92
  93     if (!elem || !*elem)
  94       croak (\"missing element in list\");
  95
  96     ret[i] = SvPV_nolen (*elem);
  97   }
  98
  99   ret[i] = NULL;
 100
 101   return ret;
 102 }
 103
 104 #define PROGRESS_KEY \"_perl_progress_cb\"
 105
 106 static void
 107 _clear_progress_callback (guestfs_h *g)
 108 {
 109   guestfs_set_progress_callback (g, NULL, NULL);
 110   SV *cb = guestfs_get_private (g, PROGRESS_KEY);
 111   if (cb) {
 112     guestfs_set_private (g, PROGRESS_KEY, NULL);
 113     SvREFCNT_dec (cb);
 114   }
 115 }
 116
 117 /* http://www.perlmonks.org/?node=338857 */
 118 static void
 119 _progress_callback (guestfs_h *g, void *cb,
 120                     int proc_nr, int serial, uint64_t position, uint64_t total)
 121 {
 122   dSP;
 123   ENTER;
 124   SAVETMPS;
 125   PUSHMARK (SP);
 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)));
 130   PUTBACK;
 131   call_sv ((SV *) cb, G_VOID | G_DISCARD | G_EVAL);
 132   FREETMPS;
 133   LEAVE;
 134 }
 135
 136 static void
 137 _close_handle (guestfs_h *g)
 138 {
 139   assert (g != NULL);
 140   _clear_progress_callback (g);
 141   guestfs_close (g);
 142 }
 143
 144 MODULE = Sys::Guestfs  PACKAGE = Sys::Guestfs
 145
 146 PROTOTYPES: ENABLE
 147
 148 guestfs_h *
 149 _create ()
 150    CODE:
 151       RETVAL = guestfs_create ();
 152       if (!RETVAL)
 153         croak (\"could not create guestfs handle\");
 154       guestfs_set_error_handler (RETVAL, NULL, NULL);
 155  OUTPUT:
 156       RETVAL
 157
 158 void
 159 DESTROY (sv)
 160       SV *sv;
 161  PPCODE:
 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
 165        * display an error.
 166        */
 167       HV *hv = (HV *) SvRV (sv);
 168       SV **svp = hv_fetch (hv, \"_g\", 2, 0);
 169       if (svp != NULL) {
 170         guestfs_h *g = (guestfs_h *) SvIV (*svp);
 171         _close_handle (g);
 172       }
 173
 174 void
 175 close (g)
 176       guestfs_h *g;
 177  PPCODE:
 178       _close_handle (g);
 179       /* Avoid double-free in DESTROY method. */
 180       HV *hv = (HV *) SvRV (ST(0));
 181       (void) hv_delete (hv, \"_g\", 2, G_DISCARD);
 182
 183 void
 184 set_progress_callback (g, cb)
 185       guestfs_h *g;
 186       SV *cb;
 187  PPCODE:
 188       _clear_progress_callback (g);
 189       SvREFCNT_inc (cb);
 190       guestfs_set_private (g, PROGRESS_KEY, cb);
 191       guestfs_set_progress_callback (g, _progress_callback, cb);
 192
 193 void
 194 clear_progress_callback (g)
 195       guestfs_h *g;
 196  PPCODE:
 197       _clear_progress_callback (g);
 198
 199 ";
 200
 201   List.iter (
 202     fun (name, (ret, args, optargs as style), _, _, _, _, _) ->
 203       (match ret 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"
 212        | RStringList _
 213        | RStruct _ | RStructList _
 214        | RHashtable _ ->
 215            pr "void\n" (* all lists returned implictly on the stack *)
 216       );
 217       (* Call and arguments. *)
 218       pr "%s (g" name;
 219       List.iter (
 220         fun arg -> pr ", %s" (name_of_argt arg)
 221       ) args;
 222       if optargs <> [] then
 223         pr ", ...";
 224       pr ")\n";
 225       pr "      guestfs_h *g;\n";
 226       iteri (
 227         fun i ->
 228           function
 229           | Pathname n | Device n | Dev_or_Path n | String n
 230           | FileIn n | FileOut n | Key n ->
 231               pr "      char *%s;\n" n
 232           | BufferIn n ->
 233               pr "      char *%s;\n" n;
 234               pr "      size_t %s_size = SvCUR (ST(%d));\n" n (i+1)
 235           | OptString n ->
 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.
 239                *)
 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
 246       ) args;
 247
 248       (* PREINIT section (local variable declarations). *)
 249       pr "PREINIT:\n";
 250       (match ret with
 251        | RErr ->
 252            pr "      int r;\n";
 253        | RInt _
 254        | RBool _ ->
 255            pr "      int r;\n";
 256        | RInt64 _ ->
 257            pr "      int64_t r;\n";
 258        | RConstString _ ->
 259            pr "      const char *r;\n";
 260        | RConstOptString _ ->
 261            pr "      const char *r;\n";
 262        | RString _ ->
 263            pr "      char *r;\n";
 264        | RStringList _ | RHashtable _ ->
 265            pr "      char **r;\n";
 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;
 271            pr "      size_t i;\n";
 272            pr "      HV *hv;\n";
 273        | RBufferOut _ ->
 274            pr "      char *r;\n";
 275            pr "      size_t size;\n";
 276       );
 277
 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";
 282       );
 283
 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.
 287        *)
 288       (match ret with
 289        | RErr ->
 290            pr " PPCODE:\n";
 291        | RInt n
 292        | RBool n ->
 293            pr "   CODE:\n";
 294        | RInt64 n ->
 295            pr "   CODE:\n";
 296        | RConstString n ->
 297            pr "   CODE:\n";
 298        | RConstOptString n ->
 299            pr "   CODE:\n";
 300        | RString n ->
 301            pr "   CODE:\n";
 302        | RStringList n | RHashtable n ->
 303            pr " PPCODE:\n";
 304        | RBufferOut n ->
 305            pr "   CODE:\n";
 306        | RStruct _
 307        | RStructList _ ->
 308            pr " PPCODE:\n";
 309       );
 310
 311       (* For optional arguments, convert these from the XSUB "items"
 312        * variable by hand.
 313        *)
 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";
 322         pr "\n";
 323         pr "        this_arg = SvPV_nolen (ST (items_i));\n";
 324         pr "        ";
 325         List.iter (
 326           fun argt ->
 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;
 331             (match argt with
 332              | Bool _
 333              | Int _
 334              | Int64 _ -> pr "SvIV (ST (items_i+1))"
 335              | String _ -> pr "SvPV_nolen (ST (items_i+1))"
 336              | _ -> assert false
 337             );
 338             pr ";\n";
 339             pr "          this_mask = GUESTFS_%s_%s_BITMASK;\n" uc_name uc_n;
 340             pr "        }\n";
 341             pr "        else ";
 342         ) optargs;
 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";
 346         pr "                 this_arg);\n";
 347         pr "        optargs_s.bitmask |= this_mask;\n";
 348         pr "      }\n";
 349         pr "\n";
 350       );
 351
 352       (* The call to the C function. *)
 353       if optargs = [] then
 354         pr "      r = guestfs_%s " name
 355       else
 356         pr "      r = guestfs_%s_argv " name;
 357       generate_c_call_args ~handle:"g" style;
 358       pr ";\n";
 359
 360       (* Cleanup any arguments. *)
 361       List.iter (
 362         function
 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
 368       ) args;
 369
 370       (* Check return value for errors and return it if necessary. *)
 371       (match ret with
 372        | RErr ->
 373            pr "      if (r == -1)\n";
 374            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
 375        | RInt n
 376        | RBool n ->
 377            pr "      if (r == -1)\n";
 378            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
 379            pr "      RETVAL = newSViv (r);\n";
 380            pr " OUTPUT:\n";
 381            pr "      RETVAL\n"
 382        | RInt64 n ->
 383            pr "      if (r == -1)\n";
 384            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
 385            pr "      RETVAL = my_newSVll (r);\n";
 386            pr " OUTPUT:\n";
 387            pr "      RETVAL\n"
 388        | RConstString n ->
 389            pr "      if (r == NULL)\n";
 390            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
 391            pr "      RETVAL = newSVpv (r, 0);\n";
 392            pr " OUTPUT:\n";
 393            pr "      RETVAL\n"
 394        | RConstOptString n ->
 395            pr "      if (r == NULL)\n";
 396            pr "        RETVAL = &PL_sv_undef;\n";
 397            pr "      else\n";
 398            pr "        RETVAL = newSVpv (r, 0);\n";
 399            pr " OUTPUT:\n";
 400            pr "      RETVAL\n"
 401        | RString n ->
 402            pr "      if (r == NULL)\n";
 403            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
 404            pr "      RETVAL = newSVpv (r, 0);\n";
 405            pr "      free (r);\n";
 406            pr " OUTPUT:\n";
 407            pr "      RETVAL\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";
 416            pr "      }\n";
 417            pr "      free (r);\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
 424        | RBufferOut n ->
 425            pr "      if (r == NULL)\n";
 426            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
 427            pr "      RETVAL = newSVpvn (r, size);\n";
 428            pr "      free (r);\n";
 429            pr " OUTPUT:\n";
 430            pr "      RETVAL\n"
 431       );
 432
 433       pr "\n"
 434   ) all_functions
 435
 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";
 442   List.iter (
 443     function
 444     | name, FString ->
 445         pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (r->val[i].%s, 0), 0);\n"
 446           name (String.length name) name
 447     | name, FUUID ->
 448         pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (r->val[i].%s, 32), 0);\n"
 449           name (String.length name) name
 450     | name, FBuffer ->
 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
 456     | name, FInt64 ->
 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
 462     | name, FChar ->
 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
 468   ) cols;
 469   pr "        PUSHs (sv_2mortal (newRV ((SV *) hv)));\n";
 470   pr "      }\n";
 471   pr "      guestfs_free_%s_list (r);\n" typ
 472
 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);
 477   List.iter (
 478     fun ((name, _) as col) ->
 479       pr "      PUSHs (sv_2mortal (newSVpv (\"%s\", 0)));\n" name;
 480
 481       match col with
 482       | name, FString ->
 483           pr "      PUSHs (sv_2mortal (newSVpv (r->%s, 0)));\n"
 484             name
 485       | name, FBuffer ->
 486           pr "      PUSHs (sv_2mortal (newSVpvn (r->%s, r->%s_len)));\n"
 487             name name
 488       | name, FUUID ->
 489           pr "      PUSHs (sv_2mortal (newSVpv (r->%s, 32)));\n"
 490             name
 491       | name, (FBytes|FUInt64) ->
 492           pr "      PUSHs (sv_2mortal (my_newSVull (r->%s)));\n"
 493             name
 494       | name, FInt64 ->
 495           pr "      PUSHs (sv_2mortal (my_newSVll (r->%s)));\n"
 496             name
 497       | name, (FInt32|FUInt32) ->
 498           pr "      PUSHs (sv_2mortal (newSVnv (r->%s)));\n"
 499             name
 500       | name, FChar ->
 501           pr "      PUSHs (sv_2mortal (newSVpv (&r->%s, 1)));\n"
 502             name
 503       | name, FOptPercent ->
 504           pr "      PUSHs (sv_2mortal (newSVnv (r->%s)));\n"
 505             name
 506   ) cols;
 507   pr "      free (r);\n"
 508
 509 (* Generate Sys/Guestfs.pm. *)
 510 and generate_perl_pm () =
 511   generate_header HashStyle LGPLv2plus;
 512
 513   pr "\
 514 =pod
 515
 516 =head1 NAME
 517
 518 Sys::Guestfs - Perl bindings for libguestfs
 519
 520 =head1 SYNOPSIS
 521
 522  use Sys::Guestfs;
 523
 524  my $h = Sys::Guestfs->new ();
 525  $h->add_drive_opts ('guest.img', format => 'raw');
 526  $h->launch ();
 527  $h->mount_options ('', '/dev/sda1', '/');
 528  $h->touch ('/hello');
 529  $h->sync ();
 530
 531 =head1 DESCRIPTION
 532
 533 The C<Sys::Guestfs> module provides a Perl XS binding to the
 534 libguestfs API for examining and modifying virtual machine
 535 disk images.
 536
 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
 542 much else besides.
 543
 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.
 548
 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
 552 FUSE.
 553
 554 See also L<Sys::Guestfs::Lib(3)> for a set of useful library
 555 functions for using libguestfs from Perl, including integration
 556 with libvirt.
 557
 558 =head1 ERRORS
 559
 560 All errors turn into calls to C<croak> (see L<Carp(3)>).
 561
 562 =head1 METHODS
 563
 564 =over 4
 565
 566 =cut
 567
 568 package Sys::Guestfs;
 569
 570 use strict;
 571 use warnings;
 572
 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);
 577 $VERSION = '0.%d';
 578
 579 require XSLoader;
 580 XSLoader::load ('Sys::Guestfs');
 581
 582 =item $h = Sys::Guestfs->new ();
 583
 584 Create a new guestfs handle.
 585
 586 =cut
 587
 588 sub new {
 589   my $proto = shift;
 590   my $class = ref ($proto) || $proto;
 591
 592   my $g = Sys::Guestfs::_create ();
 593   my $self = { _g => $g };
 594   bless $self, $class;
 595   return $self;
 596 }
 597
 598 =item $h->close ();
 599
 600 Explicitly close the guestfs handle.
 601
 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).
 611
 612 =item $h->set_progress_callback (\\&cb);
 613
 614 Set the progress notification callback for this handle
 615 to the Perl closure C<cb>.
 616
 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>
 620 and C<total>.
 621
 622 You should carefully read the documentation for
 623 L<guestfs(3)/guestfs_set_progress_callback> before using
 624 this function.
 625
 626 =item $h->clear_progress_callback ();
 627
 628 This removes any progress callback function associated with
 629 the handle.
 630
 631 =cut
 632
 633 " max_proc_nr;
 634
 635   (* Actions.  We only need to print documentation for these as
 636    * they are pulled in from the XS code automatically.
 637    *)
 638   List.iter (
 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
 642         pr "=item ";
 643         generate_perl_prototype name style;
 644         pr "\n\n";
 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
 651         | None -> ()
 652         | Some txt -> pr "%s\n\n" txt
 653       )
 654   ) all_functions_sorted;
 655
 656   pr "=cut\n\n";
 657
 658   (* Introspection hash. *)
 659   pr "use vars qw(%%guestfs_introspection);\n";
 660   pr "%%guestfs_introspection = (\n";
 661   List.iter (
 662     fun (name, (ret, args, optargs), _, _, _, shortdesc, _) ->
 663       pr "  \"%s\" => {\n" name;
 664       pr "    ret => ";
 665       (match ret with
 666        | RErr -> pr "'void'"
 667        | RInt _ -> pr "'int'"
 668        | RBool _ -> pr "'bool'"
 669        | RInt64 _ -> pr "'int64'"
 670        | RConstString _ -> pr "'const string'"
 671        | RConstOptString _ -> pr "'const nullable string'"
 672        | RString _ -> pr "'string'"
 673        | RStringList _ -> pr "'string list'"
 674        | RHashtable _ -> pr "'hash'"
 675        | RStruct (_, typ) -> pr "'struct %s'" typ
 676        | RStructList (_, typ) -> pr "'struct %s list'" typ
 677        | RBufferOut _ -> pr "'buffer'"
 678       );
 679       pr ",\n";
 680       let pr_type i = function
 681         | Pathname n -> pr "[ '%s', 'string(path)', %d ]" n i
 682         | Device n -> pr "[ '%s', 'string(device)', %d ]" n i
 683         | Dev_or_Path n -> pr "[ '%s', 'string(dev_or_path)', %d ]" n i
 684         | String n -> pr "[ '%s', 'string', %d ]" n i
 685         | FileIn n -> pr "[ '%s', 'string(filename)', %d ]" n i
 686         | FileOut n -> pr "[ '%s', 'string(filename)', %d ]" n i
 687         | Key n -> pr "[ '%s', 'string(key)', %d ]" n i
 688         | BufferIn n -> pr "[ '%s', 'buffer', %d ]" n i
 689         | OptString n -> pr "[ '%s', 'nullable string', %d ]" n i
 690         | StringList n -> pr "[ '%s', 'string list', %d ]" n i
 691         | DeviceList n -> pr "[ '%s', 'string(device) list', %d ]" n i
 692         | Bool n -> pr "[ '%s', 'bool', %d ]" n i
 693         | Int n -> pr "[ '%s', 'int', %d ]" n i
 694         | Int64 n -> pr "[ '%s', 'int64', %d ]" n i
 695         | Pointer (t, n) -> pr "[ '%s', 'pointer(%s)', %d ]" n t i
 696       in
 697       pr "    args => [\n";
 698       iteri (fun i arg ->
 699         pr "      ";
 700         pr_type i arg;
 701         pr ",\n"
 702       ) args;
 703       pr "    ],\n";
 704       if optargs <> [] then (
 705         pr "    optargs => {\n";
 706         iteri (fun i arg ->
 707           pr "      %s => " (name_of_argt arg);
 708           pr_type i arg;
 709           pr ",\n"
 710         ) optargs;
 711         pr "    },\n";
 712       );
 713       pr "    name => \"%s\",\n" name;
 714       pr "    description => %S,\n" shortdesc;
 715       pr "  },\n";
 716   ) all_functions_sorted;
 717   pr ");\n\n";
 718
 719   (* End of file. *)
 720   pr "\
 721 1;
 722
 723 =back
 724
 725 =head1 AVAILABILITY
 726
 727 From time to time we add new libguestfs APIs.  Also some libguestfs
 728 APIs won't be available in all builds of libguestfs (the Fedora
 729 build is full-featured, but other builds may disable features).
 730 How do you test whether the APIs that your Perl program needs are
 731 available in the version of C<Sys::Guestfs> that you are using?
 732
 733 To test if a particular function is available in the C<Sys::Guestfs>
 734 class, use the ordinary Perl UNIVERSAL method C<can(METHOD)>
 735 (see L<perlobj(1)>).  For example:
 736
 737  use Sys::Guestfs;
 738  if (defined (Sys::Guestfs->can (\"set_verbose\"))) {
 739    print \"\\$h->set_verbose is available\\n\";
 740  }
 741
 742 Perl does not offer a way to list the arguments of a method, and
 743 from time to time we may add extra arguments to calls that take
 744 optional arguments.  For this reason, we provide a global hash
 745 variable C<%%guestfs_introspection> which contains the arguments
 746 and their types for each libguestfs method.  The keys of this
 747 hash are the method names, and the values are an hashref
 748 containing useful introspection information about the method
 749 (further fields may be added to this in future).
 750
 751  use Sys::Guestfs;
 752  $Sys::Guestfs::guestfs_introspection{mkfs_opts}
 753  => {
 754     ret => 'void',                    # return type
 755     args => [                         # required arguments
 756       [ 'fstype', 'string', 0 ],
 757       [ 'device', 'string(device)', 1 ],
 758     ],
 759     optargs => {                      # optional arguments
 760       blocksize => [ 'blocksize', 'int', 0 ],
 761       features => [ 'features', 'string', 1 ],
 762       inode => [ 'inode', 'int', 2 ],
 763       sectorsize => [ 'sectorsize', 'int', 3 ],
 764     },
 765     name => \"mkfs_opts\",
 766     description => \"make a filesystem\",
 767   }
 768
 769 To test if particular features are supported by the current
 770 build, use the L</available> method like the example below.  Note
 771 that the appliance must be launched first.
 772
 773  $h->available ( [\"augeas\"] );
 774
 775 Since the L</available> method croaks if the feature is not supported,
 776 you might also want to wrap this in an eval and return a boolean.
 777 In fact this has already been done for you: use
 778 L<Sys::Guestfs::Lib(3)/feature_available>.
 779
 780 For further discussion on this topic, refer to
 781 L<guestfs(3)/AVAILABILITY>.
 782
 783 =head1 STORING DATA IN THE HANDLE
 784
 785 The handle returned from L</new> is a hash reference.  The hash
 786 normally contains a single element:
 787
 788  {
 789    _g => [private data used by libguestfs]
 790  }
 791
 792 Callers can add other elements to this hash to store data for their own
 793 purposes.  The data lasts for the lifetime of the handle.
 794
 795 Any fields whose names begin with an underscore are reserved
 796 for private use by libguestfs.  We may add more in future.
 797
 798 It is recommended that callers prefix the name of their field(s)
 799 with some unique string, to avoid conflicts with other users.
 800
 801 =head1 COPYRIGHT
 802
 803 Copyright (C) %s Red Hat Inc.
 804
 805 =head1 LICENSE
 806
 807 Please see the file COPYING.LIB for the full license.
 808
 809 =head1 SEE ALSO
 810
 811 L<guestfs(3)>,
 812 L<guestfish(1)>,
 813 L<http://libguestfs.org>,
 814 L<Sys::Guestfs::Lib(3)>.
 815
 816 =cut
 817 " copyright_years
 818
 819 and generate_perl_prototype name (ret, args, optargs) =
 820   (match ret with
 821    | RErr -> ()
 822    | RBool n
 823    | RInt n
 824    | RInt64 n
 825    | RConstString n
 826    | RConstOptString n
 827    | RString n
 828    | RBufferOut n -> pr "$%s = " n
 829    | RStruct (n,_)
 830    | RHashtable n -> pr "%%%s = " n
 831    | RStringList n
 832    | RStructList (n,_) -> pr "@%s = " n
 833   );
 834   pr "$h->%s (" name;
 835   let comma = ref false in
 836   List.iter (
 837     fun arg ->
 838       if !comma then pr ", ";
 839       comma := true;
 840       match arg with
 841       | Pathname n | Device n | Dev_or_Path n | String n
 842       | OptString n | Bool n | Int n | Int64 n | FileIn n | FileOut n
 843       | BufferIn n | Key n | Pointer (_, n) ->
 844           pr "$%s" n
 845       | StringList n | DeviceList n ->
 846           pr "\\@%s" n
 847   ) args;
 848   List.iter (
 849     fun arg ->
 850       if !comma then pr " [, " else pr "[";
 851       comma := true;
 852       let n = name_of_argt arg in
 853       pr "%s => $%s]" n n
 854   ) optargs;
 855   pr ");"