Version 1.11.9.
[libguestfs.git] / generator / generator_perl.ml
1 (* libguestfs
2  * Copyright (C) 2009-2011 Red Hat Inc.
3  *
4  * This program is free software; you can redistribute it and/or modify
5  * it under the terms of the GNU General Public License as published by
6  * the Free Software Foundation; either version 2 of the License, or
7  * (at your option) any later version.
8  *
9  * This program is distributed in the hope that it will be useful,
10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12  * GNU General Public License for more details.
13  *
14  * You should have received a copy of the GNU General Public License
15  * along with this program; if not, write to the Free Software
16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
17  *)
18
19 (* Please read generator/README first. *)
20
21 open Printf
22
23 open Generator_types
24 open Generator_utils
25 open Generator_pr
26 open Generator_docstrings
27 open Generator_optgroups
28 open Generator_actions
29 open Generator_structs
30 open Generator_c
31 open Generator_events
32
33 (* Generate Perl xs code, a sort of crazy variation of C with macros. *)
34 let rec generate_perl_xs () =
35   generate_header CStyle LGPLv2plus;
36
37   pr "\
38 #include \"EXTERN.h\"
39 #include \"perl.h\"
40 #include \"XSUB.h\"
41
42 #include <guestfs.h>
43
44 #ifndef PRId64
45 #define PRId64 \"lld\"
46 #endif
47
48 static SV *
49 my_newSVll(long long val) {
50 #ifdef USE_64_BIT_ALL
51   return newSViv(val);
52 #else
53   char buf[100];
54   int len;
55   len = snprintf(buf, 100, \"%%\" PRId64, val);
56   return newSVpv(buf, len);
57 #endif
58 }
59
60 #ifndef PRIu64
61 #define PRIu64 \"llu\"
62 #endif
63
64 static SV *
65 my_newSVull(unsigned long long val) {
66 #ifdef USE_64_BIT_ALL
67   return newSVuv(val);
68 #else
69   char buf[100];
70   int len;
71   len = snprintf(buf, 100, \"%%\" PRIu64, val);
72   return newSVpv(buf, len);
73 #endif
74 }
75
76 /* http://www.perlmonks.org/?node_id=680842 */
77 static char **
78 XS_unpack_charPtrPtr (SV *arg) {
79   char **ret;
80   AV *av;
81   I32 i;
82
83   if (!arg || !SvOK (arg) || !SvROK (arg) || SvTYPE (SvRV (arg)) != SVt_PVAV)
84     croak (\"array reference expected\");
85
86   av = (AV *)SvRV (arg);
87   ret = malloc ((av_len (av) + 1 + 1) * sizeof (char *));
88   if (!ret)
89     croak (\"malloc failed\");
90
91   for (i = 0; i <= av_len (av); i++) {
92     SV **elem = av_fetch (av, i, 0);
93
94     if (!elem || !*elem)
95       croak (\"missing element in list\");
96
97     ret[i] = SvPV_nolen (*elem);
98   }
99
100   ret[i] = NULL;
101
102   return ret;
103 }
104
105 /* http://www.perlmonks.org/?node=338857 */
106 static void
107 _event_callback_wrapper (guestfs_h *g,
108                          void *cb,
109                          uint64_t event,
110                          int event_handle,
111                          int flags,
112                          const char *buf, size_t buf_len,
113                          const uint64_t *array, size_t array_len)
114 {
115   dSP;
116   ENTER;
117   SAVETMPS;
118   PUSHMARK (SP);
119   XPUSHs (sv_2mortal (my_newSVull (event)));
120   XPUSHs (sv_2mortal (newSViv (event_handle)));
121   XPUSHs (sv_2mortal (newSVpvn (buf ? buf : \"\", buf_len)));
122   AV *av = newAV ();
123   size_t i;
124   for (i = 0; i < array_len; ++i)
125     av_push (av, my_newSVull (array[i]));
126   XPUSHs (sv_2mortal (newRV ((SV *) av)));
127   PUTBACK;
128   call_sv ((SV *) cb, G_VOID | G_DISCARD | G_EVAL);
129   FREETMPS;
130   LEAVE;
131 }
132
133 static SV **
134 get_all_event_callbacks (guestfs_h *g, size_t *len_rtn)
135 {
136   SV **r;
137   size_t i;
138   const char *key;
139   SV *cb;
140
141   /* Count the length of the array that will be needed. */
142   *len_rtn = 0;
143   cb = guestfs_first_private (g, &key);
144   while (cb != NULL) {
145     if (strncmp (key, \"_perl_event_\", strlen (\"_perl_event_\")) == 0)
146       (*len_rtn)++;
147     cb = guestfs_next_private (g, &key);
148   }
149
150   /* Copy them into the return array. */
151   r = guestfs_safe_malloc (g, sizeof (SV *) * (*len_rtn));
152
153   i = 0;
154   cb = guestfs_first_private (g, &key);
155   while (cb != NULL) {
156     if (strncmp (key, \"_perl_event_\", strlen (\"_perl_event_\")) == 0) {
157       r[i] = cb;
158       i++;
159     }
160     cb = guestfs_next_private (g, &key);
161   }
162
163   return r;
164 }
165
166 static void
167 _close_handle (guestfs_h *g)
168 {
169   size_t i, len;
170   SV **cbs;
171
172   assert (g != NULL);
173
174   /* As in the OCaml bindings, there is a hard to solve case where the
175    * caller can delete a callback from within the callback, resulting
176    * in a double-free here.  XXX
177    */
178   cbs = get_all_event_callbacks (g, &len);
179
180   guestfs_close (g);
181
182   for (i = 0; i < len; ++i)
183     SvREFCNT_dec (cbs[i]);
184 }
185
186 MODULE = Sys::Guestfs  PACKAGE = Sys::Guestfs
187
188 PROTOTYPES: ENABLE
189
190 guestfs_h *
191 _create ()
192    CODE:
193       RETVAL = guestfs_create ();
194       if (!RETVAL)
195         croak (\"could not create guestfs handle\");
196       guestfs_set_error_handler (RETVAL, NULL, NULL);
197  OUTPUT:
198       RETVAL
199
200 void
201 DESTROY (sv)
202       SV *sv;
203  PPCODE:
204       /* For the 'g' argument above we do the conversion explicitly and
205        * don't rely on the typemap, because if the handle has been
206        * explicitly closed we don't want the typemap conversion to
207        * display an error.
208        */
209       HV *hv = (HV *) SvRV (sv);
210       SV **svp = hv_fetch (hv, \"_g\", 2, 0);
211       if (svp != NULL) {
212         guestfs_h *g = (guestfs_h *) SvIV (*svp);
213         _close_handle (g);
214       }
215
216 void
217 close (g)
218       guestfs_h *g;
219  PPCODE:
220       _close_handle (g);
221       /* Avoid double-free in DESTROY method. */
222       HV *hv = (HV *) SvRV (ST(0));
223       (void) hv_delete (hv, \"_g\", 2, G_DISCARD);
224
225 SV *
226 set_event_callback (g, cb, event_bitmask)
227       guestfs_h *g;
228       SV *cb;
229       int event_bitmask;
230 PREINIT:
231       int eh;
232       char key[64];
233    CODE:
234       eh = guestfs_set_event_callback (g, _event_callback_wrapper,
235                                        event_bitmask, 0, cb);
236       if (eh == -1)
237         croak (\"%%s\", guestfs_last_error (g));
238
239       /* Increase the refcount for this callback, since we are storing
240        * it in the opaque C libguestfs handle.  We need to remember that
241        * we did this, so we can decrease the refcount for all undeleted
242        * callbacks left around at close time (see _close_handle).
243        */
244       SvREFCNT_inc (cb);
245
246       snprintf (key, sizeof key, \"_perl_event_%%d\", eh);
247       guestfs_set_private (g, key, cb);
248
249       RETVAL = newSViv (eh);
250  OUTPUT:
251       RETVAL
252
253 void
254 delete_event_callback (g, event_handle)
255       guestfs_h *g;
256       int event_handle;
257 PREINIT:
258       char key[64];
259       SV *cb;
260    CODE:
261       snprintf (key, sizeof key, \"_perl_event_%%d\", event_handle);
262       cb = guestfs_get_private (g, key);
263       if (cb) {
264         SvREFCNT_dec (cb);
265         guestfs_set_private (g, key, NULL);
266         guestfs_delete_event_callback (g, event_handle);
267       }
268
269 SV *
270 last_errno (g)
271       guestfs_h *g;
272 PREINIT:
273       int errnum;
274    CODE:
275       errnum = guestfs_last_errno (g);
276       RETVAL = newSViv (errnum);
277  OUTPUT:
278       RETVAL
279
280 ";
281
282   List.iter (
283     fun (name, (ret, args, optargs as style), _, _, _, _, _) ->
284       (match ret with
285        | RErr -> pr "void\n"
286        | RInt _ -> pr "SV *\n"
287        | RInt64 _ -> pr "SV *\n"
288        | RBool _ -> pr "SV *\n"
289        | RConstString _ -> pr "SV *\n"
290        | RConstOptString _ -> pr "SV *\n"
291        | RString _ -> pr "SV *\n"
292        | RBufferOut _ -> pr "SV *\n"
293        | RStringList _
294        | RStruct _ | RStructList _
295        | RHashtable _ ->
296            pr "void\n" (* all lists returned implictly on the stack *)
297       );
298       (* Call and arguments. *)
299       pr "%s (g" name;
300       List.iter (
301         fun arg -> pr ", %s" (name_of_argt arg)
302       ) args;
303       if optargs <> [] then
304         pr ", ...";
305       pr ")\n";
306       pr "      guestfs_h *g;\n";
307       iteri (
308         fun i ->
309           function
310           | Pathname n | Device n | Dev_or_Path n | String n
311           | FileIn n | FileOut n | Key n ->
312               pr "      char *%s;\n" n
313           | BufferIn n ->
314               pr "      char *%s;\n" n;
315               pr "      size_t %s_size = SvCUR (ST(%d));\n" n (i+1)
316           | OptString n ->
317               (* http://www.perlmonks.org/?node_id=554277
318                * Note that the implicit handle argument means we have
319                * to add 1 to the ST(x) operator.
320                *)
321               pr "      char *%s = SvOK(ST(%d)) ? SvPV_nolen(ST(%d)) : NULL;\n" n (i+1) (i+1)
322           | StringList n | DeviceList n -> pr "      char **%s;\n" n
323           | Bool n -> pr "      int %s;\n" n
324           | Int n -> pr "      int %s;\n" n
325           | Int64 n -> pr "      int64_t %s;\n" n
326           | Pointer (t, n) -> pr "      %s %s;\n" t n
327       ) args;
328
329       (* PREINIT section (local variable declarations). *)
330       pr "PREINIT:\n";
331       (match ret with
332        | RErr ->
333            pr "      int r;\n";
334        | RInt _
335        | RBool _ ->
336            pr "      int r;\n";
337        | RInt64 _ ->
338            pr "      int64_t r;\n";
339        | RConstString _ ->
340            pr "      const char *r;\n";
341        | RConstOptString _ ->
342            pr "      const char *r;\n";
343        | RString _ ->
344            pr "      char *r;\n";
345        | RStringList _ | RHashtable _ ->
346            pr "      char **r;\n";
347            pr "      size_t i, n;\n";
348        | RStruct (_, typ) ->
349            pr "      struct guestfs_%s *r;\n" typ;
350        | RStructList (_, typ) ->
351            pr "      struct guestfs_%s_list *r;\n" typ;
352            pr "      size_t i;\n";
353            pr "      HV *hv;\n";
354        | RBufferOut _ ->
355            pr "      char *r;\n";
356            pr "      size_t size;\n";
357       );
358
359       if optargs <> [] then (
360         pr "      struct guestfs_%s_argv optargs_s = { .bitmask = 0 };\n" name;
361         pr "      struct guestfs_%s_argv *optargs = &optargs_s;\n" name;
362         pr "      size_t items_i;\n";
363       );
364
365       (* CODE or PPCODE section.  PPCODE is used where we are
366        * returning void, or where we push the return value on the stack
367        * ourselves.  Using CODE means we will manipulate RETVAL.
368        *)
369       (match ret with
370        | RErr ->
371            pr " PPCODE:\n";
372        | RInt n
373        | RBool n ->
374            pr "   CODE:\n";
375        | RInt64 n ->
376            pr "   CODE:\n";
377        | RConstString n ->
378            pr "   CODE:\n";
379        | RConstOptString n ->
380            pr "   CODE:\n";
381        | RString n ->
382            pr "   CODE:\n";
383        | RStringList n | RHashtable n ->
384            pr " PPCODE:\n";
385        | RBufferOut n ->
386            pr "   CODE:\n";
387        | RStruct _
388        | RStructList _ ->
389            pr " PPCODE:\n";
390       );
391
392       (* For optional arguments, convert these from the XSUB "items"
393        * variable by hand.
394        *)
395       if optargs <> [] then (
396         let uc_name = String.uppercase name in
397         let skip = List.length args + 1 in
398         pr "      if (((items - %d) & 1) != 0)\n" skip;
399         pr "        croak (\"expecting an even number of extra parameters\");\n";
400         pr "      for (items_i = %d; items_i < items; items_i += 2) {\n" skip;
401         pr "        uint64_t this_mask;\n";
402         pr "        const char *this_arg;\n";
403         pr "\n";
404         pr "        this_arg = SvPV_nolen (ST (items_i));\n";
405         pr "        ";
406         List.iter (
407           fun argt ->
408             let n = name_of_argt argt in
409             let uc_n = String.uppercase n in
410             pr "if (strcmp (this_arg, \"%s\") == 0) {\n" n;
411             pr "          optargs_s.%s = " n;
412             (match argt with
413              | Bool _
414              | Int _
415              | Int64 _ -> pr "SvIV (ST (items_i+1))"
416              | String _ -> pr "SvPV_nolen (ST (items_i+1))"
417              | _ -> assert false
418             );
419             pr ";\n";
420             pr "          this_mask = GUESTFS_%s_%s_BITMASK;\n" uc_name uc_n;
421             pr "        }\n";
422             pr "        else ";
423         ) optargs;
424         pr "croak (\"unknown optional argument '%%s'\", this_arg);\n";
425         pr "        if (optargs_s.bitmask & this_mask)\n";
426         pr "          croak (\"optional argument '%%s' given twice\",\n";
427         pr "                 this_arg);\n";
428         pr "        optargs_s.bitmask |= this_mask;\n";
429         pr "      }\n";
430         pr "\n";
431       );
432
433       (* The call to the C function. *)
434       if optargs = [] then
435         pr "      r = guestfs_%s " name
436       else
437         pr "      r = guestfs_%s_argv " name;
438       generate_c_call_args ~handle:"g" style;
439       pr ";\n";
440
441       (* Cleanup any arguments. *)
442       List.iter (
443         function
444         | Pathname _ | Device _ | Dev_or_Path _ | String _ | OptString _
445         | Bool _ | Int _ | Int64 _
446         | FileIn _ | FileOut _
447         | BufferIn _ | Key _ | Pointer _ -> ()
448         | StringList n | DeviceList n -> pr "      free (%s);\n" n
449       ) args;
450
451       (* Check return value for errors and return it if necessary. *)
452       (match ret with
453        | RErr ->
454            pr "      if (r == -1)\n";
455            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
456        | RInt n
457        | RBool n ->
458            pr "      if (r == -1)\n";
459            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
460            pr "      RETVAL = newSViv (r);\n";
461            pr " OUTPUT:\n";
462            pr "      RETVAL\n"
463        | RInt64 n ->
464            pr "      if (r == -1)\n";
465            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
466            pr "      RETVAL = my_newSVll (r);\n";
467            pr " OUTPUT:\n";
468            pr "      RETVAL\n"
469        | RConstString n ->
470            pr "      if (r == NULL)\n";
471            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
472            pr "      RETVAL = newSVpv (r, 0);\n";
473            pr " OUTPUT:\n";
474            pr "      RETVAL\n"
475        | RConstOptString n ->
476            pr "      if (r == NULL)\n";
477            pr "        RETVAL = &PL_sv_undef;\n";
478            pr "      else\n";
479            pr "        RETVAL = newSVpv (r, 0);\n";
480            pr " OUTPUT:\n";
481            pr "      RETVAL\n"
482        | RString n ->
483            pr "      if (r == NULL)\n";
484            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
485            pr "      RETVAL = newSVpv (r, 0);\n";
486            pr "      free (r);\n";
487            pr " OUTPUT:\n";
488            pr "      RETVAL\n"
489        | RStringList n | RHashtable n ->
490            pr "      if (r == NULL)\n";
491            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
492            pr "      for (n = 0; r[n] != NULL; ++n) /**/;\n";
493            pr "      EXTEND (SP, n);\n";
494            pr "      for (i = 0; i < n; ++i) {\n";
495            pr "        PUSHs (sv_2mortal (newSVpv (r[i], 0)));\n";
496            pr "        free (r[i]);\n";
497            pr "      }\n";
498            pr "      free (r);\n";
499        | RStruct (n, typ) ->
500            let cols = cols_of_struct typ in
501            generate_perl_struct_code typ cols name style n
502        | RStructList (n, typ) ->
503            let cols = cols_of_struct typ in
504            generate_perl_struct_list_code typ cols name style n
505        | RBufferOut n ->
506            pr "      if (r == NULL)\n";
507            pr "        croak (\"%%s\", guestfs_last_error (g));\n";
508            pr "      RETVAL = newSVpvn (r, size);\n";
509            pr "      free (r);\n";
510            pr " OUTPUT:\n";
511            pr "      RETVAL\n"
512       );
513
514       pr "\n"
515   ) all_functions
516
517 and generate_perl_struct_list_code typ cols name style n =
518   pr "      if (r == NULL)\n";
519   pr "        croak (\"%%s\", guestfs_last_error (g));\n";
520   pr "      EXTEND (SP, r->len);\n";
521   pr "      for (i = 0; i < r->len; ++i) {\n";
522   pr "        hv = newHV ();\n";
523   List.iter (
524     function
525     | name, FString ->
526         pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (r->val[i].%s, 0), 0);\n"
527           name (String.length name) name
528     | name, FUUID ->
529         pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (r->val[i].%s, 32), 0);\n"
530           name (String.length name) name
531     | name, FBuffer ->
532         pr "        (void) hv_store (hv, \"%s\", %d, newSVpvn (r->val[i].%s, r->val[i].%s_len), 0);\n"
533           name (String.length name) name name
534     | name, (FBytes|FUInt64) ->
535         pr "        (void) hv_store (hv, \"%s\", %d, my_newSVull (r->val[i].%s), 0);\n"
536           name (String.length name) name
537     | name, FInt64 ->
538         pr "        (void) hv_store (hv, \"%s\", %d, my_newSVll (r->val[i].%s), 0);\n"
539           name (String.length name) name
540     | name, (FInt32|FUInt32) ->
541         pr "        (void) hv_store (hv, \"%s\", %d, newSVnv (r->val[i].%s), 0);\n"
542           name (String.length name) name
543     | name, FChar ->
544         pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (&r->val[i].%s, 1), 0);\n"
545           name (String.length name) name
546     | name, FOptPercent ->
547         pr "        (void) hv_store (hv, \"%s\", %d, newSVnv (r->val[i].%s), 0);\n"
548           name (String.length name) name
549   ) cols;
550   pr "        PUSHs (sv_2mortal (newRV ((SV *) hv)));\n";
551   pr "      }\n";
552   pr "      guestfs_free_%s_list (r);\n" typ
553
554 and generate_perl_struct_code typ cols name style n =
555   pr "      if (r == NULL)\n";
556   pr "        croak (\"%%s\", guestfs_last_error (g));\n";
557   pr "      EXTEND (SP, 2 * %d);\n" (List.length cols);
558   List.iter (
559     fun ((name, _) as col) ->
560       pr "      PUSHs (sv_2mortal (newSVpv (\"%s\", 0)));\n" name;
561
562       match col with
563       | name, FString ->
564           pr "      PUSHs (sv_2mortal (newSVpv (r->%s, 0)));\n"
565             name
566       | name, FBuffer ->
567           pr "      PUSHs (sv_2mortal (newSVpvn (r->%s, r->%s_len)));\n"
568             name name
569       | name, FUUID ->
570           pr "      PUSHs (sv_2mortal (newSVpv (r->%s, 32)));\n"
571             name
572       | name, (FBytes|FUInt64) ->
573           pr "      PUSHs (sv_2mortal (my_newSVull (r->%s)));\n"
574             name
575       | name, FInt64 ->
576           pr "      PUSHs (sv_2mortal (my_newSVll (r->%s)));\n"
577             name
578       | name, (FInt32|FUInt32) ->
579           pr "      PUSHs (sv_2mortal (newSVnv (r->%s)));\n"
580             name
581       | name, FChar ->
582           pr "      PUSHs (sv_2mortal (newSVpv (&r->%s, 1)));\n"
583             name
584       | name, FOptPercent ->
585           pr "      PUSHs (sv_2mortal (newSVnv (r->%s)));\n"
586             name
587   ) cols;
588   pr "      free (r);\n"
589
590 (* Generate Sys/Guestfs.pm. *)
591 and generate_perl_pm () =
592   generate_header HashStyle LGPLv2plus;
593
594   pr "\
595 =pod
596
597 =head1 NAME
598
599 Sys::Guestfs - Perl bindings for libguestfs
600
601 =head1 SYNOPSIS
602
603  use Sys::Guestfs;
604
605  my $h = Sys::Guestfs->new ();
606  $h->add_drive_opts ('guest.img', format => 'raw');
607  $h->launch ();
608  $h->mount_options ('', '/dev/sda1', '/');
609  $h->touch ('/hello');
610  $h->sync ();
611
612 =head1 DESCRIPTION
613
614 The C<Sys::Guestfs> module provides a Perl XS binding to the
615 libguestfs API for examining and modifying virtual machine
616 disk images.
617
618 Amongst the things this is good for: making batch configuration
619 changes to guests, getting disk used/free statistics (see also:
620 virt-df), migrating between virtualization systems (see also:
621 virt-p2v), performing partial backups, performing partial guest
622 clones, cloning guests and changing registry/UUID/hostname info, and
623 much else besides.
624
625 Libguestfs uses Linux kernel and qemu code, and can access any type of
626 guest filesystem that Linux and qemu can, including but not limited
627 to: ext2/3/4, btrfs, FAT and NTFS, LVM, many different disk partition
628 schemes, qcow, qcow2, vmdk.
629
630 Libguestfs provides ways to enumerate guest storage (eg. partitions,
631 LVs, what filesystem is in each LV, etc.).  It can also run commands
632 in the context of the guest.  Also you can access filesystems over
633 FUSE.
634
635 See also L<Sys::Guestfs::Lib(3)> for a set of useful library
636 functions for using libguestfs from Perl, including integration
637 with libvirt.
638
639 =head1 ERRORS
640
641 All errors turn into calls to C<croak> (see L<Carp(3)>).
642
643 The error string from libguestfs is directly available from
644 C<$@>.  Use the C<last_errno> method if you want to get the errno.
645
646 =head1 METHODS
647
648 =over 4
649
650 =cut
651
652 package Sys::Guestfs;
653
654 use strict;
655 use warnings;
656
657 # This version number changes whenever a new function
658 # is added to the libguestfs API.  It is not directly
659 # related to the libguestfs version number.
660 use vars qw($VERSION);
661 $VERSION = '0.%d';
662
663 require XSLoader;
664 XSLoader::load ('Sys::Guestfs');
665
666 " max_proc_nr;
667
668   (* Methods. *)
669   pr "\
670 =item $h = Sys::Guestfs->new ();
671
672 Create a new guestfs handle.
673
674 =cut
675
676 sub new {
677   my $proto = shift;
678   my $class = ref ($proto) || $proto;
679
680   my $g = Sys::Guestfs::_create ();
681   my $self = { _g => $g };
682   bless $self, $class;
683   return $self;
684 }
685
686 =item $h->close ();
687
688 Explicitly close the guestfs handle.
689
690 B<Note:> You should not usually call this function.  The handle will
691 be closed implicitly when its reference count goes to zero (eg.
692 when it goes out of scope or the program ends).  This call is
693 only required in some exceptional cases, such as where the program
694 may contain cached references to the handle 'somewhere' and you
695 really have to have the close happen right away.  After calling
696 C<close> the program must not call any method (including C<close>)
697 on the handle (but the implicit call to C<DESTROY> that happens
698 when the final reference is cleaned up is OK).
699
700 ";
701
702   List.iter (
703     fun (name, bitmask) ->
704       pr "=item $Sys::Guestfs::EVENT_%s\n" (String.uppercase name);
705       pr "\n";
706       pr "See L<guestfs(3)/GUESTFS_EVENT_%s>.\n"
707         (String.uppercase name);
708       pr "\n";
709       pr "=cut\n";
710       pr "\n";
711       pr "our $EVENT_%s = 0x%x;\n" (String.uppercase name) bitmask;
712       pr "\n"
713   ) events;
714
715   pr "\
716 =item $event_handle = $h->set_event_callback (\\&cb, $event_bitmask);
717
718 Register C<cb> as a callback function for all of the events
719 in C<$event_bitmask> (one or more C<$Sys::Guestfs::EVENT_*> flags
720 logically or'd together).
721
722 This function returns an event handle which
723 can be used to delete the callback using C<delete_event_callback>.
724
725 The callback function receives 4 parameters:
726
727  &cb ($event, $event_handle, $buf, $array)
728
729 =over 4
730
731 =item $event
732
733 The event which happened (equal to one of C<$Sys::Guestfs::EVENT_*>).
734
735 =item $event_handle
736
737 The event handle.
738
739 =item $buf
740
741 For some event types, this is a message buffer (ie. a string).
742
743 =item $array
744
745 For some event types (notably progress events), this is
746 an array of integers.
747
748 =back
749
750 You should carefully read the documentation for
751 L<guestfs(3)/guestfs_set_event_callback> before using
752 this function.
753
754 =item $h->delete_event_callback ($event_handle);
755
756 This removes the callback which was previously registered using
757 C<set_event_callback>.
758
759 =item $errnum = $h->last_errno ();
760
761 This returns the last error number (errno) that happened on the
762 handle C<$h>.
763
764 If successful, an errno integer not equal to zero is returned.
765
766 If no error number is available, this returns 0.
767 See L<guestfs(3)/guestfs_last_errno> for more details of why
768 this can happen.
769
770 You can use the standard Perl module L<Errno(3)> to compare
771 the numeric error returned from this call with symbolic
772 errnos:
773
774  $h->mkdir (\"/foo\");
775  if ($h->last_errno() == Errno::EEXIST()) {
776    # mkdir failed because the directory exists already.
777  }
778
779 =cut
780
781 ";
782
783   (* Actions.  We only need to print documentation for these as
784    * they are pulled in from the XS code automatically.
785    *)
786   List.iter (
787     fun (name, style, _, flags, _, _, longdesc) ->
788       if not (List.mem NotInDocs flags) then (
789         let longdesc = replace_str longdesc "C<guestfs_" "C<$h-E<gt>" in
790         pr "=item ";
791         generate_perl_prototype name style;
792         pr "\n\n";
793         pr "%s\n\n" longdesc;
794         if List.mem ProtocolLimitWarning flags then
795           pr "%s\n\n" protocol_limit_warning;
796         if List.mem DangerWillRobinson flags then
797           pr "%s\n\n" danger_will_robinson;
798         match deprecation_notice flags with
799         | None -> ()
800         | Some txt -> pr "%s\n\n" txt
801       )
802   ) all_functions_sorted;
803
804   (* End of file. *)
805   pr "\
806 =cut
807
808 1;
809
810 =back
811
812 =head1 AVAILABILITY
813
814 From time to time we add new libguestfs APIs.  Also some libguestfs
815 APIs won't be available in all builds of libguestfs (the Fedora
816 build is full-featured, but other builds may disable features).
817 How do you test whether the APIs that your Perl program needs are
818 available in the version of C<Sys::Guestfs> that you are using?
819
820 To test if a particular function is available in the C<Sys::Guestfs>
821 class, use the ordinary Perl UNIVERSAL method C<can(METHOD)>
822 (see L<perlobj(1)>).  For example:
823
824  use Sys::Guestfs;
825  if (defined (Sys::Guestfs->can (\"set_verbose\"))) {
826    print \"\\$h->set_verbose is available\\n\";
827  }
828
829 To test if particular features are supported by the current
830 build, use the L</available> method like the example below.  Note
831 that the appliance must be launched first.
832
833  $h->available ( [\"augeas\"] );
834
835 Since the L</available> method croaks if the feature is not supported,
836 you might also want to wrap this in an eval and return a boolean.
837 In fact this has already been done for you: use
838 L<Sys::Guestfs::Lib(3)/feature_available>.
839
840 For further discussion on this topic, refer to
841 L<guestfs(3)/AVAILABILITY>.
842
843 =head1 STORING DATA IN THE HANDLE
844
845 The handle returned from L</new> is a hash reference.  The hash
846 normally contains a single element:
847
848  {
849    _g => [private data used by libguestfs]
850  }
851
852 Callers can add other elements to this hash to store data for their own
853 purposes.  The data lasts for the lifetime of the handle.
854
855 Any fields whose names begin with an underscore are reserved
856 for private use by libguestfs.  We may add more in future.
857
858 It is recommended that callers prefix the name of their field(s)
859 with some unique string, to avoid conflicts with other users.
860
861 =head1 COPYRIGHT
862
863 Copyright (C) %s Red Hat Inc.
864
865 =head1 LICENSE
866
867 Please see the file COPYING.LIB for the full license.
868
869 =head1 SEE ALSO
870
871 L<guestfs(3)>,
872 L<guestfish(1)>,
873 L<http://libguestfs.org>,
874 L<Sys::Guestfs::Lib(3)>.
875
876 =cut
877 " copyright_years
878
879 and generate_perl_prototype name (ret, args, optargs) =
880   (match ret with
881    | RErr -> ()
882    | RBool n
883    | RInt n
884    | RInt64 n
885    | RConstString n
886    | RConstOptString n
887    | RString n
888    | RBufferOut n -> pr "$%s = " n
889    | RStruct (n,_)
890    | RHashtable n -> pr "%%%s = " n
891    | RStringList n
892    | RStructList (n,_) -> pr "@%s = " n
893   );
894   pr "$h->%s (" name;
895   let comma = ref false in
896   List.iter (
897     fun arg ->
898       if !comma then pr ", ";
899       comma := true;
900       match arg with
901       | Pathname n | Device n | Dev_or_Path n | String n
902       | OptString n | Bool n | Int n | Int64 n | FileIn n | FileOut n
903       | BufferIn n | Key n | Pointer (_, n) ->
904           pr "$%s" n
905       | StringList n | DeviceList n ->
906           pr "\\@%s" n
907   ) args;
908   List.iter (
909     fun arg ->
910       if !comma then pr " [, " else pr "[";
911       comma := true;
912       let n = name_of_argt arg in
913       pr "%s => $%s]" n n
914   ) optargs;
915   pr ");"