src/generator.ml

   1 #!/usr/bin/env ocaml
   2 (* libguestfs
   3  * Copyright (C) 2009 Red Hat Inc.
   4  *
   5  * This program is free software; you can redistribute it and/or modify
   6  * it under the terms of the GNU General Public License as published by
   7  * the Free Software Foundation; either version 2 of the License, or
   8  * (at your option) any later version.
   9  *
  10  * This program is distributed in the hope that it will be useful,
  11  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13  * GNU General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU General Public License
  16  * along with this program; if not, write to the Free Software
  17  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18  *
  19  * This script generates a large amount of code and documentation for
  20  * all the daemon actions.  To add a new action there are only two
  21  * files you need to change, this one to describe the interface, and
  22  * daemon/<somefile>.c to write the implementation.
  23  *)
  24
  25 #load "unix.cma";;
  26
  27 open Printf
  28
  29 type style = ret * args
  30 and ret =
  31     (* "Err" as a return value means an int used as a simple error
  32      * indication, ie. 0 or -1.
  33      *)
  34   | Err
  35     (* "RString" and "RStringList" require special treatment because
  36      * the caller must free them.
  37      *)
  38   | RString of string
  39   | RStringList of string
  40     (* LVM PVs, VGs and LVs. *)
  41   | RPVList of string
  42   | RVGList of string
  43   | RLVList of string
  44 and args =
  45     (* 0 arguments, 1 argument, etc. The guestfs_h param is implicit. *)
  46   | P0
  47   | P1 of argt
  48   | P2 of argt * argt
  49 and argt =
  50   | String of string    (* const char *name, cannot be NULL *)
  51
  52 type flags = ProtocolLimitWarning
  53
  54 (* Note about long descriptions: When referring to another
  55  * action, use the format C<guestfs_other> (ie. the full name of
  56  * the C function).  This will be replaced as appropriate in other
  57  * language bindings.
  58  *
  59  * Apart from that, long descriptions are just perldoc paragraphs.
  60  *)
  61
  62 let functions = [
  63   ("mount", (Err, P2 (String "device", String "mountpoint")), 1, [],
  64    "mount a guest disk at a position in the filesystem",
  65    "\
  66 Mount a guest disk at a position in the filesystem.  Block devices
  67 are named C</dev/sda>, C</dev/sdb> and so on, as they were added to
  68 the guest.  If those block devices contain partitions, they will have
  69 the usual names (eg. C</dev/sda1>).  Also LVM C</dev/VG/LV>-style
  70 names can be used.
  71
  72 The rules are the same as for L<mount(2)>:  A filesystem must
  73 first be mounted on C</> before others can be mounted.  Other
  74 filesystems can only be mounted on directories which already
  75 exist.
  76
  77 The mounted filesystem is writable, if we have sufficient permissions
  78 on the underlying device.
  79
  80 The filesystem options C<sync> and C<noatime> are set with this
  81 call, in order to improve reliability.");
  82
  83   ("sync", (Err, P0), 2, [],
  84    "sync disks, writes are flushed through to the disk image",
  85    "\
  86 This syncs the disk, so that any writes are flushed through to the
  87 underlying disk image.
  88
  89 You should always call this if you have modified a disk image, before
  90 closing the handle.");
  91
  92   ("touch", (Err, P1 (String "path")), 3, [],
  93    "update file timestamps or create a new file",
  94    "\
  95 Touch acts like the L<touch(1)> command.  It can be used to
  96 update the timestamps on a file, or, if the file does not exist,
  97 to create a new zero-length file.");
  98
  99   ("cat", (RString "content", P1 (String "path")), 4, [ProtocolLimitWarning],
 100    "list the contents of a file",
 101    "\
 102 Return the contents of the file named C<path>.
 103
 104 Note that this function cannot correctly handle binary files
 105 (specifically, files containing C<\\0> character which is treated
 106 as end of string).  For those you need to use the C<guestfs_read_file>
 107 function which has a more complex interface.");
 108
 109   ("ll", (RString "listing", P1 (String "directory")), 5, [],
 110    "list the files in a directory (long format)",
 111    "\
 112 List the files in C<directory> (relative to the root directory,
 113 there is no cwd) in the format of 'ls -la'.
 114
 115 This command is mostly useful for interactive sessions.  It
 116 is I<not> intended that you try to parse the output string.");
 117
 118   ("ls", (RStringList "listing", P1 (String "directory")), 6, [],
 119    "list the files in a directory",
 120    "\
 121 List the files in C<directory> (relative to the root directory,
 122 there is no cwd).  The '.' and '..' entries are not returned, but
 123 hidden files are shown.
 124
 125 This command is mostly useful for interactive sessions.  Programs
 126 should probably use C<guestfs_readdir> instead.");
 127
 128   ("list_devices", (RStringList "devices", P0), 7, [],
 129    "list the block devices",
 130    "\
 131 List all the block devices.
 132
 133 The full block device names are returned, eg. C</dev/sda>");
 134
 135   ("list_partitions", (RStringList "partitions", P0), 8, [],
 136    "list the partitions",
 137    "\
 138 List all the partitions detected on all block devices.
 139
 140 The full partition device names are returned, eg. C</dev/sda1>
 141
 142 This does not return logical volumes.  For that you will need to
 143 call C<guestfs_lvs>.");
 144
 145   ("pvs", (RStringList "physvols", P0), 9, [],
 146    "list the LVM physical volumes (PVs)",
 147    "\
 148 List all the physical volumes detected.  This is the equivalent
 149 of the L<pvs(8)> command.
 150
 151 This returns a list of just the device names that contain
 152 PVs (eg. C</dev/sda2>).
 153
 154 See also C<guestfs_pvs_full>.");
 155
 156   ("vgs", (RStringList "volgroups", P0), 10, [],
 157    "list the LVM volume groups (VGs)",
 158    "\
 159 List all the volumes groups detected.  This is the equivalent
 160 of the L<vgs(8)> command.
 161
 162 This returns a list of just the volume group names that were
 163 detected (eg. C<VolGroup00>).
 164
 165 See also C<guestfs_vgs_full>.");
 166
 167   ("lvs", (RStringList "logvols", P0), 11, [],
 168    "list the LVM logical volumes (LVs)",
 169    "\
 170 List all the logical volumes detected.  This is the equivalent
 171 of the L<lvs(8)> command.
 172
 173 This returns a list of the logical volume device names
 174 (eg. C</dev/VolGroup00/LogVol00>).
 175
 176 See also C<guestfs_lvs_full>.");
 177
 178   ("pvs_full", (RPVList "physvols", P0), 12, [],
 179    "list the LVM physical volumes (PVs)",
 180    "\
 181 List all the physical volumes detected.  This is the equivalent
 182 of the L<pvs(8)> command.  The \"full\" version includes all fields.");
 183
 184   ("vgs_full", (RVGList "volgroups", P0), 13, [],
 185    "list the LVM volume groups (VGs)",
 186    "\
 187 List all the volumes groups detected.  This is the equivalent
 188 of the L<vgs(8)> command.  The \"full\" version includes all fields.");
 189
 190   ("lvs_full", (RLVList "logvols", P0), 14, [],
 191    "list the LVM logical volumes (LVs)",
 192    "\
 193 List all the logical volumes detected.  This is the equivalent
 194 of the L<lvs(8)> command.  The \"full\" version includes all fields.");
 195 ]
 196
 197 (* Column names and types from LVM PVs/VGs/LVs. *)
 198 let pv_cols = [
 199   "pv_name", `String;
 200   "pv_uuid", `UUID;
 201   "pv_fmt", `String;
 202   "pv_size", `Bytes;
 203   "dev_size", `Bytes;
 204   "pv_free", `Bytes;
 205   "pv_used", `Bytes;
 206   "pv_attr", `String (* XXX *);
 207   "pv_pe_count", `Int;
 208   "pv_pe_alloc_count", `Int;
 209   "pv_tags", `String;
 210   "pe_start", `Bytes;
 211   "pv_mda_count", `Int;
 212   "pv_mda_free", `Bytes;
 213 (* Not in Fedora 10:
 214   "pv_mda_size", `Bytes;
 215 *)
 216 ]
 217 let vg_cols = [
 218   "vg_name", `String;
 219   "vg_uuid", `UUID;
 220   "vg_fmt", `String;
 221   "vg_attr", `String (* XXX *);
 222   "vg_size", `Bytes;
 223   "vg_free", `Bytes;
 224   "vg_sysid", `String;
 225   "vg_extent_size", `Bytes;
 226   "vg_extent_count", `Int;
 227   "vg_free_count", `Int;
 228   "max_lv", `Int;
 229   "max_pv", `Int;
 230   "pv_count", `Int;
 231   "lv_count", `Int;
 232   "snap_count", `Int;
 233   "vg_seqno", `Int;
 234   "vg_tags", `String;
 235   "vg_mda_count", `Int;
 236   "vg_mda_free", `Bytes;
 237 (* Not in Fedora 10:
 238   "vg_mda_size", `Bytes;
 239 *)
 240 ]
 241 let lv_cols = [
 242   "lv_name", `String;
 243   "lv_uuid", `UUID;
 244   "lv_attr", `String (* XXX *);
 245   "lv_major", `Int;
 246   "lv_minor", `Int;
 247   "lv_kernel_major", `Int;
 248   "lv_kernel_minor", `Int;
 249   "lv_size", `Bytes;
 250   "seg_count", `Int;
 251   "origin", `String;
 252   "snap_percent", `OptPercent;
 253   "copy_percent", `OptPercent;
 254   "move_pv", `String;
 255   "lv_tags", `String;
 256   "mirror_log", `String;
 257   "modules", `String;
 258 ]
 259
 260 (* In some places we want the functions to be displayed sorted
 261  * alphabetically, so this is useful:
 262  *)
 263 let sorted_functions =
 264   List.sort (fun (n1,_,_,_,_,_) (n2,_,_,_,_,_) -> compare n1 n2) functions
 265
 266 (* Useful functions.
 267  * Note we don't want to use any external OCaml libraries which
 268  * makes this a bit harder than it should be.
 269  *)
 270 let failwithf fs = ksprintf failwith fs
 271
 272 let replace_char s c1 c2 =
 273   let s2 = String.copy s in
 274   let r = ref false in
 275   for i = 0 to String.length s2 - 1 do
 276     if String.unsafe_get s2 i = c1 then (
 277       String.unsafe_set s2 i c2;
 278       r := true
 279     )
 280   done;
 281   if not !r then s else s2
 282
 283 let rec find s sub =
 284   let len = String.length s in
 285   let sublen = String.length sub in
 286   let rec loop i =
 287     if i <= len-sublen then (
 288       let rec loop2 j =
 289         if j < sublen then (
 290           if s.[i+j] = sub.[j] then loop2 (j+1)
 291           else -1
 292         ) else
 293           i (* found *)
 294       in
 295       let r = loop2 0 in
 296       if r = -1 then loop (i+1) else r
 297     ) else
 298       -1 (* not found *)
 299   in
 300   loop 0
 301
 302 let rec replace_str s s1 s2 =
 303   let len = String.length s in
 304   let sublen = String.length s1 in
 305   let i = find s s1 in
 306   if i = -1 then s
 307   else (
 308     let s' = String.sub s 0 i in
 309     let s'' = String.sub s (i+sublen) (len-i-sublen) in
 310     s' ^ s2 ^ replace_str s'' s1 s2
 311   )
 312
 313 (* 'pr' prints to the current output file. *)
 314 let chan = ref stdout
 315 let pr fs = ksprintf (output_string !chan) fs
 316
 317 let iter_args f = function
 318   | P0 -> ()
 319   | P1 arg1 -> f arg1
 320   | P2 (arg1, arg2) -> f arg1; f arg2
 321
 322 let iteri_args f = function
 323   | P0 -> ()
 324   | P1 arg1 -> f 0 arg1
 325   | P2 (arg1, arg2) -> f 0 arg1; f 1 arg2
 326
 327 let map_args f = function
 328   | P0 -> []
 329   | P1 arg1 -> [f arg1]
 330   | P2 (arg1, arg2) -> [f arg1; f arg2]
 331
 332 let nr_args = function | P0 -> 0 | P1 _ -> 1 | P2 _ -> 2
 333
 334 (* Check function names etc. for consistency. *)
 335 let check_functions () =
 336   List.iter (
 337     fun (name, _, _, _, _, longdesc) ->
 338       if String.contains name '-' then
 339         failwithf "Function name '%s' should not contain '-', use '_' instead."
 340           name;
 341       if longdesc.[String.length longdesc-1] = '\n' then
 342         failwithf "Long description of %s should not end with \\n." name
 343   ) functions;
 344
 345   let proc_nrs =
 346     List.map (fun (name, _, proc_nr, _, _, _) -> name, proc_nr) functions in
 347   let proc_nrs =
 348     List.sort (fun (_,nr1) (_,nr2) -> compare nr1 nr2) proc_nrs in
 349   let rec loop = function
 350     | [] -> ()
 351     | [_] -> ()
 352     | (name1,nr1) :: ((name2,nr2) :: _ as rest) when nr1 < nr2 ->
 353         loop rest
 354     | (name1,nr1) :: (name2,nr2) :: _ ->
 355         failwithf "'%s' and '%s' have conflicting procedure numbers (%d, %d)"
 356           name1 name2 nr1 nr2
 357   in
 358   loop proc_nrs
 359
 360 type comment_style = CStyle | HashStyle | OCamlStyle
 361 type license = GPLv2 | LGPLv2
 362
 363 (* Generate a header block in a number of standard styles. *)
 364 let rec generate_header comment license =
 365   let c = match comment with
 366     | CStyle ->     pr "/* "; " *"
 367     | HashStyle ->  pr "# ";  "#"
 368     | OCamlStyle -> pr "(* "; " *" in
 369   pr "libguestfs generated file\n";
 370   pr "%s WARNING: THIS FILE IS GENERATED BY 'src/generator.ml'.\n" c;
 371   pr "%s ANY CHANGES YOU MAKE TO THIS FILE WILL BE LOST.\n" c;
 372   pr "%s\n" c;
 373   pr "%s Copyright (C) 2009 Red Hat Inc.\n" c;
 374   pr "%s\n" c;
 375   (match license with
 376    | GPLv2 ->
 377        pr "%s This program is free software; you can redistribute it and/or modify\n" c;
 378        pr "%s it under the terms of the GNU General Public License as published by\n" c;
 379        pr "%s the Free Software Foundation; either version 2 of the License, or\n" c;
 380        pr "%s (at your option) any later version.\n" c;
 381        pr "%s\n" c;
 382        pr "%s This program is distributed in the hope that it will be useful,\n" c;
 383        pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
 384        pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the\n" c;
 385        pr "%s GNU General Public License for more details.\n" c;
 386        pr "%s\n" c;
 387        pr "%s You should have received a copy of the GNU General Public License along\n" c;
 388        pr "%s with this program; if not, write to the Free Software Foundation, Inc.,\n" c;
 389        pr "%s 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n" c;
 390
 391    | LGPLv2 ->
 392        pr "%s This library is free software; you can redistribute it and/or\n" c;
 393        pr "%s modify it under the terms of the GNU Lesser General Public\n" c;
 394        pr "%s License as published by the Free Software Foundation; either\n" c;
 395        pr "%s version 2 of the License, or (at your option) any later version.\n" c;
 396        pr "%s\n" c;
 397        pr "%s This library is distributed in the hope that it will be useful,\n" c;
 398        pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
 399        pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU\n" c;
 400        pr "%s Lesser General Public License for more details.\n" c;
 401        pr "%s\n" c;
 402        pr "%s You should have received a copy of the GNU Lesser General Public\n" c;
 403        pr "%s License along with this library; if not, write to the Free Software\n" c;
 404        pr "%s Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA\n" c;
 405   );
 406   (match comment with
 407    | CStyle -> pr " */\n"
 408    | HashStyle -> ()
 409    | OCamlStyle -> pr " *)\n"
 410   );
 411   pr "\n"
 412
 413 (* Generate the pod documentation for the C API. *)
 414 and generate_actions_pod () =
 415   List.iter (
 416     fun (shortname, style, _, flags, _, longdesc) ->
 417       let name = "guestfs_" ^ shortname in
 418       pr "=head2 %s\n\n" name;
 419       pr " ";
 420       generate_prototype ~extern:false ~handle:"handle" name style;
 421       pr "\n\n";
 422       pr "%s\n\n" longdesc;
 423       (match fst style with
 424        | Err ->
 425            pr "This function returns 0 on success or -1 on error.\n\n"
 426        | RString _ ->
 427            pr "This function returns a string or NULL on error.
 428 I<The caller must free the returned string after use>.\n\n"
 429        | RStringList _ ->
 430            pr "This function returns a NULL-terminated array of strings
 431 (like L<environ(3)>), or NULL if there was an error.
 432 I<The caller must free the strings and the array after use>.\n\n"
 433        | RPVList _ ->
 434            pr "This function returns a C<struct guestfs_lvm_pv_list>.
 435 I<The caller must call C<guestfs_free_lvm_pv_list> after use.>.\n\n"
 436        | RVGList _ ->
 437            pr "This function returns a C<struct guestfs_lvm_vg_list>.
 438 I<The caller must call C<guestfs_free_lvm_vg_list> after use.>.\n\n"
 439        | RLVList _ ->
 440            pr "This function returns a C<struct guestfs_lvm_lv_list>.
 441 I<The caller must call C<guestfs_free_lvm_lv_list> after use.>.\n\n"
 442       );
 443       if List.mem ProtocolLimitWarning flags then
 444         pr "Because of the message protocol, there is a transfer limit
 445 of somewhere between 2MB and 4MB.  To transfer large files you should use
 446 FTP.\n\n";
 447   ) sorted_functions
 448
 449 and generate_structs_pod () =
 450   (* LVM structs documentation. *)
 451   List.iter (
 452     fun (typ, cols) ->
 453       pr "=head2 guestfs_lvm_%s\n" typ;
 454       pr "\n";
 455       pr " struct guestfs_lvm_%s {\n" typ;
 456       List.iter (
 457         function
 458         | name, `String -> pr "  char *%s;\n" name
 459         | name, `UUID ->
 460             pr "  /* The next field is NOT nul-terminated, be careful when printing it: */\n";
 461             pr "  char %s[32];\n" name
 462         | name, `Bytes -> pr "  uint64_t %s;\n" name
 463         | name, `Int -> pr "  int64_t %s;\n" name
 464         | name, `OptPercent ->
 465             pr "  /* The next field is [0..100] or -1 meaning 'not present': */\n";
 466             pr "  float %s;\n" name
 467       ) cols;
 468       pr " \n";
 469       pr " struct guestfs_lvm_%s_list {\n" typ;
 470       pr "   uint32_t len; /* Number of elements in list. */\n";
 471       pr "   struct guestfs_lvm_%s *val; /* Elements. */\n" typ;
 472       pr " };\n";
 473       pr " \n";
 474       pr " void guestfs_free_lvm_%s_list (struct guestfs_free_lvm_%s_list *);\n"
 475         typ typ;
 476       pr "\n"
 477   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols]
 478
 479 (* Generate the protocol (XDR) file, 'guestfs_protocol.x' and
 480  * indirectly 'guestfs_protocol.h' and 'guestfs_protocol.c'.  We
 481  * have to use an underscore instead of a dash because otherwise
 482  * rpcgen generates incorrect code.
 483  *
 484  * This header is NOT exported to clients, but see also generate_structs_h.
 485  *)
 486 and generate_xdr () =
 487   generate_header CStyle LGPLv2;
 488
 489   (* This has to be defined to get around a limitation in Sun's rpcgen. *)
 490   pr "typedef string str<>;\n";
 491   pr "\n";
 492
 493   (* LVM internal structures. *)
 494   List.iter (
 495     function
 496     | typ, cols ->
 497         pr "struct guestfs_lvm_int_%s {\n" typ;
 498         List.iter (function
 499                    | name, `String -> pr "  string %s<>;\n" name
 500                    | name, `UUID -> pr "  opaque %s[32];\n" name
 501                    | name, `Bytes -> pr "  hyper %s;\n" name
 502                    | name, `Int -> pr "  hyper %s;\n" name
 503                    | name, `OptPercent -> pr "  float %s;\n" name
 504                   ) cols;
 505         pr "};\n";
 506         pr "\n";
 507         pr "typedef struct guestfs_lvm_int_%s guestfs_lvm_int_%s_list<>;\n" typ typ;
 508         pr "\n";
 509   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols];
 510
 511   List.iter (
 512     fun (shortname, style, _, _, _, _) ->
 513       let name = "guestfs_" ^ shortname in
 514       pr "/* %s */\n\n" name;
 515       (match snd style with
 516        | P0 -> ()
 517        | args ->
 518            pr "struct %s_args {\n" name;
 519            iter_args (
 520              function
 521              | String name -> pr "  string %s<>;\n" name
 522            ) args;
 523            pr "};\n\n"
 524       );
 525       (match fst style with
 526        | Err -> ()
 527        | RString n ->
 528            pr "struct %s_ret {\n" name;
 529            pr "  string %s<>;\n" n;
 530            pr "};\n\n"
 531        | RStringList n ->
 532            pr "struct %s_ret {\n" name;
 533            pr "  str %s<>;\n" n;
 534            pr "};\n\n"
 535        | RPVList n ->
 536            pr "struct %s_ret {\n" name;
 537            pr "  guestfs_lvm_int_pv_list %s;\n" n;
 538            pr "};\n\n"
 539        | RVGList n ->
 540            pr "struct %s_ret {\n" name;
 541            pr "  guestfs_lvm_int_vg_list %s;\n" n;
 542            pr "};\n\n"
 543        | RLVList n ->
 544            pr "struct %s_ret {\n" name;
 545            pr "  guestfs_lvm_int_lv_list %s;\n" n;
 546            pr "};\n\n"
 547       );
 548   ) functions;
 549
 550   (* Table of procedure numbers. *)
 551   pr "enum guestfs_procedure {\n";
 552   List.iter (
 553     fun (shortname, _, proc_nr, _, _, _) ->
 554       pr "  GUESTFS_PROC_%s = %d,\n" (String.uppercase shortname) proc_nr
 555   ) functions;
 556   pr "  GUESTFS_PROC_dummy\n"; (* so we don't have a "hanging comma" *)
 557   pr "};\n";
 558   pr "\n";
 559
 560   (* Having to choose a maximum message size is annoying for several
 561    * reasons (it limits what we can do in the API), but it (a) makes
 562    * the protocol a lot simpler, and (b) provides a bound on the size
 563    * of the daemon which operates in limited memory space.  For large
 564    * file transfers you should use FTP.
 565    *)
 566   pr "const GUESTFS_MESSAGE_MAX = %d;\n" (4 * 1024 * 1024);
 567   pr "\n";
 568
 569   (* Message header, etc. *)
 570   pr "\
 571 const GUESTFS_PROGRAM = 0x2000F5F5;
 572 const GUESTFS_PROTOCOL_VERSION = 1;
 573
 574 enum guestfs_message_direction {
 575   GUESTFS_DIRECTION_CALL = 0,        /* client -> daemon */
 576   GUESTFS_DIRECTION_REPLY = 1        /* daemon -> client */
 577 };
 578
 579 enum guestfs_message_status {
 580   GUESTFS_STATUS_OK = 0,
 581   GUESTFS_STATUS_ERROR = 1
 582 };
 583
 584 const GUESTFS_ERROR_LEN = 256;
 585
 586 struct guestfs_message_error {
 587   string error<GUESTFS_ERROR_LEN>;   /* error message */
 588 };
 589
 590 struct guestfs_message_header {
 591   unsigned prog;                     /* GUESTFS_PROGRAM */
 592   unsigned vers;                     /* GUESTFS_PROTOCOL_VERSION */
 593   guestfs_procedure proc;            /* GUESTFS_PROC_x */
 594   guestfs_message_direction direction;
 595   unsigned serial;                   /* message serial number */
 596   guestfs_message_status status;
 597 };
 598 "
 599
 600 (* Generate the guestfs-structs.h file. *)
 601 and generate_structs_h () =
 602   generate_header CStyle LGPLv2;
 603
 604   (* This is a public exported header file containing various
 605    * structures.  The structures are carefully written to have
 606    * exactly the same in-memory format as the XDR structures that
 607    * we use on the wire to the daemon.  The reason for creating
 608    * copies of these structures here is just so we don't have to
 609    * export the whole of guestfs_protocol.h (which includes much
 610    * unrelated and XDR-dependent stuff that we don't want to be
 611    * public, or required by clients).
 612    *
 613    * To reiterate, we will pass these structures to and from the
 614    * client with a simple assignment or memcpy, so the format
 615    * must be identical to what rpcgen / the RFC defines.
 616    *)
 617
 618   (* LVM public structures. *)
 619   List.iter (
 620     function
 621     | typ, cols ->
 622         pr "struct guestfs_lvm_%s {\n" typ;
 623         List.iter (
 624           function
 625           | name, `String -> pr "  char *%s;\n" name
 626           | name, `UUID -> pr "  char %s[32]; /* this is NOT nul-terminated, be careful when printing */\n" name
 627           | name, `Bytes -> pr "  uint64_t %s;\n" name
 628           | name, `Int -> pr "  int64_t %s;\n" name
 629           | name, `OptPercent -> pr "  float %s; /* [0..100] or -1 */\n" name
 630         ) cols;
 631         pr "};\n";
 632         pr "\n";
 633         pr "struct guestfs_lvm_%s_list {\n" typ;
 634         pr "  uint32_t len;\n";
 635         pr "  struct guestfs_lvm_%s *val;\n" typ;
 636         pr "};\n";
 637         pr "\n"
 638   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols]
 639
 640 (* Generate the guestfs-actions.h file. *)
 641 and generate_actions_h () =
 642   generate_header CStyle LGPLv2;
 643   List.iter (
 644     fun (shortname, style, _, _, _, _) ->
 645       let name = "guestfs_" ^ shortname in
 646       generate_prototype ~single_line:true ~newline:true ~handle:"handle"
 647         name style
 648   ) functions
 649
 650 (* Generate the client-side dispatch stubs. *)
 651 and generate_client_actions () =
 652   generate_header CStyle LGPLv2;
 653
 654   (* Client-side stubs for each function. *)
 655   List.iter (
 656     fun (shortname, style, _, _, _, _) ->
 657       let name = "guestfs_" ^ shortname in
 658
 659       (* Generate the return value struct. *)
 660       pr "struct %s_rv {\n" shortname;
 661       pr "  int cb_done;  /* flag to indicate callback was called */\n";
 662       pr "  struct guestfs_message_header hdr;\n";
 663       pr "  struct guestfs_message_error err;\n";
 664       (match fst style with
 665        | Err -> ()
 666        | RString _ | RStringList _ | RPVList _ | RVGList _ | RLVList _ ->
 667            pr "  struct %s_ret ret;\n" name
 668       );
 669       pr "};\n\n";
 670
 671       (* Generate the callback function. *)
 672       pr "static void %s_cb (guestfs_h *g, void *data, XDR *xdr)\n" shortname;
 673       pr "{\n";
 674       pr "  struct %s_rv *rv = (struct %s_rv *) data;\n" shortname shortname;
 675       pr "\n";
 676       pr "  if (!xdr_guestfs_message_header (xdr, &rv->hdr)) {\n";
 677       pr "    error (g, \"%s: failed to parse reply header\");\n" name;
 678       pr "    return;\n";
 679       pr "  }\n";
 680       pr "  if (rv->hdr.status == GUESTFS_STATUS_ERROR) {\n";
 681       pr "    if (!xdr_guestfs_message_error (xdr, &rv->err)) {\n";
 682       pr "      error (g, \"%s: failed to parse reply error\");\n" name;
 683       pr "      return;\n";
 684       pr "    }\n";
 685       pr "    goto done;\n";
 686       pr "  }\n";
 687
 688       (match fst style with
 689        | Err -> ()
 690        | RString _ | RStringList _ | RPVList _ | RVGList _ | RLVList _ ->
 691             pr "  if (!xdr_%s_ret (xdr, &rv->ret)) {\n" name;
 692             pr "    error (g, \"%s: failed to parse reply\");\n" name;
 693             pr "    return;\n";
 694             pr "  }\n";
 695       );
 696
 697       pr " done:\n";
 698       pr "  rv->cb_done = 1;\n";
 699       pr "  main_loop.main_loop_quit (g);\n";
 700       pr "}\n\n";
 701
 702       (* Generate the action stub. *)
 703       generate_prototype ~extern:false ~semicolon:false ~newline:true
 704         ~handle:"g" name style;
 705
 706       let error_code =
 707         match fst style with
 708         | Err -> "-1"
 709         | RString _ | RStringList _ | RPVList _ | RVGList _ | RLVList _ ->
 710             "NULL" in
 711
 712       pr "{\n";
 713
 714       (match snd style with
 715        | P0 -> ()
 716        | _ -> pr "  struct %s_args args;\n" name
 717       );
 718
 719       pr "  struct %s_rv rv;\n" shortname;
 720       pr "  int serial;\n";
 721       pr "\n";
 722       pr "  if (g->state != READY) {\n";
 723       pr "    error (g, \"%s called from the wrong state, %%d != READY\",\n"
 724         name;
 725       pr "      g->state);\n";
 726       pr "    return %s;\n" error_code;
 727       pr "  }\n";
 728       pr "\n";
 729       pr "  memset (&rv, 0, sizeof rv);\n";
 730       pr "\n";
 731
 732       (match snd style with
 733        | P0 ->
 734            pr "  serial = dispatch (g, GUESTFS_PROC_%s, NULL, NULL);\n"
 735              (String.uppercase shortname)
 736        | args ->
 737            iter_args (
 738              function
 739              | String name -> pr "  args.%s = (char *) %s;\n" name name
 740            ) args;
 741            pr "  serial = dispatch (g, GUESTFS_PROC_%s,\n"
 742              (String.uppercase shortname);
 743            pr "                     (xdrproc_t) xdr_%s_args, (char *) &args);\n"
 744              name;
 745       );
 746       pr "  if (serial == -1)\n";
 747       pr "    return %s;\n" error_code;
 748       pr "\n";
 749
 750       pr "  rv.cb_done = 0;\n";
 751       pr "  g->reply_cb_internal = %s_cb;\n" shortname;
 752       pr "  g->reply_cb_internal_data = &rv;\n";
 753       pr "  main_loop.main_loop_run (g);\n";
 754       pr "  g->reply_cb_internal = NULL;\n";
 755       pr "  g->reply_cb_internal_data = NULL;\n";
 756       pr "  if (!rv.cb_done) {\n";
 757       pr "    error (g, \"%s failed, see earlier error messages\");\n" name;
 758       pr "    return %s;\n" error_code;
 759       pr "  }\n";
 760       pr "\n";
 761
 762       pr "  if (check_reply_header (g, &rv.hdr, GUESTFS_PROC_%s, serial) == -1)\n"
 763         (String.uppercase shortname);
 764       pr "    return %s;\n" error_code;
 765       pr "\n";
 766
 767       pr "  if (rv.hdr.status == GUESTFS_STATUS_ERROR) {\n";
 768       pr "    error (g, \"%%s\", rv.err.error);\n";
 769       pr "    return %s;\n" error_code;
 770       pr "  }\n";
 771       pr "\n";
 772
 773       (match fst style with
 774        | Err -> pr "  return 0;\n"
 775        | RString n ->
 776            pr "  return rv.ret.%s; /* caller will free */\n" n
 777        | RStringList n ->
 778            pr "  /* caller will free this, but we need to add a NULL entry */\n";
 779            pr "  rv.ret.%s.%s_val =" n n;
 780            pr "    safe_realloc (g, rv.ret.%s.%s_val,\n" n n;
 781            pr "                  sizeof (char *) * (rv.ret.%s.%s_len + 1));\n"
 782              n n;
 783            pr "  rv.ret.%s.%s_val[rv.ret.%s.%s_len] = NULL;\n" n n n n;
 784            pr "  return rv.ret.%s.%s_val;\n" n n
 785        | RPVList n ->
 786            pr "  /* caller will free this */\n";
 787            pr "  return safe_memdup (g, &rv.ret.%s, sizeof (rv.ret.%s));\n" n n
 788        | RVGList n ->
 789            pr "  /* caller will free this */\n";
 790            pr "  return safe_memdup (g, &rv.ret.%s, sizeof (rv.ret.%s));\n" n n
 791        | RLVList n ->
 792            pr "  /* caller will free this */\n";
 793            pr "  return safe_memdup (g, &rv.ret.%s, sizeof (rv.ret.%s));\n" n n
 794       );
 795
 796       pr "}\n\n"
 797   ) functions
 798
 799 (* Generate daemon/actions.h. *)
 800 and generate_daemon_actions_h () =
 801   generate_header CStyle GPLv2;
 802
 803   pr "#include \"../src/guestfs_protocol.h\"\n";
 804   pr "\n";
 805
 806   List.iter (
 807     fun (name, style, _, _, _, _) ->
 808       generate_prototype
 809         ~single_line:true ~newline:true ~in_daemon:true ("do_" ^ name) style;
 810   ) functions
 811
 812 (* Generate the server-side stubs. *)
 813 and generate_daemon_actions () =
 814   generate_header CStyle GPLv2;
 815
 816   pr "#define _GNU_SOURCE // for strchrnul\n";
 817   pr "\n";
 818   pr "#include <stdio.h>\n";
 819   pr "#include <stdlib.h>\n";
 820   pr "#include <string.h>\n";
 821   pr "#include <inttypes.h>\n";
 822   pr "#include <ctype.h>\n";
 823   pr "#include <rpc/types.h>\n";
 824   pr "#include <rpc/xdr.h>\n";
 825   pr "\n";
 826   pr "#include \"daemon.h\"\n";
 827   pr "#include \"../src/guestfs_protocol.h\"\n";
 828   pr "#include \"actions.h\"\n";
 829   pr "\n";
 830
 831   List.iter (
 832     fun (name, style, _, _, _, _) ->
 833       (* Generate server-side stubs. *)
 834       pr "static void %s_stub (XDR *xdr_in)\n" name;
 835       pr "{\n";
 836       let error_code =
 837         match fst style with
 838         | Err -> pr "  int r;\n"; "-1"
 839         | RString _ -> pr "  char *r;\n"; "NULL"
 840         | RStringList _ -> pr "  char **r;\n"; "NULL"
 841         | RPVList _ -> pr "  guestfs_lvm_int_pv_list *r;\n"; "NULL"
 842         | RVGList _ -> pr "  guestfs_lvm_int_vg_list *r;\n"; "NULL"
 843         | RLVList _ -> pr "  guestfs_lvm_int_lv_list *r;\n"; "NULL" in
 844
 845       (match snd style with
 846        | P0 -> ()
 847        | args ->
 848            pr "  struct guestfs_%s_args args;\n" name;
 849            iter_args (
 850              function
 851              | String name -> pr "  const char *%s;\n" name
 852            ) args
 853       );
 854       pr "\n";
 855
 856       (match snd style with
 857        | P0 -> ()
 858        | args ->
 859            pr "  memset (&args, 0, sizeof args);\n";
 860            pr "\n";
 861            pr "  if (!xdr_guestfs_%s_args (xdr_in, &args)) {\n" name;
 862            pr "    reply_with_error (\"%s: daemon failed to decode procedure arguments\");\n" name;
 863            pr "    return;\n";
 864            pr "  }\n";
 865            iter_args (
 866              function
 867              | String name -> pr "  %s = args.%s;\n" name name
 868            ) args;
 869            pr "\n"
 870       );
 871
 872       pr "  r = do_%s " name;
 873       generate_call_args style;
 874       pr ";\n";
 875
 876       pr "  if (r == %s)\n" error_code;
 877       pr "    /* do_%s has already called reply_with_error, so just return */\n" name;
 878       pr "    return;\n";
 879       pr "\n";
 880
 881       (match fst style with
 882        | Err -> pr "  reply (NULL, NULL);\n"
 883        | RString n ->
 884            pr "  struct guestfs_%s_ret ret;\n" name;
 885            pr "  ret.%s = r;\n" n;
 886            pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name;
 887            pr "  free (r);\n"
 888        | RStringList n ->
 889            pr "  struct guestfs_%s_ret ret;\n" name;
 890            pr "  ret.%s.%s_len = count_strings (r);\n" n n;
 891            pr "  ret.%s.%s_val = r;\n" n n;
 892            pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name;
 893            pr "  free_strings (r);\n"
 894        | RPVList n ->
 895            pr "  struct guestfs_%s_ret ret;\n" name;
 896            pr "  ret.%s = *r;\n" n;
 897            pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name;
 898            pr "  xdr_free ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n" name
 899        | RVGList n ->
 900            pr "  struct guestfs_%s_ret ret;\n" name;
 901            pr "  ret.%s = *r;\n" n;
 902            pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name;
 903            pr "  xdr_free ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n" name
 904        | RLVList n ->
 905            pr "  struct guestfs_%s_ret ret;\n" name;
 906            pr "  ret.%s = *r;\n" n;
 907            pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name;
 908            pr "  xdr_free ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n" name
 909       );
 910
 911       pr "}\n\n";
 912   ) functions;
 913
 914   (* Dispatch function. *)
 915   pr "void dispatch_incoming_message (XDR *xdr_in)\n";
 916   pr "{\n";
 917   pr "  switch (proc_nr) {\n";
 918
 919   List.iter (
 920     fun (name, style, _, _, _, _) ->
 921       pr "    case GUESTFS_PROC_%s:\n" (String.uppercase name);
 922       pr "      %s_stub (xdr_in);\n" name;
 923       pr "      break;\n"
 924   ) functions;
 925
 926   pr "    default:\n";
 927   pr "      reply_with_error (\"dispatch_incoming_message: unknown procedure number %%d\", proc_nr);\n";
 928   pr "  }\n";
 929   pr "}\n";
 930   pr "\n";
 931
 932   (* LVM columns and tokenization functions. *)
 933   (* XXX This generates crap code.  We should rethink how we
 934    * do this parsing.
 935    *)
 936   List.iter (
 937     function
 938     | typ, cols ->
 939         pr "static const char *lvm_%s_cols = \"%s\";\n"
 940           typ (String.concat "," (List.map fst cols));
 941         pr "\n";
 942
 943         pr "static int lvm_tokenize_%s (char *str, struct guestfs_lvm_int_%s *r)\n" typ typ;
 944         pr "{\n";
 945         pr "  char *tok, *p, *next;\n";
 946         pr "  int i, j;\n";
 947         pr "\n";
 948         (*
 949         pr "  fprintf (stderr, \"%%s: <<%%s>>\\n\", __func__, str);\n";
 950         pr "\n";
 951         *)
 952         pr "  if (!str) {\n";
 953         pr "    fprintf (stderr, \"%%s: failed: passed a NULL string\\n\", __func__);\n";
 954         pr "    return -1;\n";
 955         pr "  }\n";
 956         pr "  if (!*str || isspace (*str)) {\n";
 957         pr "    fprintf (stderr, \"%%s: failed: passed a empty string or one beginning with whitespace\\n\", __func__);\n";
 958         pr "    return -1;\n";
 959         pr "  }\n";
 960         pr "  tok = str;\n";
 961         List.iter (
 962           fun (name, coltype) ->
 963             pr "  if (!tok) {\n";
 964             pr "    fprintf (stderr, \"%%s: failed: string finished early, around token %%s\\n\", __func__, \"%s\");\n" name;
 965             pr "    return -1;\n";
 966             pr "  }\n";
 967             pr "  p = strchrnul (tok, ',');\n";
 968             pr "  if (*p) next = p+1; else next = NULL;\n";
 969             pr "  *p = '\\0';\n";
 970             (match coltype with
 971              | `String ->
 972                  pr "  r->%s = strdup (tok);\n" name;
 973                  pr "  if (r->%s == NULL) {\n" name;
 974                  pr "    perror (\"strdup\");\n";
 975                  pr "    return -1;\n";
 976                  pr "  }\n"
 977              | `UUID ->
 978                  pr "  for (i = j = 0; i < 32; ++j) {\n";
 979                  pr "    if (tok[j] == '\\0') {\n";
 980                  pr "      fprintf (stderr, \"%%s: failed to parse UUID from '%%s'\\n\", __func__, tok);\n";
 981                  pr "      return -1;\n";
 982                  pr "    } else if (tok[j] != '-')\n";
 983                  pr "      r->%s[i++] = tok[j];\n" name;
 984                  pr "  }\n";
 985              | `Bytes ->
 986                  pr "  if (sscanf (tok, \"%%\"SCNu64, &r->%s) != 1) {\n" name;
 987                  pr "    fprintf (stderr, \"%%s: failed to parse size '%%s' from token %%s\\n\", __func__, tok, \"%s\");\n" name;
 988                  pr "    return -1;\n";
 989                  pr "  }\n";
 990              | `Int ->
 991                  pr "  if (sscanf (tok, \"%%\"SCNi64, &r->%s) != 1) {\n" name;
 992                  pr "    fprintf (stderr, \"%%s: failed to parse int '%%s' from token %%s\\n\", __func__, tok, \"%s\");\n" name;
 993                  pr "    return -1;\n";
 994                  pr "  }\n";
 995              | `OptPercent ->
 996                  pr "  if (tok[0] == '\\0')\n";
 997                  pr "    r->%s = -1;\n" name;
 998                  pr "  else if (sscanf (tok, \"%%f\", &r->%s) != 1) {\n" name;
 999                  pr "    fprintf (stderr, \"%%s: failed to parse float '%%s' from token %%s\\n\", __func__, tok, \"%s\");\n" name;
1000                  pr "    return -1;\n";
1001                  pr "  }\n";
1002             );
1003             pr "  tok = next;\n";
1004         ) cols;
1005
1006         pr "  if (tok != NULL) {\n";
1007         pr "    fprintf (stderr, \"%%s: failed: extra tokens at end of string\\n\", __func__);\n";
1008         pr "    return -1;\n";
1009         pr "  }\n";
1010         pr "  return 0;\n";
1011         pr "}\n";
1012         pr "\n";
1013
1014         pr "guestfs_lvm_int_%s_list *\n" typ;
1015         pr "parse_command_line_%ss (void)\n" typ;
1016         pr "{\n";
1017         pr "  char *out, *err;\n";
1018         pr "  char *p, *pend;\n";
1019         pr "  int r, i;\n";
1020         pr "  guestfs_lvm_int_%s_list *ret;\n" typ;
1021         pr "  void *newp;\n";
1022         pr "\n";
1023         pr "  ret = malloc (sizeof *ret);\n";
1024         pr "  if (!ret) {\n";
1025         pr "    reply_with_perror (\"malloc\");\n";
1026         pr "    return NULL;\n";
1027         pr "  }\n";
1028         pr "\n";
1029         pr "  ret->guestfs_lvm_int_%s_list_len = 0;\n" typ;
1030         pr "  ret->guestfs_lvm_int_%s_list_val = NULL;\n" typ;
1031         pr "\n";
1032         pr "  r = command (&out, &err,\n";
1033         pr "           \"/sbin/lvm\", \"%ss\",\n" typ;
1034         pr "           \"-o\", lvm_%s_cols, \"--unbuffered\", \"--noheadings\",\n" typ;
1035         pr "           \"--nosuffix\", \"--separator\", \",\", \"--units\", \"b\", NULL);\n";
1036         pr "  if (r == -1) {\n";
1037         pr "    reply_with_error (\"%%s\", err);\n";
1038         pr "    free (out);\n";
1039         pr "    free (err);\n";
1040         pr "    return NULL;\n";
1041         pr "  }\n";
1042         pr "\n";
1043         pr "  free (err);\n";
1044         pr "\n";
1045         pr "  /* Tokenize each line of the output. */\n";
1046         pr "  p = out;\n";
1047         pr "  i = 0;\n";
1048         pr "  while (p) {\n";
1049         pr "    pend = strchr (p, '\\n');       /* Get the next line of output. */\n";
1050         pr "    if (pend) {\n";
1051         pr "      *pend = '\\0';\n";
1052         pr "      pend++;\n";
1053         pr "    }\n";
1054         pr "\n";
1055         pr "    while (*p && isspace (*p))      /* Skip any leading whitespace. */\n";
1056         pr "      p++;\n";
1057         pr "\n";
1058         pr "    if (!*p) {                      /* Empty line?  Skip it. */\n";
1059         pr "      p = pend;\n";
1060         pr "      continue;\n";
1061         pr "    }\n";
1062         pr "\n";
1063         pr "    /* Allocate some space to store this next entry. */\n";
1064         pr "    newp = realloc (ret->guestfs_lvm_int_%s_list_val,\n" typ;
1065         pr "                sizeof (guestfs_lvm_int_%s) * (i+1));\n" typ;
1066         pr "    if (newp == NULL) {\n";
1067         pr "      reply_with_perror (\"realloc\");\n";
1068         pr "      free (ret->guestfs_lvm_int_%s_list_val);\n" typ;
1069         pr "      free (ret);\n";
1070         pr "      free (out);\n";
1071         pr "      return NULL;\n";
1072         pr "    }\n";
1073         pr "    ret->guestfs_lvm_int_%s_list_val = newp;\n" typ;
1074         pr "\n";
1075         pr "    /* Tokenize the next entry. */\n";
1076         pr "    r = lvm_tokenize_%s (p, &ret->guestfs_lvm_int_%s_list_val[i]);\n" typ typ;
1077         pr "    if (r == -1) {\n";
1078         pr "      reply_with_error (\"failed to parse output of '%ss' command\");\n" typ;
1079         pr "      free (ret->guestfs_lvm_int_%s_list_val);\n" typ;
1080         pr "      free (ret);\n";
1081         pr "      free (out);\n";
1082         pr "      return NULL;\n";
1083         pr "    }\n";
1084         pr "\n";
1085         pr "    ++i;\n";
1086         pr "    p = pend;\n";
1087         pr "  }\n";
1088         pr "\n";
1089         pr "  ret->guestfs_lvm_int_%s_list_len = i;\n" typ;
1090         pr "\n";
1091         pr "  free (out);\n";
1092         pr "  return ret;\n";
1093         pr "}\n"
1094
1095   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols]
1096
1097 (* Generate a lot of different functions for guestfish. *)
1098 and generate_fish_cmds () =
1099   generate_header CStyle GPLv2;
1100
1101   pr "#include <stdio.h>\n";
1102   pr "#include <stdlib.h>\n";
1103   pr "#include <string.h>\n";
1104   pr "#include <inttypes.h>\n";
1105   pr "\n";
1106   pr "#include <guestfs.h>\n";
1107   pr "#include \"fish.h\"\n";
1108   pr "\n";
1109
1110   (* list_commands function, which implements guestfish -h *)
1111   pr "void list_commands (void)\n";
1112   pr "{\n";
1113   pr "  printf (\"    %%-16s     %%s\\n\", \"Command\", \"Description\");\n";
1114   pr "  list_builtin_commands ();\n";
1115   List.iter (
1116     fun (name, _, _, _, shortdesc, _) ->
1117       let name = replace_char name '_' '-' in
1118       pr "  printf (\"%%-20s %%s\\n\", \"%s\", \"%s\");\n"
1119         name shortdesc
1120   ) sorted_functions;
1121   pr "  printf (\"    Use -h <cmd> / help <cmd> to show detailed help for a command.\\n\");\n";
1122   pr "}\n";
1123   pr "\n";
1124
1125   (* display_command function, which implements guestfish -h cmd *)
1126   pr "void display_command (const char *cmd)\n";
1127   pr "{\n";
1128   List.iter (
1129     fun (name, style, _, flags, shortdesc, longdesc) ->
1130       let name2 = replace_char name '_' '-' in
1131       let longdesc = replace_str longdesc "C<guestfs_" "C<" in
1132       let synopsis =
1133         match snd style with
1134         | P0 -> name2
1135         | args ->
1136             sprintf "%s <%s>"
1137               name2 (
1138                 String.concat "> <" (
1139                   map_args (function
1140                             | String n -> n) args
1141                 )
1142               ) in
1143
1144       let warnings =
1145         if List.mem ProtocolLimitWarning flags then
1146           "\n\nBecause of the message protocol, there is a transfer limit
1147 of somewhere between 2MB and 4MB.  To transfer large files you should use
1148 FTP."
1149         else "" in
1150
1151       pr "  if (";
1152       pr "strcasecmp (cmd, \"%s\") == 0" name;
1153       if name <> name2 then
1154         pr " || strcasecmp (cmd, \"%s\") == 0" name2;
1155       pr ")\n";
1156       pr "    pod2text (\"%s - %s\", %S);\n"
1157         name2 shortdesc
1158         (" " ^ synopsis ^ "\n\n" ^ longdesc ^ warnings);
1159       pr "  else\n"
1160   ) functions;
1161   pr "    display_builtin_command (cmd);\n";
1162   pr "}\n";
1163   pr "\n";
1164
1165   (* print_{pv,vg,lv}_list functions *)
1166   List.iter (
1167     function
1168     | typ, cols ->
1169         pr "static void print_%s (struct guestfs_lvm_%s *%s)\n" typ typ typ;
1170         pr "{\n";
1171         pr "  int i;\n";
1172         pr "\n";
1173         List.iter (
1174           function
1175           | name, `String ->
1176               pr "  printf (\"%s: %%s\\n\", %s->%s);\n" name typ name
1177           | name, `UUID ->
1178               pr "  printf (\"%s: \");\n" name;
1179               pr "  for (i = 0; i < 32; ++i)\n";
1180               pr "    printf (\"%%c\", %s->%s[i]);\n" typ name;
1181               pr "  printf (\"\\n\");\n"
1182           | name, `Bytes ->
1183               pr "  printf (\"%s: %%\" PRIu64 \"\\n\", %s->%s);\n" name typ name
1184           | name, `Int ->
1185               pr "  printf (\"%s: %%\" PRIi64 \"\\n\", %s->%s);\n" name typ name
1186           | name, `OptPercent ->
1187               pr "  if (%s->%s >= 0) printf (\"%s: %%g %%%%\\n\", %s->%s);\n"
1188                 typ name name typ name;
1189               pr "  else printf (\"%s: \\n\");\n" name
1190         ) cols;
1191         pr "}\n";
1192         pr "\n";
1193         pr "static void print_%s_list (struct guestfs_lvm_%s_list *%ss)\n"
1194           typ typ typ;
1195         pr "{\n";
1196         pr "  int i;\n";
1197         pr "\n";
1198         pr "  for (i = 0; i < %ss->len; ++i)\n" typ;
1199         pr "    print_%s (&%ss->val[i]);\n" typ typ;
1200         pr "}\n";
1201         pr "\n";
1202   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols];
1203
1204   (* run_<action> actions *)
1205   List.iter (
1206     fun (name, style, _, _, _, _) ->
1207       pr "static int run_%s (const char *cmd, int argc, char *argv[])\n" name;
1208       pr "{\n";
1209       (match fst style with
1210        | Err -> pr "  int r;\n"
1211        | RString _ -> pr "  char *r;\n"
1212        | RStringList _ -> pr "  char **r;\n"
1213        | RPVList _ -> pr "  struct guestfs_lvm_pv_list *r;\n"
1214        | RVGList _ -> pr "  struct guestfs_lvm_vg_list *r;\n"
1215        | RLVList _ -> pr "  struct guestfs_lvm_lv_list *r;\n"
1216       );
1217       iter_args (
1218         function
1219         | String name -> pr "  const char *%s;\n" name
1220       ) (snd style);
1221
1222       (* Check and convert parameters. *)
1223       let argc_expected = nr_args (snd style) in
1224       pr "  if (argc != %d) {\n" argc_expected;
1225       pr "    fprintf (stderr, \"%%s should have %d parameter(s)\\n\", cmd);\n"
1226         argc_expected;
1227       pr "    fprintf (stderr, \"type 'help %%s' for help on %%s\\n\", cmd, cmd);\n";
1228       pr "    return -1;\n";
1229       pr "  }\n";
1230       iteri_args (
1231         fun i ->
1232           function
1233           | String name -> pr "  %s = argv[%d];\n" name i
1234       ) (snd style);
1235
1236       (* Call C API function. *)
1237       pr "  r = guestfs_%s " name;
1238       generate_call_args ~handle:"g" style;
1239       pr ";\n";
1240
1241       (* Check return value for errors and display command results. *)
1242       (match fst style with
1243        | Err -> pr "  return r;\n"
1244        | RString _ ->
1245            pr "  if (r == NULL) return -1;\n";
1246            pr "  printf (\"%%s\", r);\n";
1247            pr "  free (r);\n";
1248            pr "  return 0;\n"
1249        | RStringList _ ->
1250            pr "  if (r == NULL) return -1;\n";
1251            pr "  print_strings (r);\n";
1252            pr "  free_strings (r);\n";
1253            pr "  return 0;\n"
1254        | RPVList _ ->
1255            pr "  if (r == NULL) return -1;\n";
1256            pr "  print_pv_list (r);\n";
1257            pr "  guestfs_free_lvm_pv_list (r);\n";
1258            pr "  return 0;\n"
1259        | RVGList _ ->
1260            pr "  if (r == NULL) return -1;\n";
1261            pr "  print_vg_list (r);\n";
1262            pr "  guestfs_free_lvm_vg_list (r);\n";
1263            pr "  return 0;\n"
1264        | RLVList _ ->
1265            pr "  if (r == NULL) return -1;\n";
1266            pr "  print_lv_list (r);\n";
1267            pr "  guestfs_free_lvm_lv_list (r);\n";
1268            pr "  return 0;\n"
1269       );
1270       pr "}\n";
1271       pr "\n"
1272   ) functions;
1273
1274   (* run_action function *)
1275   pr "int run_action (const char *cmd, int argc, char *argv[])\n";
1276   pr "{\n";
1277   List.iter (
1278     fun (name, _, _, _, _, _) ->
1279       let name2 = replace_char name '_' '-' in
1280       pr "  if (";
1281       pr "strcasecmp (cmd, \"%s\") == 0" name;
1282       if name <> name2 then
1283         pr " || strcasecmp (cmd, \"%s\") == 0" name2;
1284       pr ")\n";
1285       pr "    return run_%s (cmd, argc, argv);\n" name;
1286       pr "  else\n";
1287   ) functions;
1288   pr "    {\n";
1289   pr "      fprintf (stderr, \"%%s: unknown command\\n\", cmd);\n";
1290   pr "      return -1;\n";
1291   pr "    }\n";
1292   pr "  return 0;\n";
1293   pr "}\n";
1294   pr "\n"
1295
1296 (* Generate the POD documentation for guestfish. *)
1297 and generate_fish_actions_pod () =
1298   List.iter (
1299     fun (name, style, _, _, _, longdesc) ->
1300       let longdesc = replace_str longdesc "C<guestfs_" "C<" in
1301       let name = replace_char name '_' '-' in
1302       pr "=head2 %s\n\n" name;
1303       pr " %s" name;
1304       iter_args (
1305         function
1306         | String n -> pr " %s" n
1307       ) (snd style);
1308       pr "\n";
1309       pr "\n";
1310       pr "%s\n\n" longdesc
1311   ) sorted_functions
1312
1313 (* Generate a C function prototype. *)
1314 and generate_prototype ?(extern = true) ?(static = false) ?(semicolon = true)
1315     ?(single_line = false) ?(newline = false) ?(in_daemon = false)
1316     ?handle name style =
1317   if extern then pr "extern ";
1318   if static then pr "static ";
1319   (match fst style with
1320    | Err -> pr "int "
1321    | RString _ -> pr "char *"
1322    | RStringList _ -> pr "char **"
1323    | RPVList _ ->
1324        if not in_daemon then pr "struct guestfs_lvm_pv_list *"
1325        else pr "guestfs_lvm_int_pv_list *"
1326    | RVGList _ ->
1327        if not in_daemon then pr "struct guestfs_lvm_vg_list *"
1328        else pr "guestfs_lvm_int_vg_list *"
1329    | RLVList _ ->
1330        if not in_daemon then pr "struct guestfs_lvm_lv_list *"
1331        else pr "guestfs_lvm_int_lv_list *"
1332   );
1333   pr "%s (" name;
1334   let comma = ref false in
1335   (match handle with
1336    | None -> ()
1337    | Some handle -> pr "guestfs_h *%s" handle; comma := true
1338   );
1339   let next () =
1340     if !comma then (
1341       if single_line then pr ", " else pr ",\n\t\t"
1342     );
1343     comma := true
1344   in
1345   iter_args (
1346     function
1347     | String name -> next (); pr "const char *%s" name
1348   ) (snd style);
1349   pr ")";
1350   if semicolon then pr ";";
1351   if newline then pr "\n"
1352
1353 (* Generate C call arguments, eg "(handle, foo, bar)" *)
1354 and generate_call_args ?handle style =
1355   pr "(";
1356   let comma = ref false in
1357   (match handle with
1358    | None -> ()
1359    | Some handle -> pr "%s" handle; comma := true
1360   );
1361   iter_args (
1362     fun arg ->
1363       if !comma then pr ", ";
1364       comma := true;
1365       match arg with
1366       | String name -> pr "%s" name
1367   ) (snd style);
1368   pr ")"
1369
1370 (* Generate the OCaml bindings interface. *)
1371 and generate_ocaml_mli () =
1372   generate_header OCamlStyle LGPLv2;
1373
1374   pr "\
1375 (** For API documentation you should refer to the C API
1376     in the guestfs(3) manual page.  The OCaml API uses almost
1377     exactly the same calls. *)
1378
1379 type t
1380 (** A [guestfs_h] handle. *)
1381
1382 exception Error of string
1383 (** This exception is raised when there is an error. *)
1384
1385 val create : unit -> t
1386
1387 val close : t -> unit
1388 (** Handles are closed by the garbage collector when they become
1389     unreferenced, but callers can also call this in order to
1390     provide predictable cleanup. *)
1391
1392 val launch : t -> unit
1393 val wait_ready : t -> unit
1394 val kill_subprocess : t -> unit
1395
1396 val add_drive : t -> string -> unit
1397 val add_cdrom : t -> string -> unit
1398 val config : t -> string -> string option -> unit
1399
1400 val set_path : t -> string option -> unit
1401 val get_path : t -> string
1402 val set_autosync : t -> bool -> unit
1403 val get_autosync : t -> bool
1404 val set_verbose : t -> bool -> unit
1405 val get_verbose : t -> bool
1406
1407 ";
1408   generate_ocaml_lvm_structure_decls ();
1409
1410   (* The actions. *)
1411   List.iter (
1412     fun (name, style, _, _, shortdesc, _) ->
1413       generate_ocaml_prototype name style;
1414       pr "(** %s *)\n" shortdesc;
1415       pr "\n"
1416   ) sorted_functions
1417
1418 (* Generate the OCaml bindings implementation. *)
1419 and generate_ocaml_ml () =
1420   generate_header OCamlStyle LGPLv2;
1421
1422   pr "\
1423 type t
1424 exception Error of string
1425 external create : unit -> t = \"ocaml_guestfs_create\"
1426 external close : t -> unit = \"ocaml_guestfs_create\"
1427 external launch : t -> unit = \"ocaml_guestfs_launch\"
1428 external wait_ready : t -> unit = \"ocaml_guestfs_wait_ready\"
1429 external kill_subprocess : t -> unit = \"ocaml_guestfs_kill_subprocess\"
1430 external add_drive : t -> string -> unit = \"ocaml_guestfs_add_drive\"
1431 external add_cdrom : t -> string -> unit = \"ocaml_guestfs_add_cdrom\"
1432 external config : t -> string -> string option -> unit = \"ocaml_guestfs_config\"
1433 external set_path : t -> string option -> unit = \"ocaml_guestfs_set_path\"
1434 external get_path : t -> string = \"ocaml_guestfs_get_path\"
1435 external set_autosync : t -> bool -> unit = \"ocaml_guestfs_set_autosync\"
1436 external get_autosync : t -> bool = \"ocaml_guestfs_get_autosync\"
1437 external set_verbose : t -> bool -> unit = \"ocaml_guestfs_set_verbose\"
1438 external get_verbose : t -> bool = \"ocaml_guestfs_get_verbose\"
1439
1440 ";
1441   generate_ocaml_lvm_structure_decls ();
1442
1443   (* The actions. *)
1444   List.iter (
1445     fun (name, style, _, _, shortdesc, _) ->
1446       generate_ocaml_prototype ~is_external:true name style;
1447   ) sorted_functions
1448
1449 (* Generate the OCaml bindings C implementation. *)
1450 and generate_ocaml_c () =
1451   generate_header CStyle LGPLv2;
1452
1453   pr "#include <stdio.h>\n";
1454   pr "#include <stdlib.h>\n";
1455   pr "\n";
1456   pr "#include <guestfs.h>\n";
1457   pr "\n";
1458   pr "#include <caml/config.h>\n";
1459   pr "#include <caml/alloc.h>\n";
1460   pr "#include <caml/callback.h>\n";
1461   pr "#include <caml/fail.h>\n";
1462   pr "#include <caml/memory.h>\n";
1463   pr "#include <caml/mlvalues.h>\n";
1464   pr "\n";
1465   pr "#include \"guestfs_c.h\"\n";
1466   pr "\n";
1467
1468   List.iter (
1469     fun (name, style, _, _, _, _) ->
1470       pr "CAMLprim value\n";
1471       pr "ocaml_guestfs_%s (value hv /* XXX */)\n" name;
1472       pr "{\n";
1473       pr "  CAMLparam1 (hv); /* XXX */\n";
1474       pr "/* XXX write something here */\n";
1475       pr "  CAMLreturn (Val_unit); /* XXX */\n";
1476       pr "}\n";
1477       pr "\n"
1478   ) sorted_functions
1479
1480 and generate_ocaml_lvm_structure_decls () =
1481   List.iter (
1482     fun (typ, cols) ->
1483       pr "type lvm_%s = {\n" typ;
1484       List.iter (
1485         function
1486         | name, `String -> pr "  %s : string;\n" name
1487         | name, `UUID -> pr "  %s : string;\n" name
1488         | name, `Bytes -> pr "  %s : int64;\n" name
1489         | name, `Int -> pr "  %s : int64;\n" name
1490         | name, `OptPercent -> pr "  %s : float option;\n" name
1491       ) cols;
1492       pr "}\n";
1493       pr "\n"
1494   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols]
1495
1496 and generate_ocaml_prototype ?(is_external = false) name style =
1497   if is_external then pr "external " else pr "val ";
1498   pr "%s : t -> " name;
1499   iter_args (
1500     function
1501     | String _ -> pr "string -> " (* note String is not allowed to be NULL *)
1502   ) (snd style);
1503   (match fst style with
1504    | Err -> pr "unit" (* all errors are turned into exceptions *)
1505    | RString _ -> pr "string"
1506    | RStringList _ -> pr "string list"
1507    | RPVList _ -> pr "lvm_pv list"
1508    | RVGList _ -> pr "lvm_vg list"
1509    | RLVList _ -> pr "lvm_lv list"
1510   );
1511   if is_external then pr " = \"ocaml_guestfs_%s\"" name;
1512   pr "\n"
1513
1514 (* Generate Perl xs code, a sort of crazy variation of C with macros. *)
1515 and generate_perl_xs () =
1516   generate_header CStyle LGPLv2;
1517
1518   pr "\
1519 #include \"EXTERN.h\"
1520 #include \"perl.h\"
1521 #include \"XSUB.h\"
1522
1523 #include <guestfs.h>
1524
1525 #ifndef PRId64
1526 #define PRId64 \"lld\"
1527 #endif
1528
1529 static SV *
1530 my_newSVll(long long val) {
1531 #ifdef USE_64_BIT_ALL
1532   return newSViv(val);
1533 #else
1534   char buf[100];
1535   int len;
1536   len = snprintf(buf, 100, \"%%\" PRId64, val);
1537   return newSVpv(buf, len);
1538 #endif
1539 }
1540
1541 #ifndef PRIu64
1542 #define PRIu64 \"llu\"
1543 #endif
1544
1545 static SV *
1546 my_newSVull(unsigned long long val) {
1547 #ifdef USE_64_BIT_ALL
1548   return newSVuv(val);
1549 #else
1550   char buf[100];
1551   int len;
1552   len = snprintf(buf, 100, \"%%\" PRIu64, val);
1553   return newSVpv(buf, len);
1554 #endif
1555 }
1556
1557 /* XXX Not thread-safe, and in general not safe if the caller is
1558  * issuing multiple requests in parallel (on different guestfs
1559  * handles).  We should use the guestfs_h handle passed to the
1560  * error handle to distinguish these cases.
1561  */
1562 static char *last_error = NULL;
1563
1564 static void
1565 error_handler (guestfs_h *g,
1566                void *data,
1567                const char *msg)
1568 {
1569   if (last_error != NULL) free (last_error);
1570   last_error = strdup (msg);
1571 }
1572
1573 MODULE = Sys::Guestfs  PACKAGE = Sys::Guestfs
1574
1575 guestfs_h *
1576 _create ()
1577    CODE:
1578       RETVAL = guestfs_create ();
1579       if (!RETVAL)
1580         croak (\"could not create guestfs handle\");
1581       guestfs_set_error_handler (RETVAL, error_handler, NULL);
1582  OUTPUT:
1583       RETVAL
1584
1585 void
1586 DESTROY (g)
1587       guestfs_h *g;
1588  PPCODE:
1589       guestfs_close (g);
1590
1591 void
1592 add_drive (g, filename)
1593       guestfs_h *g;
1594       const char *filename;
1595    CODE:
1596       if (guestfs_add_drive (g, filename) == -1)
1597         croak (\"add_drive: %%s\", last_error);
1598
1599 void
1600 add_cdrom (g, filename)
1601       guestfs_h *g;
1602       const char *filename;
1603    CODE:
1604       if (guestfs_add_cdrom (g, filename) == -1)
1605         croak (\"add_cdrom: %%s\", last_error);
1606
1607 void
1608 config (g, param, value)
1609       guestfs_h *g;
1610       const char *param;
1611       const char *value;
1612    CODE:
1613       if (guestfs_config (g, param, value) == -1)
1614         croak (\"config: %%s\", last_error);
1615
1616 void
1617 launch (g)
1618       guestfs_h *g;
1619    CODE:
1620       if (guestfs_launch (g) == -1)
1621         croak (\"launch: %%s\", last_error);
1622
1623 void
1624 wait_ready (g)
1625       guestfs_h *g;
1626    CODE:
1627       if (guestfs_wait_ready (g) == -1)
1628         croak (\"wait_ready: %%s\", last_error);
1629
1630 void
1631 set_path (g, path)
1632       guestfs_h *g;
1633       const char *path;
1634    CODE:
1635       guestfs_set_path (g, path);
1636
1637 SV *
1638 get_path (g)
1639       guestfs_h *g;
1640 PREINIT:
1641       const char *path;
1642    CODE:
1643       path = guestfs_get_path (g);
1644       RETVAL = newSVpv (path, 0);
1645  OUTPUT:
1646       RETVAL
1647
1648 void
1649 set_autosync (g, autosync)
1650       guestfs_h *g;
1651       int autosync;
1652    CODE:
1653       guestfs_set_autosync (g, autosync);
1654
1655 SV *
1656 get_autosync (g)
1657       guestfs_h *g;
1658 PREINIT:
1659       int autosync;
1660    CODE:
1661       autosync = guestfs_get_autosync (g);
1662       RETVAL = newSViv (autosync);
1663  OUTPUT:
1664       RETVAL
1665
1666 void
1667 set_verbose (g, verbose)
1668       guestfs_h *g;
1669       int verbose;
1670    CODE:
1671       guestfs_set_verbose (g, verbose);
1672
1673 SV *
1674 get_verbose (g)
1675       guestfs_h *g;
1676 PREINIT:
1677       int verbose;
1678    CODE:
1679       verbose = guestfs_get_verbose (g);
1680       RETVAL = newSViv (verbose);
1681  OUTPUT:
1682       RETVAL
1683
1684 ";
1685
1686   List.iter (
1687     fun (name, style, _, _, _, _) ->
1688       (match fst style with
1689        | Err -> pr "void\n"
1690        | RString _ -> pr "SV *\n"
1691        | RStringList _
1692        | RPVList _ | RVGList _ | RLVList _ ->
1693            pr "void\n" (* all lists returned implictly on the stack *)
1694       );
1695       (* Call and arguments. *)
1696       pr "%s " name;
1697       generate_call_args ~handle:"g" style;
1698       pr "\n";
1699       pr "      guestfs_h *g;\n";
1700       iter_args (
1701         function
1702         | String n -> pr "      char *%s;\n" n
1703       ) (snd style);
1704       (* Code. *)
1705       (match fst style with
1706        | Err ->
1707            pr " PPCODE:\n";
1708            pr "      if (guestfs_%s " name;
1709            generate_call_args ~handle:"g" style;
1710            pr " == -1)\n";
1711            pr "        croak (\"%s: %%s\", last_error);\n" name
1712        | RString n ->
1713            pr "PREINIT:\n";
1714            pr "      char *%s;\n" n;
1715            pr "   CODE:\n";
1716            pr "      %s = guestfs_%s " n name;
1717            generate_call_args ~handle:"g" style;
1718            pr ";\n";
1719            pr "      if (%s == NULL)\n" n;
1720            pr "        croak (\"%s: %%s\", last_error);\n" name;
1721            pr "      RETVAL = newSVpv (%s, 0);\n" n;
1722            pr "      free (%s);\n" n;
1723            pr " OUTPUT:\n";
1724            pr "      RETVAL\n"
1725        | RStringList n ->
1726            pr "PREINIT:\n";
1727            pr "      char **%s;\n" n;
1728            pr "      int i, n;\n";
1729            pr " PPCODE:\n";
1730            pr "      %s = guestfs_%s " n name;
1731            generate_call_args ~handle:"g" style;
1732            pr ";\n";
1733            pr "      if (%s == NULL)\n" n;
1734            pr "        croak (\"%s: %%s\", last_error);\n" name;
1735            pr "      for (n = 0; %s[n] != NULL; ++n) /**/;\n" n;
1736            pr "      EXTEND (SP, n);\n";
1737            pr "      for (i = 0; i < n; ++i) {\n";
1738            pr "        PUSHs (sv_2mortal (newSVpv (%s[i], 0)));\n" n;
1739            pr "        free (%s[i]);\n" n;
1740            pr "      }\n";
1741            pr "      free (%s);\n" n;
1742        | RPVList n ->
1743            generate_perl_lvm_code "pv" pv_cols name style n;
1744        | RVGList n ->
1745            generate_perl_lvm_code "vg" vg_cols name style n;
1746        | RLVList n ->
1747            generate_perl_lvm_code "lv" lv_cols name style n;
1748       );
1749       pr "\n"
1750   ) functions
1751
1752 and generate_perl_lvm_code typ cols name style n =
1753   pr "PREINIT:\n";
1754   pr "      struct guestfs_lvm_%s_list *%s;\n" typ n;
1755   pr "      int i;\n";
1756   pr "      HV *hv;\n";
1757   pr " PPCODE:\n";
1758   pr "      %s = guestfs_%s " n name;
1759   generate_call_args ~handle:"g" style;
1760   pr ";\n";
1761   pr "      if (%s == NULL)\n" n;
1762   pr "        croak (\"%s: %%s\", last_error);\n" name;
1763   pr "      EXTEND (SP, %s->len);\n" n;
1764   pr "      for (i = 0; i < %s->len; ++i) {\n" n;
1765   pr "        hv = newHV ();\n";
1766   List.iter (
1767     function
1768     | name, `String ->
1769         pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (%s->val[i].%s, 0), 0);\n"
1770           name (String.length name) n name
1771     | name, `UUID ->
1772         pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (%s->val[i].%s, 32), 0);\n"
1773           name (String.length name) n name
1774     | name, `Bytes ->
1775         pr "        (void) hv_store (hv, \"%s\", %d, my_newSVull (%s->val[i].%s), 0);\n"
1776           name (String.length name) n name
1777     | name, `Int ->
1778         pr "        (void) hv_store (hv, \"%s\", %d, my_newSVll (%s->val[i].%s), 0);\n"
1779           name (String.length name) n name
1780     | name, `OptPercent ->
1781         pr "        (void) hv_store (hv, \"%s\", %d, newSVnv (%s->val[i].%s), 0);\n"
1782           name (String.length name) n name
1783   ) cols;
1784   pr "        PUSHs (sv_2mortal ((SV *) hv));\n";
1785   pr "      }\n";
1786   pr "      guestfs_free_lvm_%s_list (%s);\n" typ n
1787
1788 (* Generate Sys/Guestfs.pm. *)
1789 and generate_perl_pm () =
1790   generate_header HashStyle LGPLv2;
1791
1792   pr "\
1793 =pod
1794
1795 =head1 NAME
1796
1797 Sys::Guestfs - Perl bindings for libguestfs
1798
1799 =head1 SYNOPSIS
1800
1801  use Sys::Guestfs;
1802
1803  my $h = Sys::Guestfs->new ();
1804  $h->add_drive ('guest.img');
1805  $h->launch ();
1806  $h->wait_ready ();
1807  $h->mount ('/dev/sda1', '/');
1808  $h->touch ('/hello');
1809  $h->sync ();
1810
1811 =head1 DESCRIPTION
1812
1813 The C<Sys::Guestfs> module provides a Perl XS binding to the
1814 libguestfs API for examining and modifying virtual machine
1815 disk images.
1816
1817 Amongst the things this is good for: making batch configuration
1818 changes to guests, getting disk used/free statistics (see also:
1819 virt-df), migrating between virtualization systems (see also:
1820 virt-p2v), performing partial backups, performing partial guest
1821 clones, cloning guests and changing registry/UUID/hostname info, and
1822 much else besides.
1823
1824 Libguestfs uses Linux kernel and qemu code, and can access any type of
1825 guest filesystem that Linux and qemu can, including but not limited
1826 to: ext2/3/4, btrfs, FAT and NTFS, LVM, many different disk partition
1827 schemes, qcow, qcow2, vmdk.
1828
1829 Libguestfs provides ways to enumerate guest storage (eg. partitions,
1830 LVs, what filesystem is in each LV, etc.).  It can also run commands
1831 in the context of the guest.  Also you can access filesystems over FTP.
1832
1833 =head1 ERRORS
1834
1835 All errors turn into calls to C<croak> (see L<Carp(3)>).
1836
1837 =head1 METHODS
1838
1839 =over 4
1840
1841 =cut
1842
1843 package Sys::Guestfs;
1844
1845 use strict;
1846 use warnings;
1847
1848 require XSLoader;
1849 XSLoader::load ('Sys::Guestfs');
1850
1851 =item $h = Sys::Guestfs->new ();
1852
1853 Create a new guestfs handle.
1854
1855 =cut
1856
1857 sub new {
1858   my $proto = shift;
1859   my $class = ref ($proto) || $proto;
1860
1861   my $self = Sys::Guestfs::_create ();
1862   bless $self, $class;
1863   return $self;
1864 }
1865
1866 =item $h->add_drive ($filename);
1867
1868 =item $h->add_cdrom ($filename);
1869
1870 This function adds a virtual machine disk image C<filename> to the
1871 guest.  The first time you call this function, the disk appears as IDE
1872 disk 0 (C</dev/sda>) in the guest, the second time as C</dev/sdb>, and
1873 so on.
1874
1875 You don't necessarily need to be root when using libguestfs.  However
1876 you obviously do need sufficient permissions to access the filename
1877 for whatever operations you want to perform (ie. read access if you
1878 just want to read the image or write access if you want to modify the
1879 image).
1880
1881 The C<add_cdrom> variation adds a CD-ROM device.
1882
1883 =item $h->config ($param, $value);
1884
1885 =item $h->config ($param);
1886
1887 Use this to add arbitrary parameters to the C<qemu> command line.
1888 See L<qemu(1)>.
1889
1890 =item $h->launch ();
1891
1892 =item $h->wait_ready ();
1893
1894 Internally libguestfs is implemented by running a virtual machine
1895 using L<qemu(1)>.  These calls are necessary in order to boot the
1896 virtual machine.
1897
1898 You should call these two functions after configuring the handle
1899 (eg. adding drives) but before performing any actions.
1900
1901 =item $h->set_path ($path);
1902
1903 =item $path = $h->get_path ();
1904
1905 See the discussion of C<PATH> in the L<guestfs(3)>
1906 manpage.
1907
1908 =item $h->set_autosync ($autosync);
1909
1910 =item $autosync = $h->get_autosync ();
1911
1912 See the discussion of I<AUTOSYNC> in the L<guestfs(3)>
1913 manpage.
1914
1915 =item $h->set_verbose ($verbose);
1916
1917 =item $verbose = $h->get_verbose ();
1918
1919 This sets or gets the verbose messages flag.  Verbose
1920 messages are sent to C<stderr>.
1921
1922 ";
1923
1924   (* Actions.  We only need to print documentation for these as
1925    * they are pulled in from the XS code automatically.
1926    *)
1927   List.iter (
1928     fun (name, style, _, flags, _, longdesc) ->
1929       let longdesc = replace_str longdesc "C<guestfs_" "C<$h-E<gt>" in
1930       pr "=item ";
1931       generate_perl_prototype name style;
1932       pr "\n\n";
1933       pr "%s\n\n" longdesc;
1934       if List.mem ProtocolLimitWarning flags then
1935         pr "Because of the message protocol, there is a transfer limit
1936 of somewhere between 2MB and 4MB.  To transfer large files you should use
1937 FTP.\n\n";
1938   ) sorted_functions;
1939
1940   (* End of file. *)
1941   pr "\
1942 =cut
1943
1944 1;
1945
1946 =back
1947
1948 =head1 COPYRIGHT
1949
1950 Copyright (C) 2009 Red Hat Inc.
1951
1952 =head1 LICENSE
1953
1954 Please see the file COPYING.LIB for the full license.
1955
1956 =head1 SEE ALSO
1957
1958 L<guestfs(3)>, L<guestfish(1)>.
1959
1960 =cut
1961 "
1962
1963 and generate_perl_prototype name style =
1964   (match fst style with
1965    | Err -> ()
1966    | RString n -> pr "$%s = " n
1967    | RStringList n
1968    | RPVList n
1969    | RVGList n
1970    | RLVList n -> pr "@%s = " n
1971   );
1972   pr "$h->%s (" name;
1973   let comma = ref false in
1974   iter_args (
1975     fun arg ->
1976       if !comma then pr ", ";
1977       comma := true;
1978       match arg with
1979       | String n -> pr "%s" n
1980   ) (snd style);
1981   pr ");"
1982
1983 let output_to filename =
1984   let filename_new = filename ^ ".new" in
1985   chan := open_out filename_new;
1986   let close () =
1987     close_out !chan;
1988     chan := stdout;
1989     Unix.rename filename_new filename;
1990     printf "written %s\n%!" filename;
1991   in
1992   close
1993
1994 (* Main program. *)
1995 let () =
1996   check_functions ();
1997
1998   let close = output_to "src/guestfs_protocol.x" in
1999   generate_xdr ();
2000   close ();
2001
2002   let close = output_to "src/guestfs-structs.h" in
2003   generate_structs_h ();
2004   close ();
2005
2006   let close = output_to "src/guestfs-actions.h" in
2007   generate_actions_h ();
2008   close ();
2009
2010   let close = output_to "src/guestfs-actions.c" in
2011   generate_client_actions ();
2012   close ();
2013
2014   let close = output_to "daemon/actions.h" in
2015   generate_daemon_actions_h ();
2016   close ();
2017
2018   let close = output_to "daemon/stubs.c" in
2019   generate_daemon_actions ();
2020   close ();
2021
2022   let close = output_to "fish/cmds.c" in
2023   generate_fish_cmds ();
2024   close ();
2025
2026   let close = output_to "guestfs-structs.pod" in
2027   generate_structs_pod ();
2028   close ();
2029
2030   let close = output_to "guestfs-actions.pod" in
2031   generate_actions_pod ();
2032   close ();
2033
2034   let close = output_to "guestfish-actions.pod" in
2035   generate_fish_actions_pod ();
2036   close ();
2037
2038   let close = output_to "ocaml/guestfs.mli" in
2039   generate_ocaml_mli ();
2040   close ();
2041
2042   let close = output_to "ocaml/guestfs.ml" in
2043   generate_ocaml_ml ();
2044   close ();
2045
2046   let close = output_to "ocaml/guestfs_c_actions.c" in
2047   generate_ocaml_c ();
2048   close ();
2049
2050   let close = output_to "perl/Guestfs.xs" in
2051   generate_perl_xs ();
2052   close ();
2053
2054   let close = output_to "perl/lib/Sys/Guestfs.pm" in
2055   generate_perl_pm ();
2056   close ();