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