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