generator/generator_perl.ml

   1 (* libguestfs
   2  * Copyright (C) 2009-2011 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 open Generator_events
  32
  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;
  36
  37   pr "\
  38 #include \"EXTERN.h\"
  39 #include \"perl.h\"
  40 #include \"XSUB.h\"
  41
  42 #include <guestfs.h>
  43
  44 #ifndef PRId64
  45 #define PRId64 \"lld\"
  46 #endif
  47
  48 static SV *
  49 my_newSVll(long long val) {
  50 #ifdef USE_64_BIT_ALL
  51   return newSViv(val);
  52 #else
  53   char buf[100];
  54   int len;
  55   len = snprintf(buf, 100, \"%%\" PRId64, val);
  56   return newSVpv(buf, len);
  57 #endif
  58 }
  59
  60 #ifndef PRIu64
  61 #define PRIu64 \"llu\"
  62 #endif
  63
  64 static SV *
  65 my_newSVull(unsigned long long val) {
  66 #ifdef USE_64_BIT_ALL
  67   return newSVuv(val);
  68 #else
  69   char buf[100];
  70   int len;
  71   len = snprintf(buf, 100, \"%%\" PRIu64, val);
  72   return newSVpv(buf, len);
  73 #endif
  74 }
  75
  76 /* http://www.perlmonks.org/?node_id=680842 */
  77 static char **
  78 XS_unpack_charPtrPtr (SV *arg) {
  79   char **ret;
  80   AV *av;
  81   I32 i;
  82
  83   if (!arg || !SvOK (arg) || !SvROK (arg) || SvTYPE (SvRV (arg)) != SVt_PVAV)
  84     croak (\"array reference expected\");
  85
  86   av = (AV *)SvRV (arg);
  87   ret = malloc ((av_len (av) + 1 + 1) * sizeof (char *));
  88   if (!ret)
  89     croak (\"malloc failed\");
  90
  91   for (i = 0; i <= av_len (av); i++) {
  92     SV **elem = av_fetch (av, i, 0);
  93
  94     if (!elem || !*elem)
  95       croak (\"missing element in list\");
  96
  97     ret[i] = SvPV_nolen (*elem);
  98   }
  99
 100   ret[i] = NULL;
 101
 102   return ret;
 103 }
 104
 105 /* http://www.perlmonks.org/?node=338857 */
 106 static void
 107 _event_callback_wrapper (guestfs_h *g,
 108                          void *cb,
 109                          uint64_t event,
 110                          int event_handle,
 111                          int flags,
 112                          const char *buf, size_t buf_len,
 113                          const uint64_t *array, size_t array_len)
 114 {
 115   dSP;
 116   ENTER;
 117   SAVETMPS;
 118   PUSHMARK (SP);
 119   XPUSHs (sv_2mortal (my_newSVull (event)));
 120   XPUSHs (sv_2mortal (newSViv (event_handle)));
 121   XPUSHs (sv_2mortal (newSVpvn (buf ? buf : \"\", buf_len)));
 122   AV *av = newAV ();
 123   size_t i;
 124   for (i = 0; i < array_len; ++i)
 125     av_push (av, my_newSVull (array[i]));
 126   XPUSHs (sv_2mortal (newRV ((SV *) av)));
 127   PUTBACK;
 128   call_sv ((SV *) cb, G_VOID | G_DISCARD | G_EVAL);
 129   FREETMPS;
 130   LEAVE;
 131 }
 132
 133 static SV **
 134 get_all_event_callbacks (guestfs_h *g, size_t *len_rtn)
 135 {
 136   SV **r;
 137   size_t i;
 138   const char *key;
 139   SV *cb;
 140
 141   /* Count the length of the array that will be needed. */
 142   *len_rtn = 0;
 143   cb = guestfs_first_private (g, &key);
 144   while (cb != NULL) {
 145     if (strncmp (key, \"_perl_event_\", strlen (\"_perl_event_\")) == 0)
 146       (*len_rtn)++;
 147     cb = guestfs_next_private (g, &key);
 148   }
 149
 150   /* Copy them into the return array. */
 151   r = guestfs_safe_malloc (g, sizeof (SV *) * (*len_rtn));
 152
 153   i = 0;
 154   cb = guestfs_first_private (g, &key);
 155   while (cb != NULL) {
 156     if (strncmp (key, \"_perl_event_\", strlen (\"_perl_event_\")) == 0) {
 157       r[i] = cb;
 158       i++;
 159     }
 160     cb = guestfs_next_private (g, &key);
 161   }
 162
 163   return r;
 164 }
 165
 166 static void
 167 _close_handle (guestfs_h *g)
 168 {
 169   size_t i, len;
 170   SV **cbs;
 171
 172   assert (g != NULL);
 173
 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
 177    */
 178   cbs = get_all_event_callbacks (g, &len);
 179
 180   guestfs_close (g);
 181
 182   for (i = 0; i < len; ++i)
 183     SvREFCNT_dec (cbs[i]);
 184 }
 185
 186 MODULE = Sys::Guestfs  PACKAGE = Sys::Guestfs
 187
 188 PROTOTYPES: ENABLE
 189
 190 guestfs_h *
 191 _create ()
 192    CODE:
 193       RETVAL = guestfs_create ();
 194       if (!RETVAL)
 195         croak (\"could not create guestfs handle\");
 196       guestfs_set_error_handler (RETVAL, NULL, NULL);
 197  OUTPUT:
 198       RETVAL
 199
 200 void
 201 DESTROY (sv)
 202       SV *sv;
 203  PPCODE:
 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
 207        * display an error.
 208        */
 209       HV *hv = (HV *) SvRV (sv);
 210       SV **svp = hv_fetch (hv, \"_g\", 2, 0);
 211       if (svp != NULL) {
 212         guestfs_h *g = (guestfs_h *) SvIV (*svp);
 213         _close_handle (g);
 214       }
 215
 216 void
 217 close (g)
 218       guestfs_h *g;
 219  PPCODE:
 220       _close_handle (g);
 221       /* Avoid double-free in DESTROY method. */
 222       HV *hv = (HV *) SvRV (ST(0));
 223       (void) hv_delete (hv, \"_g\", 2, G_DISCARD);
 224
 225 SV *
 226 set_event_callback (g, cb, event_bitmask)
 227       guestfs_h *g;
 228       SV *cb;
 229       int event_bitmask;
 230 PREINIT:
 231       int eh;
 232       char key[64];
 233    CODE:
 234       eh = guestfs_set_event_callback (g, _event_callback_wrapper,
 235                                        event_bitmask, 0, cb);
 236       if (eh == -1)
 237         croak (\"%%s\", guestfs_last_error (g));
 238
 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).
 243        */
 244       SvREFCNT_inc (cb);
 245
 246       snprintf (key, sizeof key, \"_perl_event_%%d\", eh);
 247       guestfs_set_private (g, key, cb);
 248
 249       RETVAL = newSViv (eh);
 250  OUTPUT:
 251       RETVAL
 252
 253 void
 254 delete_event_callback (g, event_handle)
 255       guestfs_h *g;
 256       int event_handle;
 257 PREINIT:
 258       char key[64];
 259       SV *cb;
 260    CODE:
 261       snprintf (key, sizeof key, \"_perl_event_%%d\", event_handle);
 262       cb = guestfs_get_private (g, key);
 263       if (cb) {
 264         SvREFCNT_dec (cb);
 265         guestfs_set_private (g, key, NULL);
 266         guestfs_delete_event_callback (g, event_handle);
 267       }
 268
 269 SV *
 270 last_errno (g)
 271       guestfs_h *g;
 272 PREINIT:
 273       int errnum;
 274    CODE:
 275       errnum = guestfs_last_errno (g);
 276       RETVAL = newSViv (errnum);
 277  OUTPUT:
 278       RETVAL
 279
 280 ";
 281
 282   List.iter (
 283     fun (name, (ret, args, optargs as style), _, _, _, _, _) ->
 284       (match ret with
 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"
 293        | RStringList _
 294        | RStruct _ | RStructList _
 295        | RHashtable _ ->
 296            pr "void\n" (* all lists returned implictly on the stack *)
 297       );
 298       (* Call and arguments. *)
 299       pr "%s (g" name;
 300       List.iter (
 301         fun arg -> pr ", %s" (name_of_argt arg)
 302       ) args;
 303       if optargs <> [] then
 304         pr ", ...";
 305       pr ")\n";
 306       pr "      guestfs_h *g;\n";
 307       iteri (
 308         fun i ->
 309           function
 310           | Pathname n | Device n | Dev_or_Path n | String n
 311           | FileIn n | FileOut n | Key n ->
 312               pr "      char *%s;\n" n
 313           | BufferIn n ->
 314               pr "      char *%s;\n" n;
 315               pr "      size_t %s_size = SvCUR (ST(%d));\n" n (i+1)
 316           | OptString n ->
 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.
 320                *)
 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
 327       ) args;
 328
 329       (* PREINIT section (local variable declarations). *)
 330       pr "PREINIT:\n";
 331       (match ret with
 332        | RErr ->
 333            pr "      int r;\n";
 334        | RInt _
 335        | RBool _ ->
 336            pr "      int r;\n";
 337        | RInt64 _ ->
 338            pr "      int64_t r;\n";
 339        | RConstString _ ->
 340            pr "      const char *r;\n";
 341        | RConstOptString _ ->
 342            pr "      const char *r;\n";
 343        | RString _ ->
 344            pr "      char *r;\n";
 345        | RStringList _ | RHashtable _ ->
 346            pr "      char **r;\n";
 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;
 352            pr "      size_t i;\n";
 353            pr "      HV *hv;\n";
 354        | RBufferOut _ ->
 355            pr "      char *r;\n";
 356            pr "      size_t size;\n";
 357       );
 358
 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";
 363       );
 364
 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.
 368        *)
 369       (match ret with
 370        | RErr ->
 371            pr " PPCODE:\n";
 372        | RInt n
 373        | RBool n ->
 374            pr "   CODE:\n";
 375        | RInt64 n ->
 376            pr "   CODE:\n";
 377        | RConstString n ->
 378            pr "   CODE:\n";
 379        | RConstOptString n ->
 380            pr "   CODE:\n";
 381        | RString n ->
 382            pr "   CODE:\n";
 383        | RStringList n | RHashtable n ->
 384            pr " PPCODE:\n";
 385        | RBufferOut n ->
 386            pr "   CODE:\n";
 387        | RStruct _
 388        | RStructList _ ->
 389            pr " PPCODE:\n";
 390       );
 391
 392       (* For optional arguments, convert these from the XSUB "items"
 393        * variable by hand.
 394        *)
 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";
 403         pr "\n";
 404         pr "        this_arg = SvPV_nolen (ST (items_i));\n";
 405         pr "        ";
 406         List.iter (
 407           fun argt ->
 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;
 412             (match argt with
 413              | Bool _
 414              | Int _
 415              | Int64 _ -> pr "SvIV (ST (items_i+1))"
 416              | String _ -> pr "SvPV_nolen (ST (items_i+1))"
 417              | _ -> assert false
 418             );
 419             pr ";\n";
 420             pr "          this_mask = GUESTFS_%s_%s_BITMASK;\n" uc_name uc_n;
 421             pr "        }\n";
 422             pr "        else ";
 423         ) optargs;
 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";
 427         pr "                 this_arg);\n";
 428         pr "        optargs_s.bitmask |= this_mask;\n";
 429         pr "      }\n";
 430         pr "\n";
 431       );
 432
 433       (* The call to the C function. *)
 434       if optargs = [] then
 435         pr "      r = guestfs_%s " name
 436       else
 437         pr "      r = guestfs_%s_argv " name;
 438       generate_c_call_args ~handle:"g" style;
 439       pr ";\n";
 440
 441       (* Cleanup any arguments. *)
 442       List.iter (
 443         function
 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
 449       ) args;
 450
 451       (* Check return value for errors and return it if necessary. *)
 452       (match ret with
 453        | RErr ->
 454            pr "      if (r == -1)\n";
 455            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
 456        | RInt n
 457        | RBool n ->
 458            pr "      if (r == -1)\n";
 459            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
 460            pr "      RETVAL = newSViv (r);\n";
 461            pr " OUTPUT:\n";
 462            pr "      RETVAL\n"
 463        | RInt64 n ->
 464            pr "      if (r == -1)\n";
 465            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
 466            pr "      RETVAL = my_newSVll (r);\n";
 467            pr " OUTPUT:\n";
 468            pr "      RETVAL\n"
 469        | RConstString n ->
 470            pr "      if (r == NULL)\n";
 471            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
 472            pr "      RETVAL = newSVpv (r, 0);\n";
 473            pr " OUTPUT:\n";
 474            pr "      RETVAL\n"
 475        | RConstOptString n ->
 476            pr "      if (r == NULL)\n";
 477            pr "        RETVAL = &PL_sv_undef;\n";
 478            pr "      else\n";
 479            pr "        RETVAL = newSVpv (r, 0);\n";
 480            pr " OUTPUT:\n";
 481            pr "      RETVAL\n"
 482        | RString n ->
 483            pr "      if (r == NULL)\n";
 484            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
 485            pr "      RETVAL = newSVpv (r, 0);\n";
 486            pr "      free (r);\n";
 487            pr " OUTPUT:\n";
 488            pr "      RETVAL\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";
 497            pr "      }\n";
 498            pr "      free (r);\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
 505        | RBufferOut n ->
 506            pr "      if (r == NULL)\n";
 507            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
 508            pr "      RETVAL = newSVpvn (r, size);\n";
 509            pr "      free (r);\n";
 510            pr " OUTPUT:\n";
 511            pr "      RETVAL\n"
 512       );
 513
 514       pr "\n"
 515   ) all_functions
 516
 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";
 523   List.iter (
 524     function
 525     | name, FString ->
 526         pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (r->val[i].%s, 0), 0);\n"
 527           name (String.length name) name
 528     | name, FUUID ->
 529         pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (r->val[i].%s, 32), 0);\n"
 530           name (String.length name) name
 531     | name, FBuffer ->
 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
 537     | name, FInt64 ->
 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
 543     | name, FChar ->
 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
 549   ) cols;
 550   pr "        PUSHs (sv_2mortal (newRV ((SV *) hv)));\n";
 551   pr "      }\n";
 552   pr "      guestfs_free_%s_list (r);\n" typ
 553
 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);
 558   List.iter (
 559     fun ((name, _) as col) ->
 560       pr "      PUSHs (sv_2mortal (newSVpv (\"%s\", 0)));\n" name;
 561
 562       match col with
 563       | name, FString ->
 564           pr "      PUSHs (sv_2mortal (newSVpv (r->%s, 0)));\n"
 565             name
 566       | name, FBuffer ->
 567           pr "      PUSHs (sv_2mortal (newSVpvn (r->%s, r->%s_len)));\n"
 568             name name
 569       | name, FUUID ->
 570           pr "      PUSHs (sv_2mortal (newSVpv (r->%s, 32)));\n"
 571             name
 572       | name, (FBytes|FUInt64) ->
 573           pr "      PUSHs (sv_2mortal (my_newSVull (r->%s)));\n"
 574             name
 575       | name, FInt64 ->
 576           pr "      PUSHs (sv_2mortal (my_newSVll (r->%s)));\n"
 577             name
 578       | name, (FInt32|FUInt32) ->
 579           pr "      PUSHs (sv_2mortal (newSVnv (r->%s)));\n"
 580             name
 581       | name, FChar ->
 582           pr "      PUSHs (sv_2mortal (newSVpv (&r->%s, 1)));\n"
 583             name
 584       | name, FOptPercent ->
 585           pr "      PUSHs (sv_2mortal (newSVnv (r->%s)));\n"
 586             name
 587   ) cols;
 588   pr "      free (r);\n"
 589
 590 (* Generate Sys/Guestfs.pm. *)
 591 and generate_perl_pm () =
 592   generate_header HashStyle LGPLv2plus;
 593
 594   pr "\
 595 =pod
 596
 597 =head1 NAME
 598
 599 Sys::Guestfs - Perl bindings for libguestfs
 600
 601 =head1 SYNOPSIS
 602
 603  use Sys::Guestfs;
 604
 605  my $h = Sys::Guestfs->new ();
 606  $h->add_drive_opts ('guest.img', format => 'raw');
 607  $h->launch ();
 608  $h->mount_options ('', '/dev/sda1', '/');
 609  $h->touch ('/hello');
 610  $h->sync ();
 611
 612 =head1 DESCRIPTION
 613
 614 The C<Sys::Guestfs> module provides a Perl XS binding to the
 615 libguestfs API for examining and modifying virtual machine
 616 disk images.
 617
 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
 623 much else besides.
 624
 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.
 629
 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
 633 FUSE.
 634
 635 See also L<Sys::Guestfs::Lib(3)> for a set of useful library
 636 functions for using libguestfs from Perl, including integration
 637 with libvirt.
 638
 639 =head1 ERRORS
 640
 641 All errors turn into calls to C<croak> (see L<Carp(3)>).
 642
 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.
 645
 646 =head1 METHODS
 647
 648 =over 4
 649
 650 =cut
 651
 652 package Sys::Guestfs;
 653
 654 use strict;
 655 use warnings;
 656
 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);
 661 $VERSION = '0.%d';
 662
 663 require XSLoader;
 664 XSLoader::load ('Sys::Guestfs');
 665
 666 " max_proc_nr;
 667
 668   (* Methods. *)
 669   pr "\
 670 =item $h = Sys::Guestfs->new ();
 671
 672 Create a new guestfs handle.
 673
 674 =cut
 675
 676 sub new {
 677   my $proto = shift;
 678   my $class = ref ($proto) || $proto;
 679
 680   my $g = Sys::Guestfs::_create ();
 681   my $self = { _g => $g };
 682   bless $self, $class;
 683   return $self;
 684 }
 685
 686 =item $h->close ();
 687
 688 Explicitly close the guestfs handle.
 689
 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).
 699
 700 ";
 701
 702   List.iter (
 703     fun (name, bitmask) ->
 704       pr "=item $Sys::Guestfs::EVENT_%s\n" (String.uppercase name);
 705       pr "\n";
 706       pr "See L<guestfs(3)/GUESTFS_EVENT_%s>.\n"
 707         (String.uppercase name);
 708       pr "\n";
 709       pr "=cut\n";
 710       pr "\n";
 711       pr "our $EVENT_%s = 0x%x;\n" (String.uppercase name) bitmask;
 712       pr "\n"
 713   ) events;
 714
 715   pr "\
 716 =item $event_handle = $h->set_event_callback (\\&cb, $event_bitmask);
 717
 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).
 721
 722 This function returns an event handle which
 723 can be used to delete the callback using C<delete_event_callback>.
 724
 725 The callback function receives 4 parameters:
 726
 727  &cb ($event, $event_handle, $buf, $array)
 728
 729 =over 4
 730
 731 =item $event
 732
 733 The event which happened (equal to one of C<$Sys::Guestfs::EVENT_*>).
 734
 735 =item $event_handle
 736
 737 The event handle.
 738
 739 =item $buf
 740
 741 For some event types, this is a message buffer (ie. a string).
 742
 743 =item $array
 744
 745 For some event types (notably progress events), this is
 746 an array of integers.
 747
 748 =back
 749
 750 You should carefully read the documentation for
 751 L<guestfs(3)/guestfs_set_event_callback> before using
 752 this function.
 753
 754 =item $h->delete_event_callback ($event_handle);
 755
 756 This removes the callback which was previously registered using
 757 C<set_event_callback>.
 758
 759 =item $errnum = $h->last_errno ();
 760
 761 This returns the last error number (errno) that happened on the
 762 handle C<$h>.
 763
 764 If successful, an errno integer not equal to zero is returned.
 765
 766 If no error number is available, this returns 0.
 767 See L<guestfs(3)/guestfs_last_errno> for more details of why
 768 this can happen.
 769
 770 You can use the standard Perl module L<Errno(3)> to compare
 771 the numeric error returned from this call with symbolic
 772 errnos:
 773
 774  $h->mkdir (\"/foo\");
 775  if ($h->last_errno() == Errno::EEXIST()) {
 776    # mkdir failed because the directory exists already.
 777  }
 778
 779 =cut
 780
 781 ";
 782
 783   (* Actions.  We only need to print documentation for these as
 784    * they are pulled in from the XS code automatically.
 785    *)
 786   List.iter (
 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
 790         pr "=item ";
 791         generate_perl_prototype name style;
 792         pr "\n\n";
 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
 799         | None -> ()
 800         | Some txt -> pr "%s\n\n" txt
 801       )
 802   ) all_functions_sorted;
 803
 804   (* End of file. *)
 805   pr "\
 806 =cut
 807
 808 1;
 809
 810 =back
 811
 812 =head1 AVAILABILITY
 813
 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?
 819
 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:
 823
 824  use Sys::Guestfs;
 825  if (defined (Sys::Guestfs->can (\"set_verbose\"))) {
 826    print \"\\$h->set_verbose is available\\n\";
 827  }
 828
 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.
 832
 833  $h->available ( [\"augeas\"] );
 834
 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>.
 839
 840 For further discussion on this topic, refer to
 841 L<guestfs(3)/AVAILABILITY>.
 842
 843 =head1 STORING DATA IN THE HANDLE
 844
 845 The handle returned from L</new> is a hash reference.  The hash
 846 normally contains a single element:
 847
 848  {
 849    _g => [private data used by libguestfs]
 850  }
 851
 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.
 854
 855 Any fields whose names begin with an underscore are reserved
 856 for private use by libguestfs.  We may add more in future.
 857
 858 It is recommended that callers prefix the name of their field(s)
 859 with some unique string, to avoid conflicts with other users.
 860
 861 =head1 COPYRIGHT
 862
 863 Copyright (C) %s Red Hat Inc.
 864
 865 =head1 LICENSE
 866
 867 Please see the file COPYING.LIB for the full license.
 868
 869 =head1 SEE ALSO
 870
 871 L<guestfs(3)>,
 872 L<guestfish(1)>,
 873 L<http://libguestfs.org>,
 874 L<Sys::Guestfs::Lib(3)>.
 875
 876 =cut
 877 " copyright_years
 878
 879 and generate_perl_prototype name (ret, args, optargs) =
 880   (match ret with
 881    | RErr -> ()
 882    | RBool n
 883    | RInt n
 884    | RInt64 n
 885    | RConstString n
 886    | RConstOptString n
 887    | RString n
 888    | RBufferOut n -> pr "$%s = " n
 889    | RStruct (n,_)
 890    | RHashtable n -> pr "%%%s = " n
 891    | RStringList n
 892    | RStructList (n,_) -> pr "@%s = " n
 893   );
 894   pr "$h->%s (" name;
 895   let comma = ref false in
 896   List.iter (
 897     fun arg ->
 898       if !comma then pr ", ";
 899       comma := true;
 900       match arg with
 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) ->
 904           pr "$%s" n
 905       | StringList n | DeviceList n ->
 906           pr "\\@%s" n
 907   ) args;
 908   List.iter (
 909     fun arg ->
 910       if !comma then pr " [, " else pr "[";
 911       comma := true;
 912       let n = name_of_argt arg in
 913       pr "%s => $%s]" n n
 914   ) optargs;
 915   pr ");"