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