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