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 void
 281 user_cancel (g)
 282       guestfs_h *g;
 283  PPCODE:
 284       guestfs_user_cancel (g);
 285
 286 ";
 287
 288   List.iter (
 289     fun (name, (ret, args, optargs as style), _, _, _, _, _) ->
 290       (match ret with
 291        | RErr -> pr "void\n"
 292        | RInt _ -> pr "SV *\n"
 293        | RInt64 _ -> pr "SV *\n"
 294        | RBool _ -> pr "SV *\n"
 295        | RConstString _ -> pr "SV *\n"
 296        | RConstOptString _ -> pr "SV *\n"
 297        | RString _ -> pr "SV *\n"
 298        | RBufferOut _ -> pr "SV *\n"
 299        | RStringList _
 300        | RStruct _ | RStructList _
 301        | RHashtable _ ->
 302            pr "void\n" (* all lists returned implictly on the stack *)
 303       );
 304       (* Call and arguments. *)
 305       pr "%s (g" name;
 306       List.iter (
 307         fun arg -> pr ", %s" (name_of_argt arg)
 308       ) args;
 309       if optargs <> [] then
 310         pr ", ...";
 311       pr ")\n";
 312       pr "      guestfs_h *g;\n";
 313       iteri (
 314         fun i ->
 315           function
 316           | Pathname n | Device n | Dev_or_Path n | String n
 317           | FileIn n | FileOut n | Key n ->
 318               pr "      char *%s;\n" n
 319           | BufferIn n ->
 320               pr "      char *%s;\n" n;
 321               pr "      size_t %s_size = SvCUR (ST(%d));\n" n (i+1)
 322           | OptString n ->
 323               (* http://www.perlmonks.org/?node_id=554277
 324                * Note that the implicit handle argument means we have
 325                * to add 1 to the ST(x) operator.
 326                *)
 327               pr "      char *%s = SvOK(ST(%d)) ? SvPV_nolen(ST(%d)) : NULL;\n" n (i+1) (i+1)
 328           | StringList n | DeviceList n -> pr "      char **%s;\n" n
 329           | Bool n -> pr "      int %s;\n" n
 330           | Int n -> pr "      int %s;\n" n
 331           | Int64 n -> pr "      int64_t %s;\n" n
 332           | Pointer (t, n) -> pr "      %s %s;\n" t n
 333       ) args;
 334
 335       (* PREINIT section (local variable declarations). *)
 336       pr "PREINIT:\n";
 337       (match ret with
 338        | RErr ->
 339            pr "      int r;\n";
 340        | RInt _
 341        | RBool _ ->
 342            pr "      int r;\n";
 343        | RInt64 _ ->
 344            pr "      int64_t r;\n";
 345        | RConstString _ ->
 346            pr "      const char *r;\n";
 347        | RConstOptString _ ->
 348            pr "      const char *r;\n";
 349        | RString _ ->
 350            pr "      char *r;\n";
 351        | RStringList _ | RHashtable _ ->
 352            pr "      char **r;\n";
 353            pr "      size_t i, n;\n";
 354        | RStruct (_, typ) ->
 355            pr "      struct guestfs_%s *r;\n" typ;
 356        | RStructList (_, typ) ->
 357            pr "      struct guestfs_%s_list *r;\n" typ;
 358            pr "      size_t i;\n";
 359            pr "      HV *hv;\n";
 360        | RBufferOut _ ->
 361            pr "      char *r;\n";
 362            pr "      size_t size;\n";
 363       );
 364
 365       if optargs <> [] then (
 366         pr "      struct guestfs_%s_argv optargs_s = { .bitmask = 0 };\n" name;
 367         pr "      struct guestfs_%s_argv *optargs = &optargs_s;\n" name;
 368         pr "      size_t items_i;\n";
 369       );
 370
 371       (* CODE or PPCODE section.  PPCODE is used where we are
 372        * returning void, or where we push the return value on the stack
 373        * ourselves.  Using CODE means we will manipulate RETVAL.
 374        *)
 375       (match ret with
 376        | RErr ->
 377            pr " PPCODE:\n";
 378        | RInt n
 379        | RBool n ->
 380            pr "   CODE:\n";
 381        | RInt64 n ->
 382            pr "   CODE:\n";
 383        | RConstString n ->
 384            pr "   CODE:\n";
 385        | RConstOptString n ->
 386            pr "   CODE:\n";
 387        | RString n ->
 388            pr "   CODE:\n";
 389        | RStringList n | RHashtable n ->
 390            pr " PPCODE:\n";
 391        | RBufferOut n ->
 392            pr "   CODE:\n";
 393        | RStruct _
 394        | RStructList _ ->
 395            pr " PPCODE:\n";
 396       );
 397
 398       (* For optional arguments, convert these from the XSUB "items"
 399        * variable by hand.
 400        *)
 401       if optargs <> [] then (
 402         let uc_name = String.uppercase name in
 403         let skip = List.length args + 1 in
 404         pr "      if (((items - %d) & 1) != 0)\n" skip;
 405         pr "        croak (\"expecting an even number of extra parameters\");\n";
 406         pr "      for (items_i = %d; items_i < items; items_i += 2) {\n" skip;
 407         pr "        uint64_t this_mask;\n";
 408         pr "        const char *this_arg;\n";
 409         pr "\n";
 410         pr "        this_arg = SvPV_nolen (ST (items_i));\n";
 411         pr "        ";
 412         List.iter (
 413           fun argt ->
 414             let n = name_of_argt argt in
 415             let uc_n = String.uppercase n in
 416             pr "if (strcmp (this_arg, \"%s\") == 0) {\n" n;
 417             pr "          optargs_s.%s = " n;
 418             (match argt with
 419              | Bool _
 420              | Int _
 421              | Int64 _ -> pr "SvIV (ST (items_i+1))"
 422              | String _ -> pr "SvPV_nolen (ST (items_i+1))"
 423              | _ -> assert false
 424             );
 425             pr ";\n";
 426             pr "          this_mask = GUESTFS_%s_%s_BITMASK;\n" uc_name uc_n;
 427             pr "        }\n";
 428             pr "        else ";
 429         ) optargs;
 430         pr "croak (\"unknown optional argument '%%s'\", this_arg);\n";
 431         pr "        if (optargs_s.bitmask & this_mask)\n";
 432         pr "          croak (\"optional argument '%%s' given twice\",\n";
 433         pr "                 this_arg);\n";
 434         pr "        optargs_s.bitmask |= this_mask;\n";
 435         pr "      }\n";
 436         pr "\n";
 437       );
 438
 439       (* The call to the C function. *)
 440       if optargs = [] then
 441         pr "      r = guestfs_%s " name
 442       else
 443         pr "      r = guestfs_%s_argv " name;
 444       generate_c_call_args ~handle:"g" style;
 445       pr ";\n";
 446
 447       (* Cleanup any arguments. *)
 448       List.iter (
 449         function
 450         | Pathname _ | Device _ | Dev_or_Path _ | String _ | OptString _
 451         | Bool _ | Int _ | Int64 _
 452         | FileIn _ | FileOut _
 453         | BufferIn _ | Key _ | Pointer _ -> ()
 454         | StringList n | DeviceList n -> pr "      free (%s);\n" n
 455       ) args;
 456
 457       (* Check return value for errors and return it if necessary. *)
 458       (match ret with
 459        | RErr ->
 460            pr "      if (r == -1)\n";
 461            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
 462        | RInt n
 463        | RBool n ->
 464            pr "      if (r == -1)\n";
 465            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
 466            pr "      RETVAL = newSViv (r);\n";
 467            pr " OUTPUT:\n";
 468            pr "      RETVAL\n"
 469        | RInt64 n ->
 470            pr "      if (r == -1)\n";
 471            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
 472            pr "      RETVAL = my_newSVll (r);\n";
 473            pr " OUTPUT:\n";
 474            pr "      RETVAL\n"
 475        | RConstString n ->
 476            pr "      if (r == NULL)\n";
 477            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
 478            pr "      RETVAL = newSVpv (r, 0);\n";
 479            pr " OUTPUT:\n";
 480            pr "      RETVAL\n"
 481        | RConstOptString n ->
 482            pr "      if (r == NULL)\n";
 483            pr "        RETVAL = &PL_sv_undef;\n";
 484            pr "      else\n";
 485            pr "        RETVAL = newSVpv (r, 0);\n";
 486            pr " OUTPUT:\n";
 487            pr "      RETVAL\n"
 488        | RString n ->
 489            pr "      if (r == NULL)\n";
 490            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
 491            pr "      RETVAL = newSVpv (r, 0);\n";
 492            pr "      free (r);\n";
 493            pr " OUTPUT:\n";
 494            pr "      RETVAL\n"
 495        | RStringList n | RHashtable n ->
 496            pr "      if (r == NULL)\n";
 497            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
 498            pr "      for (n = 0; r[n] != NULL; ++n) /**/;\n";
 499            pr "      EXTEND (SP, n);\n";
 500            pr "      for (i = 0; i < n; ++i) {\n";
 501            pr "        PUSHs (sv_2mortal (newSVpv (r[i], 0)));\n";
 502            pr "        free (r[i]);\n";
 503            pr "      }\n";
 504            pr "      free (r);\n";
 505        | RStruct (n, typ) ->
 506            let cols = cols_of_struct typ in
 507            generate_perl_struct_code typ cols name style n
 508        | RStructList (n, typ) ->
 509            let cols = cols_of_struct typ in
 510            generate_perl_struct_list_code typ cols name style n
 511        | RBufferOut n ->
 512            pr "      if (r == NULL)\n";
 513            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
 514            pr "      RETVAL = newSVpvn (r, size);\n";
 515            pr "      free (r);\n";
 516            pr " OUTPUT:\n";
 517            pr "      RETVAL\n"
 518       );
 519
 520       pr "\n"
 521   ) all_functions
 522
 523 and generate_perl_struct_list_code typ cols name style n =
 524   pr "      if (r == NULL)\n";
 525   pr "        croak (\"%%s\", guestfs_last_error (g));\n";
 526   pr "      EXTEND (SP, r->len);\n";
 527   pr "      for (i = 0; i < r->len; ++i) {\n";
 528   pr "        hv = newHV ();\n";
 529   List.iter (
 530     function
 531     | name, FString ->
 532         pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (r->val[i].%s, 0), 0);\n"
 533           name (String.length name) name
 534     | name, FUUID ->
 535         pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (r->val[i].%s, 32), 0);\n"
 536           name (String.length name) name
 537     | name, FBuffer ->
 538         pr "        (void) hv_store (hv, \"%s\", %d, newSVpvn (r->val[i].%s, r->val[i].%s_len), 0);\n"
 539           name (String.length name) name name
 540     | name, (FBytes|FUInt64) ->
 541         pr "        (void) hv_store (hv, \"%s\", %d, my_newSVull (r->val[i].%s), 0);\n"
 542           name (String.length name) name
 543     | name, FInt64 ->
 544         pr "        (void) hv_store (hv, \"%s\", %d, my_newSVll (r->val[i].%s), 0);\n"
 545           name (String.length name) name
 546     | name, (FInt32|FUInt32) ->
 547         pr "        (void) hv_store (hv, \"%s\", %d, newSVnv (r->val[i].%s), 0);\n"
 548           name (String.length name) name
 549     | name, FChar ->
 550         pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (&r->val[i].%s, 1), 0);\n"
 551           name (String.length name) name
 552     | name, FOptPercent ->
 553         pr "        (void) hv_store (hv, \"%s\", %d, newSVnv (r->val[i].%s), 0);\n"
 554           name (String.length name) name
 555   ) cols;
 556   pr "        PUSHs (sv_2mortal (newRV ((SV *) hv)));\n";
 557   pr "      }\n";
 558   pr "      guestfs_free_%s_list (r);\n" typ
 559
 560 and generate_perl_struct_code typ cols name style n =
 561   pr "      if (r == NULL)\n";
 562   pr "        croak (\"%%s\", guestfs_last_error (g));\n";
 563   pr "      EXTEND (SP, 2 * %d);\n" (List.length cols);
 564   List.iter (
 565     fun ((name, _) as col) ->
 566       pr "      PUSHs (sv_2mortal (newSVpv (\"%s\", 0)));\n" name;
 567
 568       match col with
 569       | name, FString ->
 570           pr "      PUSHs (sv_2mortal (newSVpv (r->%s, 0)));\n"
 571             name
 572       | name, FBuffer ->
 573           pr "      PUSHs (sv_2mortal (newSVpvn (r->%s, r->%s_len)));\n"
 574             name name
 575       | name, FUUID ->
 576           pr "      PUSHs (sv_2mortal (newSVpv (r->%s, 32)));\n"
 577             name
 578       | name, (FBytes|FUInt64) ->
 579           pr "      PUSHs (sv_2mortal (my_newSVull (r->%s)));\n"
 580             name
 581       | name, FInt64 ->
 582           pr "      PUSHs (sv_2mortal (my_newSVll (r->%s)));\n"
 583             name
 584       | name, (FInt32|FUInt32) ->
 585           pr "      PUSHs (sv_2mortal (newSVnv (r->%s)));\n"
 586             name
 587       | name, FChar ->
 588           pr "      PUSHs (sv_2mortal (newSVpv (&r->%s, 1)));\n"
 589             name
 590       | name, FOptPercent ->
 591           pr "      PUSHs (sv_2mortal (newSVnv (r->%s)));\n"
 592             name
 593   ) cols;
 594   pr "      free (r);\n"
 595
 596 (* Generate Sys/Guestfs.pm. *)
 597 and generate_perl_pm () =
 598   generate_header HashStyle LGPLv2plus;
 599
 600   pr "\
 601 =pod
 602
 603 =head1 NAME
 604
 605 Sys::Guestfs - Perl bindings for libguestfs
 606
 607 =head1 SYNOPSIS
 608
 609  use Sys::Guestfs;
 610
 611  my $h = Sys::Guestfs->new ();
 612  $h->add_drive_opts ('guest.img', format => 'raw');
 613  $h->launch ();
 614  $h->mount_options ('', '/dev/sda1', '/');
 615  $h->touch ('/hello');
 616  $h->sync ();
 617
 618 =head1 DESCRIPTION
 619
 620 The C<Sys::Guestfs> module provides a Perl XS binding to the
 621 libguestfs API for examining and modifying virtual machine
 622 disk images.
 623
 624 Amongst the things this is good for: making batch configuration
 625 changes to guests, getting disk used/free statistics (see also:
 626 virt-df), migrating between virtualization systems (see also:
 627 virt-p2v), performing partial backups, performing partial guest
 628 clones, cloning guests and changing registry/UUID/hostname info, and
 629 much else besides.
 630
 631 Libguestfs uses Linux kernel and qemu code, and can access any type of
 632 guest filesystem that Linux and qemu can, including but not limited
 633 to: ext2/3/4, btrfs, FAT and NTFS, LVM, many different disk partition
 634 schemes, qcow, qcow2, vmdk.
 635
 636 Libguestfs provides ways to enumerate guest storage (eg. partitions,
 637 LVs, what filesystem is in each LV, etc.).  It can also run commands
 638 in the context of the guest.  Also you can access filesystems over
 639 FUSE.
 640
 641 See also L<Sys::Guestfs::Lib(3)> for a set of useful library
 642 functions for using libguestfs from Perl, including integration
 643 with libvirt.
 644
 645 =head1 ERRORS
 646
 647 All errors turn into calls to C<croak> (see L<Carp(3)>).
 648
 649 The error string from libguestfs is directly available from
 650 C<$@>.  Use the C<last_errno> method if you want to get the errno.
 651
 652 =head1 METHODS
 653
 654 =over 4
 655
 656 =cut
 657
 658 package Sys::Guestfs;
 659
 660 use strict;
 661 use warnings;
 662
 663 # This version number changes whenever a new function
 664 # is added to the libguestfs API.  It is not directly
 665 # related to the libguestfs version number.
 666 use vars qw($VERSION);
 667 $VERSION = '0.%d';
 668
 669 require XSLoader;
 670 XSLoader::load ('Sys::Guestfs');
 671
 672 " max_proc_nr;
 673
 674   (* Methods. *)
 675   pr "\
 676 =item $h = Sys::Guestfs->new ();
 677
 678 Create a new guestfs handle.
 679
 680 =cut
 681
 682 sub new {
 683   my $proto = shift;
 684   my $class = ref ($proto) || $proto;
 685
 686   my $g = Sys::Guestfs::_create ();
 687   my $self = { _g => $g };
 688   bless $self, $class;
 689   return $self;
 690 }
 691
 692 =item $h->close ();
 693
 694 Explicitly close the guestfs handle.
 695
 696 B<Note:> You should not usually call this function.  The handle will
 697 be closed implicitly when its reference count goes to zero (eg.
 698 when it goes out of scope or the program ends).  This call is
 699 only required in some exceptional cases, such as where the program
 700 may contain cached references to the handle 'somewhere' and you
 701 really have to have the close happen right away.  After calling
 702 C<close> the program must not call any method (including C<close>)
 703 on the handle (but the implicit call to C<DESTROY> that happens
 704 when the final reference is cleaned up is OK).
 705
 706 ";
 707
 708   List.iter (
 709     fun (name, bitmask) ->
 710       pr "=item $Sys::Guestfs::EVENT_%s\n" (String.uppercase name);
 711       pr "\n";
 712       pr "See L<guestfs(3)/GUESTFS_EVENT_%s>.\n"
 713         (String.uppercase name);
 714       pr "\n";
 715       pr "=cut\n";
 716       pr "\n";
 717       pr "our $EVENT_%s = 0x%x;\n" (String.uppercase name) bitmask;
 718       pr "\n"
 719   ) events;
 720
 721   pr "\
 722 =item $event_handle = $h->set_event_callback (\\&cb, $event_bitmask);
 723
 724 Register C<cb> as a callback function for all of the events
 725 in C<$event_bitmask> (one or more C<$Sys::Guestfs::EVENT_*> flags
 726 logically or'd together).
 727
 728 This function returns an event handle which
 729 can be used to delete the callback using C<delete_event_callback>.
 730
 731 The callback function receives 4 parameters:
 732
 733  &cb ($event, $event_handle, $buf, $array)
 734
 735 =over 4
 736
 737 =item $event
 738
 739 The event which happened (equal to one of C<$Sys::Guestfs::EVENT_*>).
 740
 741 =item $event_handle
 742
 743 The event handle.
 744
 745 =item $buf
 746
 747 For some event types, this is a message buffer (ie. a string).
 748
 749 =item $array
 750
 751 For some event types (notably progress events), this is
 752 an array of integers.
 753
 754 =back
 755
 756 You should carefully read the documentation for
 757 L<guestfs(3)/guestfs_set_event_callback> before using
 758 this function.
 759
 760 =item $h->delete_event_callback ($event_handle);
 761
 762 This removes the callback which was previously registered using
 763 C<set_event_callback>.
 764
 765 =item $errnum = $h->last_errno ();
 766
 767 This returns the last error number (errno) that happened on the
 768 handle C<$h>.
 769
 770 If successful, an errno integer not equal to zero is returned.
 771
 772 If no error number is available, this returns 0.
 773 See L<guestfs(3)/guestfs_last_errno> for more details of why
 774 this can happen.
 775
 776 You can use the standard Perl module L<Errno(3)> to compare
 777 the numeric error returned from this call with symbolic
 778 errnos:
 779
 780  $h->mkdir (\"/foo\");
 781  if ($h->last_errno() == Errno::EEXIST()) {
 782    # mkdir failed because the directory exists already.
 783  }
 784
 785 =item $h->user_cancel ();
 786
 787 Cancel current transfer.  This is safe to call from Perl signal
 788 handlers and threads.
 789
 790 =cut
 791
 792 ";
 793
 794   (* Actions.  We only need to print documentation for these as
 795    * they are pulled in from the XS code automatically.
 796    *)
 797   List.iter (
 798     fun (name, style, _, flags, _, _, longdesc) ->
 799       if not (List.mem NotInDocs flags) then (
 800         let longdesc = replace_str longdesc "C<guestfs_" "C<$h-E<gt>" in
 801         pr "=item ";
 802         generate_perl_prototype name style;
 803         pr "\n\n";
 804         pr "%s\n\n" longdesc;
 805         if List.mem ProtocolLimitWarning flags then
 806           pr "%s\n\n" protocol_limit_warning;
 807         match deprecation_notice flags with
 808         | None -> ()
 809         | Some txt -> pr "%s\n\n" txt
 810       )
 811   ) all_functions_sorted;
 812
 813   pr "=cut\n\n";
 814
 815   (* Introspection hash. *)
 816   pr "use vars qw(%%guestfs_introspection);\n";
 817   pr "%%guestfs_introspection = (\n";
 818   List.iter (
 819     fun (name, (ret, args, optargs), _, _, _, shortdesc, _) ->
 820       pr "  \"%s\" => {\n" name;
 821       pr "    ret => ";
 822       (match ret with
 823        | RErr -> pr "'void'"
 824        | RInt _ -> pr "'int'"
 825        | RBool _ -> pr "'bool'"
 826        | RInt64 _ -> pr "'int64'"
 827        | RConstString _ -> pr "'const string'"
 828        | RConstOptString _ -> pr "'const nullable string'"
 829        | RString _ -> pr "'string'"
 830        | RStringList _ -> pr "'string list'"
 831        | RHashtable _ -> pr "'hash'"
 832        | RStruct (_, typ) -> pr "'struct %s'" typ
 833        | RStructList (_, typ) -> pr "'struct %s list'" typ
 834        | RBufferOut _ -> pr "'buffer'"
 835       );
 836       pr ",\n";
 837       let pr_type i = function
 838         | Pathname n -> pr "[ '%s', 'string(path)', %d ]" n i
 839         | Device n -> pr "[ '%s', 'string(device)', %d ]" n i
 840         | Dev_or_Path n -> pr "[ '%s', 'string(dev_or_path)', %d ]" n i
 841         | String n -> pr "[ '%s', 'string', %d ]" n i
 842         | FileIn n -> pr "[ '%s', 'string(filename)', %d ]" n i
 843         | FileOut n -> pr "[ '%s', 'string(filename)', %d ]" n i
 844         | Key n -> pr "[ '%s', 'string(key)', %d ]" n i
 845         | BufferIn n -> pr "[ '%s', 'buffer', %d ]" n i
 846         | OptString n -> pr "[ '%s', 'nullable string', %d ]" n i
 847         | StringList n -> pr "[ '%s', 'string list', %d ]" n i
 848         | DeviceList n -> pr "[ '%s', 'string(device) list', %d ]" n i
 849         | Bool n -> pr "[ '%s', 'bool', %d ]" n i
 850         | Int n -> pr "[ '%s', 'int', %d ]" n i
 851         | Int64 n -> pr "[ '%s', 'int64', %d ]" n i
 852         | Pointer (t, n) -> pr "[ '%s', 'pointer(%s)', %d ]" n t i
 853       in
 854       pr "    args => [\n";
 855       iteri (fun i arg ->
 856         pr "      ";
 857         pr_type i arg;
 858         pr ",\n"
 859       ) args;
 860       pr "    ],\n";
 861       if optargs <> [] then (
 862         pr "    optargs => {\n";
 863         iteri (fun i arg ->
 864           pr "      %s => " (name_of_argt arg);
 865           pr_type i arg;
 866           pr ",\n"
 867         ) optargs;
 868         pr "    },\n";
 869       );
 870       pr "    name => \"%s\",\n" name;
 871       pr "    description => %S,\n" shortdesc;
 872       pr "  },\n";
 873   ) all_functions_sorted;
 874   pr ");\n\n";
 875
 876   (* End of file. *)
 877   pr "\
 878 1;
 879
 880 =back
 881
 882 =head1 AVAILABILITY
 883
 884 From time to time we add new libguestfs APIs.  Also some libguestfs
 885 APIs won't be available in all builds of libguestfs (the Fedora
 886 build is full-featured, but other builds may disable features).
 887 How do you test whether the APIs that your Perl program needs are
 888 available in the version of C<Sys::Guestfs> that you are using?
 889
 890 To test if a particular function is available in the C<Sys::Guestfs>
 891 class, use the ordinary Perl UNIVERSAL method C<can(METHOD)>
 892 (see L<perlobj(1)>).  For example:
 893
 894  use Sys::Guestfs;
 895  if (defined (Sys::Guestfs->can (\"set_verbose\"))) {
 896    print \"\\$h->set_verbose is available\\n\";
 897  }
 898
 899 Perl does not offer a way to list the arguments of a method, and
 900 from time to time we may add extra arguments to calls that take
 901 optional arguments.  For this reason, we provide a global hash
 902 variable C<%%guestfs_introspection> which contains the arguments
 903 and their types for each libguestfs method.  The keys of this
 904 hash are the method names, and the values are an hashref
 905 containing useful introspection information about the method
 906 (further fields may be added to this in future).
 907
 908  use Sys::Guestfs;
 909  $Sys::Guestfs::guestfs_introspection{mkfs_opts}
 910  => {
 911     ret => 'void',                    # return type
 912     args => [                         # required arguments
 913       [ 'fstype', 'string', 0 ],
 914       [ 'device', 'string(device)', 1 ],
 915     ],
 916     optargs => {                      # optional arguments
 917       blocksize => [ 'blocksize', 'int', 0 ],
 918       features => [ 'features', 'string', 1 ],
 919       inode => [ 'inode', 'int', 2 ],
 920       sectorsize => [ 'sectorsize', 'int', 3 ],
 921     },
 922     name => \"mkfs_opts\",
 923     description => \"make a filesystem\",
 924   }
 925
 926 To test if particular features are supported by the current
 927 build, use the L</available> method like the example below.  Note
 928 that the appliance must be launched first.
 929
 930  $h->available ( [\"augeas\"] );
 931
 932 Since the L</available> method croaks if the feature is not supported,
 933 you might also want to wrap this in an eval and return a boolean.
 934 In fact this has already been done for you: use
 935 L<Sys::Guestfs::Lib(3)/feature_available>.
 936
 937 For further discussion on this topic, refer to
 938 L<guestfs(3)/AVAILABILITY>.
 939
 940 =head1 STORING DATA IN THE HANDLE
 941
 942 The handle returned from L</new> is a hash reference.  The hash
 943 normally contains a single element:
 944
 945  {
 946    _g => [private data used by libguestfs]
 947  }
 948
 949 Callers can add other elements to this hash to store data for their own
 950 purposes.  The data lasts for the lifetime of the handle.
 951
 952 Any fields whose names begin with an underscore are reserved
 953 for private use by libguestfs.  We may add more in future.
 954
 955 It is recommended that callers prefix the name of their field(s)
 956 with some unique string, to avoid conflicts with other users.
 957
 958 =head1 COPYRIGHT
 959
 960 Copyright (C) %s Red Hat Inc.
 961
 962 =head1 LICENSE
 963
 964 Please see the file COPYING.LIB for the full license.
 965
 966 =head1 SEE ALSO
 967
 968 L<guestfs(3)>,
 969 L<guestfish(1)>,
 970 L<http://libguestfs.org>,
 971 L<Sys::Guestfs::Lib(3)>.
 972
 973 =cut
 974 " copyright_years
 975
 976 and generate_perl_prototype name (ret, args, optargs) =
 977   (match ret with
 978    | RErr -> ()
 979    | RBool n
 980    | RInt n
 981    | RInt64 n
 982    | RConstString n
 983    | RConstOptString n
 984    | RString n
 985    | RBufferOut n -> pr "$%s = " n
 986    | RStruct (n,_)
 987    | RHashtable n -> pr "%%%s = " n
 988    | RStringList n
 989    | RStructList (n,_) -> pr "@%s = " n
 990   );
 991   pr "$h->%s (" name;
 992   let comma = ref false in
 993   List.iter (
 994     fun arg ->
 995       if !comma then pr ", ";
 996       comma := true;
 997       match arg with
 998       | Pathname n | Device n | Dev_or_Path n | String n
 999       | OptString n | Bool n | Int n | Int64 n | FileIn n | FileOut n
1000       | BufferIn n | Key n | Pointer (_, n) ->
1001           pr "$%s" n
1002       | StringList n | DeviceList n ->
1003           pr "\\@%s" n
1004   ) args;
1005   List.iter (
1006     fun arg ->
1007       if !comma then pr " [, " else pr "[";
1008       comma := true;
1009       let n = name_of_argt arg in
1010       pr "%s => $%s]" n n
1011   ) optargs;
1012   pr ");"