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