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
  20 (* This script generates a large amount of code and documentation for
  21  * all the daemon actions.
  22  *
  23  * To add a new action there are only two files you need to change,
  24  * this one to describe the interface (see the big table below), and
  25  * daemon/<somefile>.c to write the implementation.
  26  *
  27  * After editing this file, run it (./src/generator.ml) to regenerate
  28  * all the output files.
  29  *
  30  * IMPORTANT: This script should NOT print any warnings.  If it prints
  31  * warnings, you should treat them as errors.
  32  * [Need to add -warn-error to ocaml command line]
  33  *)
  34
  35 #load "unix.cma";;
  36
  37 open Printf
  38
  39 type style = ret * args
  40 and ret =
  41     (* "RErr" as a return value means an int used as a simple error
  42      * indication, ie. 0 or -1.
  43      *)
  44   | RErr
  45     (* "RInt" as a return value means an int which is -1 for error
  46      * or any value >= 0 on success.
  47      *)
  48   | RInt of string
  49     (* "RBool" is a bool return value which can be true/false or
  50      * -1 for error.
  51      *)
  52   | RBool of string
  53     (* "RConstString" is a string that refers to a constant value.
  54      * Try to avoid using this.  In particular you cannot use this
  55      * for values returned from the daemon, because there is no
  56      * thread-safe way to return them in the C API.
  57      *)
  58   | RConstString of string
  59     (* "RString" and "RStringList" are caller-frees. *)
  60   | RString of string
  61   | RStringList of string
  62     (* Some limited tuples are possible: *)
  63   | RIntBool of string * string
  64     (* LVM PVs, VGs and LVs. *)
  65   | RPVList of string
  66   | RVGList of string
  67   | RLVList of string
  68 and args = argt list    (* Function parameters, guestfs handle is implicit. *)
  69
  70     (* Note in future we should allow a "variable args" parameter as
  71      * the final parameter, to allow commands like
  72      *   chmod mode file [file(s)...]
  73      * This is not implemented yet, but many commands (such as chmod)
  74      * are currently defined with the argument order keeping this future
  75      * possibility in mind.
  76      *)
  77 and argt =
  78   | String of string    (* const char *name, cannot be NULL *)
  79   | OptString of string (* const char *name, may be NULL *)
  80   | Bool of string      (* boolean *)
  81   | Int of string       (* int (smallish ints, signed, <= 31 bits) *)
  82
  83 type flags =
  84   | ProtocolLimitWarning  (* display warning about protocol size limits *)
  85   | FishAlias of string   (* provide an alias for this cmd in guestfish *)
  86   | FishAction of string  (* call this function in guestfish *)
  87   | NotInFish             (* do not export via guestfish *)
  88
  89 (* You can supply zero or as many tests as you want per API call.
  90  *
  91  * Note that the test environment has 3 block devices, of size 10M, 20M
  92  * and 30M (respectively /dev/sda, /dev/sdb, /dev/sdc).  To run the
  93  * tests in a reasonable amount of time, the virtual machine and
  94  * block devices are reused between tests. So don't try testing
  95  * kill_subprocess :-x
  96  *
  97  * Don't assume anything about the previous contents of the block
  98  * devices.  Use 'Init*' to create some initial scenarios.
  99  *)
 100 type tests = test list
 101 and test =
 102     (* Run the command sequence and just expect nothing to fail. *)
 103   | TestRun of test_init * seq
 104     (* Run the command sequence and expect the output of the final
 105      * command to be the string.
 106      *)
 107   | TestOutput of test_init * seq * string
 108     (* Run the command sequence and expect the output of the final
 109      * command to be the list of strings.
 110      *)
 111   | TestOutputList of test_init * seq * string list
 112     (* Run the command sequence and expect the output of the final
 113      * command to be the integer.
 114      *)
 115   | TestOutputInt of test_init * seq * int
 116     (* Run the command sequence and expect the output of the final
 117      * command to be a true value (!= 0 or != NULL).
 118      *)
 119   | TestOutputTrue of test_init * seq
 120     (* Run the command sequence and expect the output of the final
 121      * command to be a false value (== 0 or == NULL, but not an error).
 122      *)
 123   | TestOutputFalse of test_init * seq
 124     (* Run the command sequence and expect the output of the final
 125      * command to be a list of the given length (but don't care about
 126      * content).
 127      *)
 128   | TestOutputLength of test_init * seq * int
 129     (* Run the command sequence and expect the final command (only)
 130      * to fail.
 131      *)
 132   | TestLastFail of test_init * seq
 133
 134 (* Some initial scenarios for testing. *)
 135 and test_init =
 136     (* Do nothing, block devices could contain random stuff. *)
 137   | InitNone
 138     (* /dev/sda contains a single partition /dev/sda1, which is formatted
 139      * as ext2, empty [except for lost+found] and mounted on /.
 140      * /dev/sdb and /dev/sdc may have random content.
 141      * No LVM.
 142      *)
 143   | InitEmpty
 144     (* /dev/sda:
 145      *   /dev/sda1 (is a PV):
 146      *     /dev/VG/LV:
 147      *       formatted as ext2, empty [except for lost+found], mounted on /
 148      * /dev/sdb and /dev/sdc may have random content.
 149      *)
 150   | InitEmptyLVM
 151
 152 (* Sequence of commands for testing. *)
 153 and seq = cmd list
 154 and cmd = string list
 155
 156 (* Note about long descriptions: When referring to another
 157  * action, use the format C<guestfs_other> (ie. the full name of
 158  * the C function).  This will be replaced as appropriate in other
 159  * language bindings.
 160  *
 161  * Apart from that, long descriptions are just perldoc paragraphs.
 162  *)
 163
 164 let non_daemon_functions = [
 165   ("launch", (RErr, []), -1, [FishAlias "run"; FishAction "launch"],
 166    [],
 167    "launch the qemu subprocess",
 168    "\
 169 Internally libguestfs is implemented by running a virtual machine
 170 using L<qemu(1)>.
 171
 172 You should call this after configuring the handle
 173 (eg. adding drives) but before performing any actions.");
 174
 175   ("wait_ready", (RErr, []), -1, [NotInFish],
 176    [],
 177    "wait until the qemu subprocess launches",
 178    "\
 179 Internally libguestfs is implemented by running a virtual machine
 180 using L<qemu(1)>.
 181
 182 You should call this after C<guestfs_launch> to wait for the launch
 183 to complete.");
 184
 185   ("kill_subprocess", (RErr, []), -1, [],
 186    [],
 187    "kill the qemu subprocess",
 188    "\
 189 This kills the qemu subprocess.  You should never need to call this.");
 190
 191   ("add_drive", (RErr, [String "filename"]), -1, [FishAlias "add"],
 192    [],
 193    "add an image to examine or modify",
 194    "\
 195 This function adds a virtual machine disk image C<filename> to the
 196 guest.  The first time you call this function, the disk appears as IDE
 197 disk 0 (C</dev/sda>) in the guest, the second time as C</dev/sdb>, and
 198 so on.
 199
 200 You don't necessarily need to be root when using libguestfs.  However
 201 you obviously do need sufficient permissions to access the filename
 202 for whatever operations you want to perform (ie. read access if you
 203 just want to read the image or write access if you want to modify the
 204 image).
 205
 206 This is equivalent to the qemu parameter C<-drive file=filename>.");
 207
 208   ("add_cdrom", (RErr, [String "filename"]), -1, [FishAlias "cdrom"],
 209    [],
 210    "add a CD-ROM disk image to examine",
 211    "\
 212 This function adds a virtual CD-ROM disk image to the guest.
 213
 214 This is equivalent to the qemu parameter C<-cdrom filename>.");
 215
 216   ("config", (RErr, [String "qemuparam"; OptString "qemuvalue"]), -1, [],
 217    [],
 218    "add qemu parameters",
 219    "\
 220 This can be used to add arbitrary qemu command line parameters
 221 of the form C<-param value>.  Actually it's not quite arbitrary - we
 222 prevent you from setting some parameters which would interfere with
 223 parameters that we use.
 224
 225 The first character of C<param> string must be a C<-> (dash).
 226
 227 C<value> can be NULL.");
 228
 229   ("set_path", (RErr, [String "path"]), -1, [FishAlias "path"],
 230    [],
 231    "set the search path",
 232    "\
 233 Set the path that libguestfs searches for kernel and initrd.img.
 234
 235 The default is C<$libdir/guestfs> unless overridden by setting
 236 C<LIBGUESTFS_PATH> environment variable.
 237
 238 The string C<path> is stashed in the libguestfs handle, so the caller
 239 must make sure it remains valid for the lifetime of the handle.
 240
 241 Setting C<path> to C<NULL> restores the default path.");
 242
 243   ("get_path", (RConstString "path", []), -1, [],
 244    [],
 245    "get the search path",
 246    "\
 247 Return the current search path.
 248
 249 This is always non-NULL.  If it wasn't set already, then this will
 250 return the default path.");
 251
 252   ("set_autosync", (RErr, [Bool "autosync"]), -1, [FishAlias "autosync"],
 253    [],
 254    "set autosync mode",
 255    "\
 256 If C<autosync> is true, this enables autosync.  Libguestfs will make a
 257 best effort attempt to run C<guestfs_sync> when the handle is closed
 258 (also if the program exits without closing handles).");
 259
 260   ("get_autosync", (RBool "autosync", []), -1, [],
 261    [],
 262    "get autosync mode",
 263    "\
 264 Get the autosync flag.");
 265
 266   ("set_verbose", (RErr, [Bool "verbose"]), -1, [FishAlias "verbose"],
 267    [],
 268    "set verbose mode",
 269    "\
 270 If C<verbose> is true, this turns on verbose messages (to C<stderr>).
 271
 272 Verbose messages are disabled unless the environment variable
 273 C<LIBGUESTFS_DEBUG> is defined and set to C<1>.");
 274
 275   ("get_verbose", (RBool "verbose", []), -1, [],
 276    [],
 277    "get verbose mode",
 278    "\
 279 This returns the verbose messages flag.")
 280 ]
 281
 282 let daemon_functions = [
 283   ("mount", (RErr, [String "device"; String "mountpoint"]), 1, [],
 284    [TestOutput (
 285       InitNone,
 286       [["sfdisk"];
 287        ["mkfs"; "ext2"; "/dev/sda1"];
 288        ["mount"; "/dev/sda1"; "/"];
 289        ["write_file"; "/new"; "new file contents"; "0"];
 290        ["cat"; "/new"]], "new file contents")],
 291    "mount a guest disk at a position in the filesystem",
 292    "\
 293 Mount a guest disk at a position in the filesystem.  Block devices
 294 are named C</dev/sda>, C</dev/sdb> and so on, as they were added to
 295 the guest.  If those block devices contain partitions, they will have
 296 the usual names (eg. C</dev/sda1>).  Also LVM C</dev/VG/LV>-style
 297 names can be used.
 298
 299 The rules are the same as for L<mount(2)>:  A filesystem must
 300 first be mounted on C</> before others can be mounted.  Other
 301 filesystems can only be mounted on directories which already
 302 exist.
 303
 304 The mounted filesystem is writable, if we have sufficient permissions
 305 on the underlying device.
 306
 307 The filesystem options C<sync> and C<noatime> are set with this
 308 call, in order to improve reliability.");
 309
 310   ("sync", (RErr, []), 2, [],
 311    [ TestRun (InitNone, [["sync"]])],
 312    "sync disks, writes are flushed through to the disk image",
 313    "\
 314 This syncs the disk, so that any writes are flushed through to the
 315 underlying disk image.
 316
 317 You should always call this if you have modified a disk image, before
 318 closing the handle.");
 319
 320   ("touch", (RErr, [String "path"]), 3, [],
 321    [TestOutputTrue (
 322       InitEmpty,
 323       [["touch"; "/new"];
 324        ["exists"; "/new"]])],
 325    "update file timestamps or create a new file",
 326    "\
 327 Touch acts like the L<touch(1)> command.  It can be used to
 328 update the timestamps on a file, or, if the file does not exist,
 329 to create a new zero-length file.");
 330
 331   ("cat", (RString "content", [String "path"]), 4, [ProtocolLimitWarning],
 332    [TestOutput (
 333       InitEmpty,
 334       [["write_file"; "/new"; "new file contents"; "0"];
 335        ["cat"; "/new"]], "new file contents")],
 336    "list the contents of a file",
 337    "\
 338 Return the contents of the file named C<path>.
 339
 340 Note that this function cannot correctly handle binary files
 341 (specifically, files containing C<\\0> character which is treated
 342 as end of string).  For those you need to use the C<guestfs_read_file>
 343 function which has a more complex interface.");
 344
 345   ("ll", (RString "listing", [String "directory"]), 5, [],
 346    [], (* XXX Tricky to test because it depends on the exact format
 347         * of the 'ls -l' command, which changes between F10 and F11.
 348         *)
 349    "list the files in a directory (long format)",
 350    "\
 351 List the files in C<directory> (relative to the root directory,
 352 there is no cwd) in the format of 'ls -la'.
 353
 354 This command is mostly useful for interactive sessions.  It
 355 is I<not> intended that you try to parse the output string.");
 356
 357   ("ls", (RStringList "listing", [String "directory"]), 6, [],
 358    [TestOutputList (
 359       InitEmpty,
 360       [["touch"; "/new"];
 361        ["touch"; "/newer"];
 362        ["touch"; "/newest"];
 363        ["ls"; "/"]], ["lost+found"; "new"; "newer"; "newest"])],
 364    "list the files in a directory",
 365    "\
 366 List the files in C<directory> (relative to the root directory,
 367 there is no cwd).  The '.' and '..' entries are not returned, but
 368 hidden files are shown.
 369
 370 This command is mostly useful for interactive sessions.  Programs
 371 should probably use C<guestfs_readdir> instead.");
 372
 373   ("list_devices", (RStringList "devices", []), 7, [],
 374    [TestOutputList (
 375       InitNone,
 376       [["list_devices"]], ["/dev/sda"; "/dev/sdb"; "/dev/sdc"])],
 377    "list the block devices",
 378    "\
 379 List all the block devices.
 380
 381 The full block device names are returned, eg. C</dev/sda>");
 382
 383   ("list_partitions", (RStringList "partitions", []), 8, [],
 384    [TestOutputList (
 385       InitEmpty,
 386       [["list_partitions"]], ["/dev/sda1"]);
 387     TestOutputList (
 388       InitEmpty,
 389       [["sfdisk"];
 390        ["list_partitions"]], ["/dev/sda1"; "/dev/sda2"; "/dev/sda3"])],
 391    "list the partitions",
 392    "\
 393 List all the partitions detected on all block devices.
 394
 395 The full partition device names are returned, eg. C</dev/sda1>
 396
 397 This does not return logical volumes.  For that you will need to
 398 call C<guestfs_lvs>.");
 399
 400   ("pvs", (RStringList "physvols", []), 9, [],
 401    [TestOutputList (
 402       InitEmptyLVM,
 403       [["pvs"]], ["/dev/sda1"]);
 404     TestOutputList (
 405       InitNone,
 406       [["sfdisk"];
 407        ["pvcreate"; "/dev/sda1"];
 408        ["pvcreate"; "/dev/sda2"];
 409        ["pvcreate"; "/dev/sda3"];
 410        ["pvs"]], ["/dev/sda1"; "/dev/sda2"; "/dev/sda3"])],
 411    "list the LVM physical volumes (PVs)",
 412    "\
 413 List all the physical volumes detected.  This is the equivalent
 414 of the L<pvs(8)> command.
 415
 416 This returns a list of just the device names that contain
 417 PVs (eg. C</dev/sda2>).
 418
 419 See also C<guestfs_pvs_full>.");
 420
 421   ("vgs", (RStringList "volgroups", []), 10, [],
 422    [TestOutputList (
 423       InitEmptyLVM,
 424       [["vgs"]], ["VG"]);
 425     TestOutputList (
 426       InitNone,
 427       [["sfdisk"];
 428        ["pvcreate"; "/dev/sda1"];
 429        ["pvcreate"; "/dev/sda2"];
 430        ["pvcreate"; "/dev/sda3"];
 431        ["vgcreate"; "VG1"; "/dev/sda1 /dev/sda2"];
 432        ["vgcreate"; "VG2"; "/dev/sda3"];
 433        ["vgs"]], ["VG1"; "VG2"])],
 434    "list the LVM volume groups (VGs)",
 435    "\
 436 List all the volumes groups detected.  This is the equivalent
 437 of the L<vgs(8)> command.
 438
 439 This returns a list of just the volume group names that were
 440 detected (eg. C<VolGroup00>).
 441
 442 See also C<guestfs_vgs_full>.");
 443
 444   ("lvs", (RStringList "logvols", []), 11, [],
 445    [TestOutputList (
 446       InitEmptyLVM,
 447       [["lvs"]], ["/dev/VG/LV"]);
 448     TestOutputList (
 449       InitNone,
 450       [["sfdisk"];
 451        ["pvcreate"; "/dev/sda1"];
 452        ["pvcreate"; "/dev/sda2"];
 453        ["pvcreate"; "/dev/sda3"];
 454        ["vgcreate"; "VG1"; "/dev/sda1 /dev/sda2"];
 455        ["vgcreate"; "VG2"; "/dev/sda3"];
 456        ["lvcreate"; "LV1"; "VG1"; "5000"];
 457        ["lvcreate"; "LV2"; "VG1"; "5000"];
 458        ["lvcreate"; "LV3"; "VG2"; "5000"];
 459        ["lvs"]], ["LV1"; "LV2"; "LV3"])],
 460    "list the LVM logical volumes (LVs)",
 461    "\
 462 List all the logical volumes detected.  This is the equivalent
 463 of the L<lvs(8)> command.
 464
 465 This returns a list of the logical volume device names
 466 (eg. C</dev/VolGroup00/LogVol00>).
 467
 468 See also C<guestfs_lvs_full>.");
 469
 470   ("pvs_full", (RPVList "physvols", []), 12, [],
 471    [TestOutputLength (
 472       InitEmptyLVM,
 473       [["pvs"]], 1)],
 474    "list the LVM physical volumes (PVs)",
 475    "\
 476 List all the physical volumes detected.  This is the equivalent
 477 of the L<pvs(8)> command.  The \"full\" version includes all fields.");
 478
 479   ("vgs_full", (RVGList "volgroups", []), 13, [],
 480    [TestOutputLength (
 481       InitEmptyLVM,
 482       [["pvs"]], 1)],
 483    "list the LVM volume groups (VGs)",
 484    "\
 485 List all the volumes groups detected.  This is the equivalent
 486 of the L<vgs(8)> command.  The \"full\" version includes all fields.");
 487
 488   ("lvs_full", (RLVList "logvols", []), 14, [],
 489    [TestOutputLength (
 490       InitEmptyLVM,
 491       [["pvs"]], 1)],
 492    "list the LVM logical volumes (LVs)",
 493    "\
 494 List all the logical volumes detected.  This is the equivalent
 495 of the L<lvs(8)> command.  The \"full\" version includes all fields.");
 496
 497   ("read_lines", (RStringList "lines", [String "path"]), 15, [],
 498    [TestOutputList (
 499       InitEmpty,
 500       [["write_file"; "/new"; "line1\r\nline2\nline3"; "0"];
 501        ["read_lines"; "/new"]], ["line1"; "line2"; "line3"]);
 502     TestOutputList (
 503       InitEmpty,
 504       [["write_file"; "/new"; ""; "0"];
 505        ["read_lines"; "/new"]], [])],
 506    "read file as lines",
 507    "\
 508 Return the contents of the file named C<path>.
 509
 510 The file contents are returned as a list of lines.  Trailing
 511 C<LF> and C<CRLF> character sequences are I<not> returned.
 512
 513 Note that this function cannot correctly handle binary files
 514 (specifically, files containing C<\\0> character which is treated
 515 as end of line).  For those you need to use the C<guestfs_read_file>
 516 function which has a more complex interface.");
 517
 518   ("aug_init", (RErr, [String "root"; Int "flags"]), 16, [],
 519    [], (* XXX Augeas code needs tests. *)
 520    "create a new Augeas handle",
 521    "\
 522 Create a new Augeas handle for editing configuration files.
 523 If there was any previous Augeas handle associated with this
 524 guestfs session, then it is closed.
 525
 526 You must call this before using any other C<guestfs_aug_*>
 527 commands.
 528
 529 C<root> is the filesystem root.  C<root> must not be NULL,
 530 use C</> instead.
 531
 532 The flags are the same as the flags defined in
 533 E<lt>augeas.hE<gt>, the logical I<or> of the following
 534 integers:
 535
 536 =over 4
 537
 538 =item C<AUG_SAVE_BACKUP> = 1
 539
 540 Keep the original file with a C<.augsave> extension.
 541
 542 =item C<AUG_SAVE_NEWFILE> = 2
 543
 544 Save changes into a file with extension C<.augnew>, and
 545 do not overwrite original.  Overrides C<AUG_SAVE_BACKUP>.
 546
 547 =item C<AUG_TYPE_CHECK> = 4
 548
 549 Typecheck lenses (can be expensive).
 550
 551 =item C<AUG_NO_STDINC> = 8
 552
 553 Do not use standard load path for modules.
 554
 555 =item C<AUG_SAVE_NOOP> = 16
 556
 557 Make save a no-op, just record what would have been changed.
 558
 559 =item C<AUG_NO_LOAD> = 32
 560
 561 Do not load the tree in C<guestfs_aug_init>.
 562
 563 =back
 564
 565 To close the handle, you can call C<guestfs_aug_close>.
 566
 567 To find out more about Augeas, see L<http://augeas.net/>.");
 568
 569   ("aug_close", (RErr, []), 26, [],
 570    [], (* XXX Augeas code needs tests. *)
 571    "close the current Augeas handle",
 572    "\
 573 Close the current Augeas handle and free up any resources
 574 used by it.  After calling this, you have to call
 575 C<guestfs_aug_init> again before you can use any other
 576 Augeas functions.");
 577
 578   ("aug_defvar", (RInt "nrnodes", [String "name"; OptString "expr"]), 17, [],
 579    [], (* XXX Augeas code needs tests. *)
 580    "define an Augeas variable",
 581    "\
 582 Defines an Augeas variable C<name> whose value is the result
 583 of evaluating C<expr>.  If C<expr> is NULL, then C<name> is
 584 undefined.
 585
 586 On success this returns the number of nodes in C<expr>, or
 587 C<0> if C<expr> evaluates to something which is not a nodeset.");
 588
 589   ("aug_defnode", (RIntBool ("nrnodes", "created"), [String "name"; String "expr"; String "val"]), 18, [],
 590    [], (* XXX Augeas code needs tests. *)
 591    "define an Augeas node",
 592    "\
 593 Defines a variable C<name> whose value is the result of
 594 evaluating C<expr>.
 595
 596 If C<expr> evaluates to an empty nodeset, a node is created,
 597 equivalent to calling C<guestfs_aug_set> C<expr>, C<value>.
 598 C<name> will be the nodeset containing that single node.
 599
 600 On success this returns a pair containing the
 601 number of nodes in the nodeset, and a boolean flag
 602 if a node was created.");
 603
 604   ("aug_get", (RString "val", [String "path"]), 19, [],
 605    [], (* XXX Augeas code needs tests. *)
 606    "look up the value of an Augeas path",
 607    "\
 608 Look up the value associated with C<path>.  If C<path>
 609 matches exactly one node, the C<value> is returned.");
 610
 611   ("aug_set", (RErr, [String "path"; String "val"]), 20, [],
 612    [], (* XXX Augeas code needs tests. *)
 613    "set Augeas path to value",
 614    "\
 615 Set the value associated with C<path> to C<value>.");
 616
 617   ("aug_insert", (RErr, [String "path"; String "label"; Bool "before"]), 21, [],
 618    [], (* XXX Augeas code needs tests. *)
 619    "insert a sibling Augeas node",
 620    "\
 621 Create a new sibling C<label> for C<path>, inserting it into
 622 the tree before or after C<path> (depending on the boolean
 623 flag C<before>).
 624
 625 C<path> must match exactly one existing node in the tree, and
 626 C<label> must be a label, ie. not contain C</>, C<*> or end
 627 with a bracketed index C<[N]>.");
 628
 629   ("aug_rm", (RInt "nrnodes", [String "path"]), 22, [],
 630    [], (* XXX Augeas code needs tests. *)
 631    "remove an Augeas path",
 632    "\
 633 Remove C<path> and all of its children.
 634
 635 On success this returns the number of entries which were removed.");
 636
 637   ("aug_mv", (RErr, [String "src"; String "dest"]), 23, [],
 638    [], (* XXX Augeas code needs tests. *)
 639    "move Augeas node",
 640    "\
 641 Move the node C<src> to C<dest>.  C<src> must match exactly
 642 one node.  C<dest> is overwritten if it exists.");
 643
 644   ("aug_match", (RStringList "matches", [String "path"]), 24, [],
 645    [], (* XXX Augeas code needs tests. *)
 646    "return Augeas nodes which match path",
 647    "\
 648 Returns a list of paths which match the path expression C<path>.
 649 The returned paths are sufficiently qualified so that they match
 650 exactly one node in the current tree.");
 651
 652   ("aug_save", (RErr, []), 25, [],
 653    [], (* XXX Augeas code needs tests. *)
 654    "write all pending Augeas changes to disk",
 655    "\
 656 This writes all pending changes to disk.
 657
 658 The flags which were passed to C<guestfs_aug_init> affect exactly
 659 how files are saved.");
 660
 661   ("aug_load", (RErr, []), 27, [],
 662    [], (* XXX Augeas code needs tests. *)
 663    "load files into the tree",
 664    "\
 665 Load files into the tree.
 666
 667 See C<aug_load> in the Augeas documentation for the full gory
 668 details.");
 669
 670   ("aug_ls", (RStringList "matches", [String "path"]), 28, [],
 671    [], (* XXX Augeas code needs tests. *)
 672    "list Augeas nodes under a path",
 673    "\
 674 This is just a shortcut for listing C<guestfs_aug_match>
 675 C<path/*> and sorting the resulting nodes into alphabetical order.");
 676
 677   ("rm", (RErr, [String "path"]), 29, [],
 678    [TestRun (
 679       InitEmpty,
 680       [["touch"; "/new"];
 681        ["rm"; "/new"]]);
 682     TestLastFail (
 683       InitEmpty,
 684       [["rm"; "/new"]]);
 685     TestLastFail (
 686       InitEmpty,
 687       [["mkdir"; "/new"];
 688        ["rm"; "/new"]])],
 689    "remove a file",
 690    "\
 691 Remove the single file C<path>.");
 692
 693   ("rmdir", (RErr, [String "path"]), 30, [],
 694    [TestRun (
 695       InitEmpty,
 696       [["mkdir"; "/new"];
 697        ["rmdir"; "/new"]]);
 698     TestLastFail (
 699       InitEmpty,
 700       [["rmdir"; "/new"]]);
 701     TestLastFail (
 702       InitEmpty,
 703       [["touch"; "/new"];
 704        ["rmdir"; "/new"]])],
 705    "remove a directory",
 706    "\
 707 Remove the single directory C<path>.");
 708
 709   ("rm_rf", (RErr, [String "path"]), 31, [],
 710    [TestOutputFalse (
 711       InitEmpty,
 712       [["mkdir"; "/new"];
 713        ["mkdir"; "/new/foo"];
 714        ["touch"; "/new/foo/bar"];
 715        ["rm_rf"; "/new"];
 716        ["exists"; "/new"]])],
 717    "remove a file or directory recursively",
 718    "\
 719 Remove the file or directory C<path>, recursively removing the
 720 contents if its a directory.  This is like the C<rm -rf> shell
 721 command.");
 722
 723   ("mkdir", (RErr, [String "path"]), 32, [],
 724    [TestOutputTrue (
 725       InitEmpty,
 726       [["mkdir"; "/new"];
 727        ["is_dir"; "/new"]])],
 728    "create a directory",
 729    "\
 730 Create a directory named C<path>.");
 731
 732   ("mkdir_p", (RErr, [String "path"]), 33, [],
 733    [TestOutputTrue (
 734       InitEmpty,
 735       [["mkdir_p"; "/new/foo/bar"];
 736        ["is_dir"; "/new/foo/bar"]]);
 737     TestOutputTrue (
 738       InitEmpty,
 739       [["mkdir_p"; "/new/foo/bar"];
 740        ["is_dir"; "/new/foo"]]);
 741     TestOutputTrue (
 742       InitEmpty,
 743       [["mkdir_p"; "/new/foo/bar"];
 744        ["is_dir"; "/new"]])],
 745    "create a directory and parents",
 746    "\
 747 Create a directory named C<path>, creating any parent directories
 748 as necessary.  This is like the C<mkdir -p> shell command.");
 749
 750   ("chmod", (RErr, [Int "mode"; String "path"]), 34, [],
 751    [], (* XXX Need stat command to test *)
 752    "change file mode",
 753    "\
 754 Change the mode (permissions) of C<path> to C<mode>.  Only
 755 numeric modes are supported.");
 756
 757   ("chown", (RErr, [Int "owner"; Int "group"; String "path"]), 35, [],
 758    [], (* XXX Need stat command to test *)
 759    "change file owner and group",
 760    "\
 761 Change the file owner to C<owner> and group to C<group>.
 762
 763 Only numeric uid and gid are supported.  If you want to use
 764 names, you will need to locate and parse the password file
 765 yourself (Augeas support makes this relatively easy).");
 766 ]
 767
 768 let all_functions = non_daemon_functions @ daemon_functions
 769
 770 (* In some places we want the functions to be displayed sorted
 771  * alphabetically, so this is useful:
 772  *)
 773 let all_functions_sorted =
 774   List.sort (fun (n1,_,_,_,_,_,_) (n2,_,_,_,_,_,_) ->
 775                compare n1 n2) all_functions
 776
 777 (* Column names and types from LVM PVs/VGs/LVs. *)
 778 let pv_cols = [
 779   "pv_name", `String;
 780   "pv_uuid", `UUID;
 781   "pv_fmt", `String;
 782   "pv_size", `Bytes;
 783   "dev_size", `Bytes;
 784   "pv_free", `Bytes;
 785   "pv_used", `Bytes;
 786   "pv_attr", `String (* XXX *);
 787   "pv_pe_count", `Int;
 788   "pv_pe_alloc_count", `Int;
 789   "pv_tags", `String;
 790   "pe_start", `Bytes;
 791   "pv_mda_count", `Int;
 792   "pv_mda_free", `Bytes;
 793 (* Not in Fedora 10:
 794   "pv_mda_size", `Bytes;
 795 *)
 796 ]
 797 let vg_cols = [
 798   "vg_name", `String;
 799   "vg_uuid", `UUID;
 800   "vg_fmt", `String;
 801   "vg_attr", `String (* XXX *);
 802   "vg_size", `Bytes;
 803   "vg_free", `Bytes;
 804   "vg_sysid", `String;
 805   "vg_extent_size", `Bytes;
 806   "vg_extent_count", `Int;
 807   "vg_free_count", `Int;
 808   "max_lv", `Int;
 809   "max_pv", `Int;
 810   "pv_count", `Int;
 811   "lv_count", `Int;
 812   "snap_count", `Int;
 813   "vg_seqno", `Int;
 814   "vg_tags", `String;
 815   "vg_mda_count", `Int;
 816   "vg_mda_free", `Bytes;
 817 (* Not in Fedora 10:
 818   "vg_mda_size", `Bytes;
 819 *)
 820 ]
 821 let lv_cols = [
 822   "lv_name", `String;
 823   "lv_uuid", `UUID;
 824   "lv_attr", `String (* XXX *);
 825   "lv_major", `Int;
 826   "lv_minor", `Int;
 827   "lv_kernel_major", `Int;
 828   "lv_kernel_minor", `Int;
 829   "lv_size", `Bytes;
 830   "seg_count", `Int;
 831   "origin", `String;
 832   "snap_percent", `OptPercent;
 833   "copy_percent", `OptPercent;
 834   "move_pv", `String;
 835   "lv_tags", `String;
 836   "mirror_log", `String;
 837   "modules", `String;
 838 ]
 839
 840 (* Useful functions.
 841  * Note we don't want to use any external OCaml libraries which
 842  * makes this a bit harder than it should be.
 843  *)
 844 let failwithf fs = ksprintf failwith fs
 845
 846 let replace_char s c1 c2 =
 847   let s2 = String.copy s in
 848   let r = ref false in
 849   for i = 0 to String.length s2 - 1 do
 850     if String.unsafe_get s2 i = c1 then (
 851       String.unsafe_set s2 i c2;
 852       r := true
 853     )
 854   done;
 855   if not !r then s else s2
 856
 857 let rec find s sub =
 858   let len = String.length s in
 859   let sublen = String.length sub in
 860   let rec loop i =
 861     if i <= len-sublen then (
 862       let rec loop2 j =
 863         if j < sublen then (
 864           if s.[i+j] = sub.[j] then loop2 (j+1)
 865           else -1
 866         ) else
 867           i (* found *)
 868       in
 869       let r = loop2 0 in
 870       if r = -1 then loop (i+1) else r
 871     ) else
 872       -1 (* not found *)
 873   in
 874   loop 0
 875
 876 let rec replace_str s s1 s2 =
 877   let len = String.length s in
 878   let sublen = String.length s1 in
 879   let i = find s s1 in
 880   if i = -1 then s
 881   else (
 882     let s' = String.sub s 0 i in
 883     let s'' = String.sub s (i+sublen) (len-i-sublen) in
 884     s' ^ s2 ^ replace_str s'' s1 s2
 885   )
 886
 887 let rec find_map f = function
 888   | [] -> raise Not_found
 889   | x :: xs ->
 890       match f x with
 891       | Some y -> y
 892       | None -> find_map f xs
 893
 894 let iteri f xs =
 895   let rec loop i = function
 896     | [] -> ()
 897     | x :: xs -> f i x; loop (i+1) xs
 898   in
 899   loop 0 xs
 900
 901 let name_of_argt = function String n | OptString n | Bool n | Int n -> n
 902
 903 (* Check function names etc. for consistency. *)
 904 let check_functions () =
 905   let contains_uppercase str =
 906     let len = String.length str in
 907     let rec loop i =
 908       if i >= len then false
 909       else (
 910         let c = str.[i] in
 911         if c >= 'A' && c <= 'Z' then true
 912         else loop (i+1)
 913       )
 914     in
 915     loop 0
 916   in
 917
 918   (* Check function names. *)
 919   List.iter (
 920     fun (name, _, _, _, _, _, _) ->
 921       if String.length name >= 7 && String.sub name 0 7 = "guestfs" then
 922         failwithf "function name %s does not need 'guestfs' prefix" name;
 923       if contains_uppercase name then
 924         failwithf "function name %s should not contain uppercase chars" name;
 925       if String.contains name '-' then
 926         failwithf "function name %s should not contain '-', use '_' instead."
 927           name
 928   ) all_functions;
 929
 930   (* Check function parameter/return names. *)
 931   List.iter (
 932     fun (name, style, _, _, _, _, _) ->
 933       let check_arg_ret_name n =
 934         if contains_uppercase n then
 935           failwithf "%s param/ret %s should not contain uppercase chars"
 936             name n;
 937         if String.contains n '-' || String.contains n '_' then
 938           failwithf "%s param/ret %s should not contain '-' or '_'"
 939             name n;
 940         if n = "value" then
 941           failwithf "%s has a param/ret called 'value', which causes conflicts in the OCaml bindings, use something like 'val' or a more descriptive name" n
 942       in
 943
 944       (match fst style with
 945        | RErr -> ()
 946        | RInt n | RBool n | RConstString n | RString n
 947        | RStringList n | RPVList n | RVGList n | RLVList n ->
 948            check_arg_ret_name n
 949        | RIntBool (n,m) ->
 950            check_arg_ret_name n;
 951            check_arg_ret_name m
 952       );
 953       List.iter (fun arg -> check_arg_ret_name (name_of_argt arg)) (snd style)
 954   ) all_functions;
 955
 956   (* Check long dscriptions. *)
 957   List.iter (
 958     fun (name, _, _, _, _, _, longdesc) ->
 959       if longdesc.[String.length longdesc-1] = '\n' then
 960         failwithf "long description of %s should not end with \\n." name
 961   ) all_functions;
 962
 963   (* Check proc_nrs. *)
 964   List.iter (
 965     fun (name, _, proc_nr, _, _, _, _) ->
 966       if proc_nr <= 0 then
 967         failwithf "daemon function %s should have proc_nr > 0" name
 968   ) daemon_functions;
 969
 970   List.iter (
 971     fun (name, _, proc_nr, _, _, _, _) ->
 972       if proc_nr <> -1 then
 973         failwithf "non-daemon function %s should have proc_nr -1" name
 974   ) non_daemon_functions;
 975
 976   let proc_nrs =
 977     List.map (fun (name, _, proc_nr, _, _, _, _) -> name, proc_nr)
 978       daemon_functions in
 979   let proc_nrs =
 980     List.sort (fun (_,nr1) (_,nr2) -> compare nr1 nr2) proc_nrs in
 981   let rec loop = function
 982     | [] -> ()
 983     | [_] -> ()
 984     | (name1,nr1) :: ((name2,nr2) :: _ as rest) when nr1 < nr2 ->
 985         loop rest
 986     | (name1,nr1) :: (name2,nr2) :: _ ->
 987         failwithf "%s and %s have conflicting procedure numbers (%d, %d)"
 988           name1 name2 nr1 nr2
 989   in
 990   loop proc_nrs
 991
 992 (* 'pr' prints to the current output file. *)
 993 let chan = ref stdout
 994 let pr fs = ksprintf (output_string !chan) fs
 995
 996 (* Generate a header block in a number of standard styles. *)
 997 type comment_style = CStyle | HashStyle | OCamlStyle
 998 type license = GPLv2 | LGPLv2
 999
1000 let generate_header comment license =
1001   let c = match comment with
1002     | CStyle ->     pr "/* "; " *"
1003     | HashStyle ->  pr "# ";  "#"
1004     | OCamlStyle -> pr "(* "; " *" in
1005   pr "libguestfs generated file\n";
1006   pr "%s WARNING: THIS FILE IS GENERATED BY 'src/generator.ml'.\n" c;
1007   pr "%s ANY CHANGES YOU MAKE TO THIS FILE WILL BE LOST.\n" c;
1008   pr "%s\n" c;
1009   pr "%s Copyright (C) 2009 Red Hat Inc.\n" c;
1010   pr "%s\n" c;
1011   (match license with
1012    | GPLv2 ->
1013        pr "%s This program is free software; you can redistribute it and/or modify\n" c;
1014        pr "%s it under the terms of the GNU General Public License as published by\n" c;
1015        pr "%s the Free Software Foundation; either version 2 of the License, or\n" c;
1016        pr "%s (at your option) any later version.\n" c;
1017        pr "%s\n" c;
1018        pr "%s This program is distributed in the hope that it will be useful,\n" c;
1019        pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
1020        pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the\n" c;
1021        pr "%s GNU General Public License for more details.\n" c;
1022        pr "%s\n" c;
1023        pr "%s You should have received a copy of the GNU General Public License along\n" c;
1024        pr "%s with this program; if not, write to the Free Software Foundation, Inc.,\n" c;
1025        pr "%s 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n" c;
1026
1027    | LGPLv2 ->
1028        pr "%s This library is free software; you can redistribute it and/or\n" c;
1029        pr "%s modify it under the terms of the GNU Lesser General Public\n" c;
1030        pr "%s License as published by the Free Software Foundation; either\n" c;
1031        pr "%s version 2 of the License, or (at your option) any later version.\n" c;
1032        pr "%s\n" c;
1033        pr "%s This library is distributed in the hope that it will be useful,\n" c;
1034        pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
1035        pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU\n" c;
1036        pr "%s Lesser General Public License for more details.\n" c;
1037        pr "%s\n" c;
1038        pr "%s You should have received a copy of the GNU Lesser General Public\n" c;
1039        pr "%s License along with this library; if not, write to the Free Software\n" c;
1040        pr "%s Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA\n" c;
1041   );
1042   (match comment with
1043    | CStyle -> pr " */\n"
1044    | HashStyle -> ()
1045    | OCamlStyle -> pr " *)\n"
1046   );
1047   pr "\n"
1048
1049 (* Start of main code generation functions below this line. *)
1050
1051 (* Generate the pod documentation for the C API. *)
1052 let rec generate_actions_pod () =
1053   List.iter (
1054     fun (shortname, style, _, flags, _, _, longdesc) ->
1055       let name = "guestfs_" ^ shortname in
1056       pr "=head2 %s\n\n" name;
1057       pr " ";
1058       generate_prototype ~extern:false ~handle:"handle" name style;
1059       pr "\n\n";
1060       pr "%s\n\n" longdesc;
1061       (match fst style with
1062        | RErr ->
1063            pr "This function returns 0 on success or -1 on error.\n\n"
1064        | RInt _ ->
1065            pr "On error this function returns -1.\n\n"
1066        | RBool _ ->
1067            pr "This function returns a C truth value on success or -1 on error.\n\n"
1068        | RConstString _ ->
1069            pr "This function returns a string or NULL on error.
1070 The string is owned by the guest handle and must I<not> be freed.\n\n"
1071        | RString _ ->
1072            pr "This function returns a string or NULL on error.
1073 I<The caller must free the returned string after use>.\n\n"
1074        | RStringList _ ->
1075            pr "This function returns a NULL-terminated array of strings
1076 (like L<environ(3)>), or NULL if there was an error.
1077 I<The caller must free the strings and the array after use>.\n\n"
1078        | RIntBool _ ->
1079            pr "This function returns a C<struct guestfs_int_bool *>.
1080 I<The caller must call C<guestfs_free_int_bool> after use>.\n\n"
1081        | RPVList _ ->
1082            pr "This function returns a C<struct guestfs_lvm_pv_list *>.
1083 I<The caller must call C<guestfs_free_lvm_pv_list> after use>.\n\n"
1084        | RVGList _ ->
1085            pr "This function returns a C<struct guestfs_lvm_vg_list *>.
1086 I<The caller must call C<guestfs_free_lvm_vg_list> after use>.\n\n"
1087        | RLVList _ ->
1088            pr "This function returns a C<struct guestfs_lvm_lv_list *>.
1089 I<The caller must call C<guestfs_free_lvm_lv_list> after use>.\n\n"
1090       );
1091       if List.mem ProtocolLimitWarning flags then
1092         pr "Because of the message protocol, there is a transfer limit
1093 of somewhere between 2MB and 4MB.  To transfer large files you should use
1094 FTP.\n\n";
1095   ) all_functions_sorted
1096
1097 and generate_structs_pod () =
1098   (* LVM structs documentation. *)
1099   List.iter (
1100     fun (typ, cols) ->
1101       pr "=head2 guestfs_lvm_%s\n" typ;
1102       pr "\n";
1103       pr " struct guestfs_lvm_%s {\n" typ;
1104       List.iter (
1105         function
1106         | name, `String -> pr "  char *%s;\n" name
1107         | name, `UUID ->
1108             pr "  /* The next field is NOT nul-terminated, be careful when printing it: */\n";
1109             pr "  char %s[32];\n" name
1110         | name, `Bytes -> pr "  uint64_t %s;\n" name
1111         | name, `Int -> pr "  int64_t %s;\n" name
1112         | name, `OptPercent ->
1113             pr "  /* The next field is [0..100] or -1 meaning 'not present': */\n";
1114             pr "  float %s;\n" name
1115       ) cols;
1116       pr " \n";
1117       pr " struct guestfs_lvm_%s_list {\n" typ;
1118       pr "   uint32_t len; /* Number of elements in list. */\n";
1119       pr "   struct guestfs_lvm_%s *val; /* Elements. */\n" typ;
1120       pr " };\n";
1121       pr " \n";
1122       pr " void guestfs_free_lvm_%s_list (struct guestfs_free_lvm_%s_list *);\n"
1123         typ typ;
1124       pr "\n"
1125   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols]
1126
1127 (* Generate the protocol (XDR) file, 'guestfs_protocol.x' and
1128  * indirectly 'guestfs_protocol.h' and 'guestfs_protocol.c'.
1129  *
1130  * We have to use an underscore instead of a dash because otherwise
1131  * rpcgen generates incorrect code.
1132  *
1133  * This header is NOT exported to clients, but see also generate_structs_h.
1134  *)
1135 and generate_xdr () =
1136   generate_header CStyle LGPLv2;
1137
1138   (* This has to be defined to get around a limitation in Sun's rpcgen. *)
1139   pr "typedef string str<>;\n";
1140   pr "\n";
1141
1142   (* LVM internal structures. *)
1143   List.iter (
1144     function
1145     | typ, cols ->
1146         pr "struct guestfs_lvm_int_%s {\n" typ;
1147         List.iter (function
1148                    | name, `String -> pr "  string %s<>;\n" name
1149                    | name, `UUID -> pr "  opaque %s[32];\n" name
1150                    | name, `Bytes -> pr "  hyper %s;\n" name
1151                    | name, `Int -> pr "  hyper %s;\n" name
1152                    | name, `OptPercent -> pr "  float %s;\n" name
1153                   ) cols;
1154         pr "};\n";
1155         pr "\n";
1156         pr "typedef struct guestfs_lvm_int_%s guestfs_lvm_int_%s_list<>;\n" typ typ;
1157         pr "\n";
1158   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols];
1159
1160   List.iter (
1161     fun (shortname, style, _, _, _, _, _) ->
1162       let name = "guestfs_" ^ shortname in
1163
1164       (match snd style with
1165        | [] -> ()
1166        | args ->
1167            pr "struct %s_args {\n" name;
1168            List.iter (
1169              function
1170              | String n -> pr "  string %s<>;\n" n
1171              | OptString n -> pr "  str *%s;\n" n
1172              | Bool n -> pr "  bool %s;\n" n
1173              | Int n -> pr "  int %s;\n" n
1174            ) args;
1175            pr "};\n\n"
1176       );
1177       (match fst style with
1178        | RErr -> ()
1179        | RInt n ->
1180            pr "struct %s_ret {\n" name;
1181            pr "  int %s;\n" n;
1182            pr "};\n\n"
1183        | RBool n ->
1184            pr "struct %s_ret {\n" name;
1185            pr "  bool %s;\n" n;
1186            pr "};\n\n"
1187        | RConstString _ ->
1188            failwithf "RConstString cannot be returned from a daemon function"
1189        | RString n ->
1190            pr "struct %s_ret {\n" name;
1191            pr "  string %s<>;\n" n;
1192            pr "};\n\n"
1193        | RStringList n ->
1194            pr "struct %s_ret {\n" name;
1195            pr "  str %s<>;\n" n;
1196            pr "};\n\n"
1197        | RIntBool (n,m) ->
1198            pr "struct %s_ret {\n" name;
1199            pr "  int %s;\n" n;
1200            pr "  bool %s;\n" m;
1201            pr "};\n\n"
1202        | RPVList n ->
1203            pr "struct %s_ret {\n" name;
1204            pr "  guestfs_lvm_int_pv_list %s;\n" n;
1205            pr "};\n\n"
1206        | RVGList n ->
1207            pr "struct %s_ret {\n" name;
1208            pr "  guestfs_lvm_int_vg_list %s;\n" n;
1209            pr "};\n\n"
1210        | RLVList n ->
1211            pr "struct %s_ret {\n" name;
1212            pr "  guestfs_lvm_int_lv_list %s;\n" n;
1213            pr "};\n\n"
1214       );
1215   ) daemon_functions;
1216
1217   (* Table of procedure numbers. *)
1218   pr "enum guestfs_procedure {\n";
1219   List.iter (
1220     fun (shortname, _, proc_nr, _, _, _, _) ->
1221       pr "  GUESTFS_PROC_%s = %d,\n" (String.uppercase shortname) proc_nr
1222   ) daemon_functions;
1223   pr "  GUESTFS_PROC_dummy\n"; (* so we don't have a "hanging comma" *)
1224   pr "};\n";
1225   pr "\n";
1226
1227   (* Having to choose a maximum message size is annoying for several
1228    * reasons (it limits what we can do in the API), but it (a) makes
1229    * the protocol a lot simpler, and (b) provides a bound on the size
1230    * of the daemon which operates in limited memory space.  For large
1231    * file transfers you should use FTP.
1232    *)
1233   pr "const GUESTFS_MESSAGE_MAX = %d;\n" (4 * 1024 * 1024);
1234   pr "\n";
1235
1236   (* Message header, etc. *)
1237   pr "\
1238 const GUESTFS_PROGRAM = 0x2000F5F5;
1239 const GUESTFS_PROTOCOL_VERSION = 1;
1240
1241 enum guestfs_message_direction {
1242   GUESTFS_DIRECTION_CALL = 0,        /* client -> daemon */
1243   GUESTFS_DIRECTION_REPLY = 1        /* daemon -> client */
1244 };
1245
1246 enum guestfs_message_status {
1247   GUESTFS_STATUS_OK = 0,
1248   GUESTFS_STATUS_ERROR = 1
1249 };
1250
1251 const GUESTFS_ERROR_LEN = 256;
1252
1253 struct guestfs_message_error {
1254   string error<GUESTFS_ERROR_LEN>;   /* error message */
1255 };
1256
1257 struct guestfs_message_header {
1258   unsigned prog;                     /* GUESTFS_PROGRAM */
1259   unsigned vers;                     /* GUESTFS_PROTOCOL_VERSION */
1260   guestfs_procedure proc;            /* GUESTFS_PROC_x */
1261   guestfs_message_direction direction;
1262   unsigned serial;                   /* message serial number */
1263   guestfs_message_status status;
1264 };
1265 "
1266
1267 (* Generate the guestfs-structs.h file. *)
1268 and generate_structs_h () =
1269   generate_header CStyle LGPLv2;
1270
1271   (* This is a public exported header file containing various
1272    * structures.  The structures are carefully written to have
1273    * exactly the same in-memory format as the XDR structures that
1274    * we use on the wire to the daemon.  The reason for creating
1275    * copies of these structures here is just so we don't have to
1276    * export the whole of guestfs_protocol.h (which includes much
1277    * unrelated and XDR-dependent stuff that we don't want to be
1278    * public, or required by clients).
1279    *
1280    * To reiterate, we will pass these structures to and from the
1281    * client with a simple assignment or memcpy, so the format
1282    * must be identical to what rpcgen / the RFC defines.
1283    *)
1284
1285   (* guestfs_int_bool structure. *)
1286   pr "struct guestfs_int_bool {\n";
1287   pr "  int32_t i;\n";
1288   pr "  int32_t b;\n";
1289   pr "};\n";
1290   pr "\n";
1291
1292   (* LVM public structures. *)
1293   List.iter (
1294     function
1295     | typ, cols ->
1296         pr "struct guestfs_lvm_%s {\n" typ;
1297         List.iter (
1298           function
1299           | name, `String -> pr "  char *%s;\n" name
1300           | name, `UUID -> pr "  char %s[32]; /* this is NOT nul-terminated, be careful when printing */\n" name
1301           | name, `Bytes -> pr "  uint64_t %s;\n" name
1302           | name, `Int -> pr "  int64_t %s;\n" name
1303           | name, `OptPercent -> pr "  float %s; /* [0..100] or -1 */\n" name
1304         ) cols;
1305         pr "};\n";
1306         pr "\n";
1307         pr "struct guestfs_lvm_%s_list {\n" typ;
1308         pr "  uint32_t len;\n";
1309         pr "  struct guestfs_lvm_%s *val;\n" typ;
1310         pr "};\n";
1311         pr "\n"
1312   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols]
1313
1314 (* Generate the guestfs-actions.h file. *)
1315 and generate_actions_h () =
1316   generate_header CStyle LGPLv2;
1317   List.iter (
1318     fun (shortname, style, _, _, _, _, _) ->
1319       let name = "guestfs_" ^ shortname in
1320       generate_prototype ~single_line:true ~newline:true ~handle:"handle"
1321         name style
1322   ) all_functions
1323
1324 (* Generate the client-side dispatch stubs. *)
1325 and generate_client_actions () =
1326   generate_header CStyle LGPLv2;
1327
1328   (* Client-side stubs for each function. *)
1329   List.iter (
1330     fun (shortname, style, _, _, _, _, _) ->
1331       let name = "guestfs_" ^ shortname in
1332
1333       (* Generate the return value struct. *)
1334       pr "struct %s_rv {\n" shortname;
1335       pr "  int cb_done;  /* flag to indicate callback was called */\n";
1336       pr "  struct guestfs_message_header hdr;\n";
1337       pr "  struct guestfs_message_error err;\n";
1338       (match fst style with
1339        | RErr -> ()
1340        | RConstString _ ->
1341            failwithf "RConstString cannot be returned from a daemon function"
1342        | RInt _
1343        | RBool _ | RString _ | RStringList _
1344        | RIntBool _
1345        | RPVList _ | RVGList _ | RLVList _ ->
1346            pr "  struct %s_ret ret;\n" name
1347       );
1348       pr "};\n\n";
1349
1350       (* Generate the callback function. *)
1351       pr "static void %s_cb (guestfs_h *g, void *data, XDR *xdr)\n" shortname;
1352       pr "{\n";
1353       pr "  struct %s_rv *rv = (struct %s_rv *) data;\n" shortname shortname;
1354       pr "\n";
1355       pr "  if (!xdr_guestfs_message_header (xdr, &rv->hdr)) {\n";
1356       pr "    error (g, \"%s: failed to parse reply header\");\n" name;
1357       pr "    return;\n";
1358       pr "  }\n";
1359       pr "  if (rv->hdr.status == GUESTFS_STATUS_ERROR) {\n";
1360       pr "    if (!xdr_guestfs_message_error (xdr, &rv->err)) {\n";
1361       pr "      error (g, \"%s: failed to parse reply error\");\n" name;
1362       pr "      return;\n";
1363       pr "    }\n";
1364       pr "    goto done;\n";
1365       pr "  }\n";
1366
1367       (match fst style with
1368        | RErr -> ()
1369        | RConstString _ ->
1370            failwithf "RConstString cannot be returned from a daemon function"
1371        | RInt _
1372        | RBool _ | RString _ | RStringList _
1373        | RIntBool _
1374        | RPVList _ | RVGList _ | RLVList _ ->
1375             pr "  if (!xdr_%s_ret (xdr, &rv->ret)) {\n" name;
1376             pr "    error (g, \"%s: failed to parse reply\");\n" name;
1377             pr "    return;\n";
1378             pr "  }\n";
1379       );
1380
1381       pr " done:\n";
1382       pr "  rv->cb_done = 1;\n";
1383       pr "  main_loop.main_loop_quit (g);\n";
1384       pr "}\n\n";
1385
1386       (* Generate the action stub. *)
1387       generate_prototype ~extern:false ~semicolon:false ~newline:true
1388         ~handle:"g" name style;
1389
1390       let error_code =
1391         match fst style with
1392         | RErr | RInt _ | RBool _ -> "-1"
1393         | RConstString _ ->
1394             failwithf "RConstString cannot be returned from a daemon function"
1395         | RString _ | RStringList _ | RIntBool _
1396         | RPVList _ | RVGList _ | RLVList _ ->
1397             "NULL" in
1398
1399       pr "{\n";
1400
1401       (match snd style with
1402        | [] -> ()
1403        | _ -> pr "  struct %s_args args;\n" name
1404       );
1405
1406       pr "  struct %s_rv rv;\n" shortname;
1407       pr "  int serial;\n";
1408       pr "\n";
1409       pr "  if (g->state != READY) {\n";
1410       pr "    error (g, \"%s called from the wrong state, %%d != READY\",\n"
1411         name;
1412       pr "      g->state);\n";
1413       pr "    return %s;\n" error_code;
1414       pr "  }\n";
1415       pr "\n";
1416       pr "  memset (&rv, 0, sizeof rv);\n";
1417       pr "\n";
1418
1419       (match snd style with
1420        | [] ->
1421            pr "  serial = dispatch (g, GUESTFS_PROC_%s, NULL, NULL);\n"
1422              (String.uppercase shortname)
1423        | args ->
1424            List.iter (
1425              function
1426              | String n ->
1427                  pr "  args.%s = (char *) %s;\n" n n
1428              | OptString n ->
1429                  pr "  args.%s = %s ? (char **) &%s : NULL;\n" n n n
1430              | Bool n ->
1431                  pr "  args.%s = %s;\n" n n
1432              | Int n ->
1433                  pr "  args.%s = %s;\n" n n
1434            ) args;
1435            pr "  serial = dispatch (g, GUESTFS_PROC_%s,\n"
1436              (String.uppercase shortname);
1437            pr "                     (xdrproc_t) xdr_%s_args, (char *) &args);\n"
1438              name;
1439       );
1440       pr "  if (serial == -1)\n";
1441       pr "    return %s;\n" error_code;
1442       pr "\n";
1443
1444       pr "  rv.cb_done = 0;\n";
1445       pr "  g->reply_cb_internal = %s_cb;\n" shortname;
1446       pr "  g->reply_cb_internal_data = &rv;\n";
1447       pr "  main_loop.main_loop_run (g);\n";
1448       pr "  g->reply_cb_internal = NULL;\n";
1449       pr "  g->reply_cb_internal_data = NULL;\n";
1450       pr "  if (!rv.cb_done) {\n";
1451       pr "    error (g, \"%s failed, see earlier error messages\");\n" name;
1452       pr "    return %s;\n" error_code;
1453       pr "  }\n";
1454       pr "\n";
1455
1456       pr "  if (check_reply_header (g, &rv.hdr, GUESTFS_PROC_%s, serial) == -1)\n"
1457         (String.uppercase shortname);
1458       pr "    return %s;\n" error_code;
1459       pr "\n";
1460
1461       pr "  if (rv.hdr.status == GUESTFS_STATUS_ERROR) {\n";
1462       pr "    error (g, \"%%s\", rv.err.error);\n";
1463       pr "    return %s;\n" error_code;
1464       pr "  }\n";
1465       pr "\n";
1466
1467       (match fst style with
1468        | RErr -> pr "  return 0;\n"
1469        | RInt n
1470        | RBool n -> pr "  return rv.ret.%s;\n" n
1471        | RConstString _ ->
1472            failwithf "RConstString cannot be returned from a daemon function"
1473        | RString n ->
1474            pr "  return rv.ret.%s; /* caller will free */\n" n
1475        | RStringList n ->
1476            pr "  /* caller will free this, but we need to add a NULL entry */\n";
1477            pr "  rv.ret.%s.%s_val =" n n;
1478            pr "    safe_realloc (g, rv.ret.%s.%s_val,\n" n n;
1479            pr "                  sizeof (char *) * (rv.ret.%s.%s_len + 1));\n"
1480              n n;
1481            pr "  rv.ret.%s.%s_val[rv.ret.%s.%s_len] = NULL;\n" n n n n;
1482            pr "  return rv.ret.%s.%s_val;\n" n n
1483        | RIntBool _ ->
1484            pr "  /* caller with free this */\n";
1485            pr "  return safe_memdup (g, &rv.ret, sizeof (rv.ret));\n"
1486        | RPVList n ->
1487            pr "  /* caller will free this */\n";
1488            pr "  return safe_memdup (g, &rv.ret.%s, sizeof (rv.ret.%s));\n" n n
1489        | RVGList n ->
1490            pr "  /* caller will free this */\n";
1491            pr "  return safe_memdup (g, &rv.ret.%s, sizeof (rv.ret.%s));\n" n n
1492        | RLVList n ->
1493            pr "  /* caller will free this */\n";
1494            pr "  return safe_memdup (g, &rv.ret.%s, sizeof (rv.ret.%s));\n" n n
1495       );
1496
1497       pr "}\n\n"
1498   ) daemon_functions
1499
1500 (* Generate daemon/actions.h. *)
1501 and generate_daemon_actions_h () =
1502   generate_header CStyle GPLv2;
1503
1504   pr "#include \"../src/guestfs_protocol.h\"\n";
1505   pr "\n";
1506
1507   List.iter (
1508     fun (name, style, _, _, _, _, _) ->
1509         generate_prototype
1510           ~single_line:true ~newline:true ~in_daemon:true ~prefix:"do_"
1511           name style;
1512   ) daemon_functions
1513
1514 (* Generate the server-side stubs. *)
1515 and generate_daemon_actions () =
1516   generate_header CStyle GPLv2;
1517
1518   pr "#define _GNU_SOURCE // for strchrnul\n";
1519   pr "\n";
1520   pr "#include <stdio.h>\n";
1521   pr "#include <stdlib.h>\n";
1522   pr "#include <string.h>\n";
1523   pr "#include <inttypes.h>\n";
1524   pr "#include <ctype.h>\n";
1525   pr "#include <rpc/types.h>\n";
1526   pr "#include <rpc/xdr.h>\n";
1527   pr "\n";
1528   pr "#include \"daemon.h\"\n";
1529   pr "#include \"../src/guestfs_protocol.h\"\n";
1530   pr "#include \"actions.h\"\n";
1531   pr "\n";
1532
1533   List.iter (
1534     fun (name, style, _, _, _, _, _) ->
1535       (* Generate server-side stubs. *)
1536       pr "static void %s_stub (XDR *xdr_in)\n" name;
1537       pr "{\n";
1538       let error_code =
1539         match fst style with
1540         | RErr | RInt _ -> pr "  int r;\n"; "-1"
1541         | RBool _ -> pr "  int r;\n"; "-1"
1542         | RConstString _ ->
1543             failwithf "RConstString cannot be returned from a daemon function"
1544         | RString _ -> pr "  char *r;\n"; "NULL"
1545         | RStringList _ -> pr "  char **r;\n"; "NULL"
1546         | RIntBool _ -> pr "  guestfs_%s_ret *r;\n" name; "NULL"
1547         | RPVList _ -> pr "  guestfs_lvm_int_pv_list *r;\n"; "NULL"
1548         | RVGList _ -> pr "  guestfs_lvm_int_vg_list *r;\n"; "NULL"
1549         | RLVList _ -> pr "  guestfs_lvm_int_lv_list *r;\n"; "NULL" in
1550
1551       (match snd style with
1552        | [] -> ()
1553        | args ->
1554            pr "  struct guestfs_%s_args args;\n" name;
1555            List.iter (
1556              function
1557              | String n
1558              | OptString n -> pr "  const char *%s;\n" n
1559              | Bool n -> pr "  int %s;\n" n
1560              | Int n -> pr "  int %s;\n" n
1561            ) args
1562       );
1563       pr "\n";
1564
1565       (match snd style with
1566        | [] -> ()
1567        | args ->
1568            pr "  memset (&args, 0, sizeof args);\n";
1569            pr "\n";
1570            pr "  if (!xdr_guestfs_%s_args (xdr_in, &args)) {\n" name;
1571            pr "    reply_with_error (\"%%s: daemon failed to decode procedure arguments\", \"%s\");\n" name;
1572            pr "    return;\n";
1573            pr "  }\n";
1574            List.iter (
1575              function
1576              | String n -> pr "  %s = args.%s;\n" n n
1577              | OptString n -> pr "  %s = args.%s ? *args.%s : NULL;\n" n n n
1578              | Bool n -> pr "  %s = args.%s;\n" n n
1579              | Int n -> pr "  %s = args.%s;\n" n n
1580            ) args;
1581            pr "\n"
1582       );
1583
1584       pr "  r = do_%s " name;
1585       generate_call_args style;
1586       pr ";\n";
1587
1588       pr "  if (r == %s)\n" error_code;
1589       pr "    /* do_%s has already called reply_with_error, so just return */\n" name;
1590       pr "    return;\n";
1591       pr "\n";
1592
1593       (match fst style with
1594        | RErr -> pr "  reply (NULL, NULL);\n"
1595        | RInt n ->
1596            pr "  struct guestfs_%s_ret ret;\n" name;
1597            pr "  ret.%s = r;\n" n;
1598            pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name
1599        | RBool n ->
1600            pr "  struct guestfs_%s_ret ret;\n" name;
1601            pr "  ret.%s = r;\n" n;
1602            pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name
1603        | RConstString _ ->
1604            failwithf "RConstString cannot be returned from a daemon function"
1605        | RString n ->
1606            pr "  struct guestfs_%s_ret ret;\n" name;
1607            pr "  ret.%s = r;\n" n;
1608            pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name;
1609            pr "  free (r);\n"
1610        | RStringList n ->
1611            pr "  struct guestfs_%s_ret ret;\n" name;
1612            pr "  ret.%s.%s_len = count_strings (r);\n" n n;
1613            pr "  ret.%s.%s_val = r;\n" n n;
1614            pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name;
1615            pr "  free_strings (r);\n"
1616        | RIntBool _ ->
1617            pr "  reply ((xdrproc_t) xdr_guestfs_%s_ret, (char *) r);\n" name;
1618            pr "  xdr_free ((xdrproc_t) xdr_guestfs_%s_ret, (char *) r);\n" name
1619        | RPVList n ->
1620            pr "  struct guestfs_%s_ret ret;\n" name;
1621            pr "  ret.%s = *r;\n" n;
1622            pr "  reply ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n" name;
1623            pr "  xdr_free ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n" name
1624        | RVGList n ->
1625            pr "  struct guestfs_%s_ret ret;\n" name;
1626            pr "  ret.%s = *r;\n" n;
1627            pr "  reply ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n" name;
1628            pr "  xdr_free ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n" name
1629        | RLVList n ->
1630            pr "  struct guestfs_%s_ret ret;\n" name;
1631            pr "  ret.%s = *r;\n" n;
1632            pr "  reply ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n" name;
1633            pr "  xdr_free ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n" name
1634       );
1635
1636       pr "}\n\n";
1637   ) daemon_functions;
1638
1639   (* Dispatch function. *)
1640   pr "void dispatch_incoming_message (XDR *xdr_in)\n";
1641   pr "{\n";
1642   pr "  switch (proc_nr) {\n";
1643
1644   List.iter (
1645     fun (name, style, _, _, _, _, _) ->
1646         pr "    case GUESTFS_PROC_%s:\n" (String.uppercase name);
1647         pr "      %s_stub (xdr_in);\n" name;
1648         pr "      break;\n"
1649   ) daemon_functions;
1650
1651   pr "    default:\n";
1652   pr "      reply_with_error (\"dispatch_incoming_message: unknown procedure number %%d\", proc_nr);\n";
1653   pr "  }\n";
1654   pr "}\n";
1655   pr "\n";
1656
1657   (* LVM columns and tokenization functions. *)
1658   (* XXX This generates crap code.  We should rethink how we
1659    * do this parsing.
1660    *)
1661   List.iter (
1662     function
1663     | typ, cols ->
1664         pr "static const char *lvm_%s_cols = \"%s\";\n"
1665           typ (String.concat "," (List.map fst cols));
1666         pr "\n";
1667
1668         pr "static int lvm_tokenize_%s (char *str, struct guestfs_lvm_int_%s *r)\n" typ typ;
1669         pr "{\n";
1670         pr "  char *tok, *p, *next;\n";
1671         pr "  int i, j;\n";
1672         pr "\n";
1673         (*
1674         pr "  fprintf (stderr, \"%%s: <<%%s>>\\n\", __func__, str);\n";
1675         pr "\n";
1676         *)
1677         pr "  if (!str) {\n";
1678         pr "    fprintf (stderr, \"%%s: failed: passed a NULL string\\n\", __func__);\n";
1679         pr "    return -1;\n";
1680         pr "  }\n";
1681         pr "  if (!*str || isspace (*str)) {\n";
1682         pr "    fprintf (stderr, \"%%s: failed: passed a empty string or one beginning with whitespace\\n\", __func__);\n";
1683         pr "    return -1;\n";
1684         pr "  }\n";
1685         pr "  tok = str;\n";
1686         List.iter (
1687           fun (name, coltype) ->
1688             pr "  if (!tok) {\n";
1689             pr "    fprintf (stderr, \"%%s: failed: string finished early, around token %%s\\n\", __func__, \"%s\");\n" name;
1690             pr "    return -1;\n";
1691             pr "  }\n";
1692             pr "  p = strchrnul (tok, ',');\n";
1693             pr "  if (*p) next = p+1; else next = NULL;\n";
1694             pr "  *p = '\\0';\n";
1695             (match coltype with
1696              | `String ->
1697                  pr "  r->%s = strdup (tok);\n" name;
1698                  pr "  if (r->%s == NULL) {\n" name;
1699                  pr "    perror (\"strdup\");\n";
1700                  pr "    return -1;\n";
1701                  pr "  }\n"
1702              | `UUID ->
1703                  pr "  for (i = j = 0; i < 32; ++j) {\n";
1704                  pr "    if (tok[j] == '\\0') {\n";
1705                  pr "      fprintf (stderr, \"%%s: failed to parse UUID from '%%s'\\n\", __func__, tok);\n";
1706                  pr "      return -1;\n";
1707                  pr "    } else if (tok[j] != '-')\n";
1708                  pr "      r->%s[i++] = tok[j];\n" name;
1709                  pr "  }\n";
1710              | `Bytes ->
1711                  pr "  if (sscanf (tok, \"%%\"SCNu64, &r->%s) != 1) {\n" name;
1712                  pr "    fprintf (stderr, \"%%s: failed to parse size '%%s' from token %%s\\n\", __func__, tok, \"%s\");\n" name;
1713                  pr "    return -1;\n";
1714                  pr "  }\n";
1715              | `Int ->
1716                  pr "  if (sscanf (tok, \"%%\"SCNi64, &r->%s) != 1) {\n" name;
1717                  pr "    fprintf (stderr, \"%%s: failed to parse int '%%s' from token %%s\\n\", __func__, tok, \"%s\");\n" name;
1718                  pr "    return -1;\n";
1719                  pr "  }\n";
1720              | `OptPercent ->
1721                  pr "  if (tok[0] == '\\0')\n";
1722                  pr "    r->%s = -1;\n" name;
1723                  pr "  else if (sscanf (tok, \"%%f\", &r->%s) != 1) {\n" name;
1724                  pr "    fprintf (stderr, \"%%s: failed to parse float '%%s' from token %%s\\n\", __func__, tok, \"%s\");\n" name;
1725                  pr "    return -1;\n";
1726                  pr "  }\n";
1727             );
1728             pr "  tok = next;\n";
1729         ) cols;
1730
1731         pr "  if (tok != NULL) {\n";
1732         pr "    fprintf (stderr, \"%%s: failed: extra tokens at end of string\\n\", __func__);\n";
1733         pr "    return -1;\n";
1734         pr "  }\n";
1735         pr "  return 0;\n";
1736         pr "}\n";
1737         pr "\n";
1738
1739         pr "guestfs_lvm_int_%s_list *\n" typ;
1740         pr "parse_command_line_%ss (void)\n" typ;
1741         pr "{\n";
1742         pr "  char *out, *err;\n";
1743         pr "  char *p, *pend;\n";
1744         pr "  int r, i;\n";
1745         pr "  guestfs_lvm_int_%s_list *ret;\n" typ;
1746         pr "  void *newp;\n";
1747         pr "\n";
1748         pr "  ret = malloc (sizeof *ret);\n";
1749         pr "  if (!ret) {\n";
1750         pr "    reply_with_perror (\"malloc\");\n";
1751         pr "    return NULL;\n";
1752         pr "  }\n";
1753         pr "\n";
1754         pr "  ret->guestfs_lvm_int_%s_list_len = 0;\n" typ;
1755         pr "  ret->guestfs_lvm_int_%s_list_val = NULL;\n" typ;
1756         pr "\n";
1757         pr "  r = command (&out, &err,\n";
1758         pr "           \"/sbin/lvm\", \"%ss\",\n" typ;
1759         pr "           \"-o\", lvm_%s_cols, \"--unbuffered\", \"--noheadings\",\n" typ;
1760         pr "           \"--nosuffix\", \"--separator\", \",\", \"--units\", \"b\", NULL);\n";
1761         pr "  if (r == -1) {\n";
1762         pr "    reply_with_error (\"%%s\", err);\n";
1763         pr "    free (out);\n";
1764         pr "    free (err);\n";
1765         pr "    return NULL;\n";
1766         pr "  }\n";
1767         pr "\n";
1768         pr "  free (err);\n";
1769         pr "\n";
1770         pr "  /* Tokenize each line of the output. */\n";
1771         pr "  p = out;\n";
1772         pr "  i = 0;\n";
1773         pr "  while (p) {\n";
1774         pr "    pend = strchr (p, '\\n');       /* Get the next line of output. */\n";
1775         pr "    if (pend) {\n";
1776         pr "      *pend = '\\0';\n";
1777         pr "      pend++;\n";
1778         pr "    }\n";
1779         pr "\n";
1780         pr "    while (*p && isspace (*p))      /* Skip any leading whitespace. */\n";
1781         pr "      p++;\n";
1782         pr "\n";
1783         pr "    if (!*p) {                      /* Empty line?  Skip it. */\n";
1784         pr "      p = pend;\n";
1785         pr "      continue;\n";
1786         pr "    }\n";
1787         pr "\n";
1788         pr "    /* Allocate some space to store this next entry. */\n";
1789         pr "    newp = realloc (ret->guestfs_lvm_int_%s_list_val,\n" typ;
1790         pr "                sizeof (guestfs_lvm_int_%s) * (i+1));\n" typ;
1791         pr "    if (newp == NULL) {\n";
1792         pr "      reply_with_perror (\"realloc\");\n";
1793         pr "      free (ret->guestfs_lvm_int_%s_list_val);\n" typ;
1794         pr "      free (ret);\n";
1795         pr "      free (out);\n";
1796         pr "      return NULL;\n";
1797         pr "    }\n";
1798         pr "    ret->guestfs_lvm_int_%s_list_val = newp;\n" typ;
1799         pr "\n";
1800         pr "    /* Tokenize the next entry. */\n";
1801         pr "    r = lvm_tokenize_%s (p, &ret->guestfs_lvm_int_%s_list_val[i]);\n" typ typ;
1802         pr "    if (r == -1) {\n";
1803         pr "      reply_with_error (\"failed to parse output of '%ss' command\");\n" typ;
1804         pr "      free (ret->guestfs_lvm_int_%s_list_val);\n" typ;
1805         pr "      free (ret);\n";
1806         pr "      free (out);\n";
1807         pr "      return NULL;\n";
1808         pr "    }\n";
1809         pr "\n";
1810         pr "    ++i;\n";
1811         pr "    p = pend;\n";
1812         pr "  }\n";
1813         pr "\n";
1814         pr "  ret->guestfs_lvm_int_%s_list_len = i;\n" typ;
1815         pr "\n";
1816         pr "  free (out);\n";
1817         pr "  return ret;\n";
1818         pr "}\n"
1819
1820   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols]
1821
1822 (* Generate the tests. *)
1823 and generate_tests () =
1824   generate_header CStyle GPLv2;
1825
1826   pr "#include <stdio.h>\n";
1827   pr "#include <stdlib.h>\n";
1828   pr "#include <string.h>\n";
1829   pr "\n";
1830   pr "#include \"guestfs.h\"\n";
1831   pr "\n";
1832
1833
1834
1835   pr "int main (int argc, char *argv[])\n";
1836   pr "{\n";
1837   pr "  exit (0);\n";
1838   pr "}\n"
1839
1840 (* Generate a lot of different functions for guestfish. *)
1841 and generate_fish_cmds () =
1842   generate_header CStyle GPLv2;
1843
1844   let all_functions =
1845     List.filter (
1846       fun (_, _, _, flags, _, _, _) -> not (List.mem NotInFish flags)
1847     ) all_functions in
1848   let all_functions_sorted =
1849     List.filter (
1850       fun (_, _, _, flags, _, _, _) -> not (List.mem NotInFish flags)
1851     ) all_functions_sorted in
1852
1853   pr "#include <stdio.h>\n";
1854   pr "#include <stdlib.h>\n";
1855   pr "#include <string.h>\n";
1856   pr "#include <inttypes.h>\n";
1857   pr "\n";
1858   pr "#include <guestfs.h>\n";
1859   pr "#include \"fish.h\"\n";
1860   pr "\n";
1861
1862   (* list_commands function, which implements guestfish -h *)
1863   pr "void list_commands (void)\n";
1864   pr "{\n";
1865   pr "  printf (\"    %%-16s     %%s\\n\", \"Command\", \"Description\");\n";
1866   pr "  list_builtin_commands ();\n";
1867   List.iter (
1868     fun (name, _, _, flags, _, shortdesc, _) ->
1869       let name = replace_char name '_' '-' in
1870       pr "  printf (\"%%-20s %%s\\n\", \"%s\", \"%s\");\n"
1871         name shortdesc
1872   ) all_functions_sorted;
1873   pr "  printf (\"    Use -h <cmd> / help <cmd> to show detailed help for a command.\\n\");\n";
1874   pr "}\n";
1875   pr "\n";
1876
1877   (* display_command function, which implements guestfish -h cmd *)
1878   pr "void display_command (const char *cmd)\n";
1879   pr "{\n";
1880   List.iter (
1881     fun (name, style, _, flags, _, shortdesc, longdesc) ->
1882       let name2 = replace_char name '_' '-' in
1883       let alias =
1884         try find_map (function FishAlias n -> Some n | _ -> None) flags
1885         with Not_found -> name in
1886       let longdesc = replace_str longdesc "C<guestfs_" "C<" in
1887       let synopsis =
1888         match snd style with
1889         | [] -> name2
1890         | args ->
1891             sprintf "%s <%s>"
1892               name2 (String.concat "> <" (List.map name_of_argt args)) in
1893
1894       let warnings =
1895         if List.mem ProtocolLimitWarning flags then
1896           "\n\nBecause of the message protocol, there is a transfer limit
1897 of somewhere between 2MB and 4MB.  To transfer large files you should use
1898 FTP."
1899         else "" in
1900
1901       let describe_alias =
1902         if name <> alias then
1903           sprintf "\n\nYou can use '%s' as an alias for this command." alias
1904         else "" in
1905
1906       pr "  if (";
1907       pr "strcasecmp (cmd, \"%s\") == 0" name;
1908       if name <> name2 then
1909         pr " || strcasecmp (cmd, \"%s\") == 0" name2;
1910       if name <> alias then
1911         pr " || strcasecmp (cmd, \"%s\") == 0" alias;
1912       pr ")\n";
1913       pr "    pod2text (\"%s - %s\", %S);\n"
1914         name2 shortdesc
1915         (" " ^ synopsis ^ "\n\n" ^ longdesc ^ warnings ^ describe_alias);
1916       pr "  else\n"
1917   ) all_functions;
1918   pr "    display_builtin_command (cmd);\n";
1919   pr "}\n";
1920   pr "\n";
1921
1922   (* print_{pv,vg,lv}_list functions *)
1923   List.iter (
1924     function
1925     | typ, cols ->
1926         pr "static void print_%s (struct guestfs_lvm_%s *%s)\n" typ typ typ;
1927         pr "{\n";
1928         pr "  int i;\n";
1929         pr "\n";
1930         List.iter (
1931           function
1932           | name, `String ->
1933               pr "  printf (\"%s: %%s\\n\", %s->%s);\n" name typ name
1934           | name, `UUID ->
1935               pr "  printf (\"%s: \");\n" name;
1936               pr "  for (i = 0; i < 32; ++i)\n";
1937               pr "    printf (\"%%c\", %s->%s[i]);\n" typ name;
1938               pr "  printf (\"\\n\");\n"
1939           | name, `Bytes ->
1940               pr "  printf (\"%s: %%\" PRIu64 \"\\n\", %s->%s);\n" name typ name
1941           | name, `Int ->
1942               pr "  printf (\"%s: %%\" PRIi64 \"\\n\", %s->%s);\n" name typ name
1943           | name, `OptPercent ->
1944               pr "  if (%s->%s >= 0) printf (\"%s: %%g %%%%\\n\", %s->%s);\n"
1945                 typ name name typ name;
1946               pr "  else printf (\"%s: \\n\");\n" name
1947         ) cols;
1948         pr "}\n";
1949         pr "\n";
1950         pr "static void print_%s_list (struct guestfs_lvm_%s_list *%ss)\n"
1951           typ typ typ;
1952         pr "{\n";
1953         pr "  int i;\n";
1954         pr "\n";
1955         pr "  for (i = 0; i < %ss->len; ++i)\n" typ;
1956         pr "    print_%s (&%ss->val[i]);\n" typ typ;
1957         pr "}\n";
1958         pr "\n";
1959   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols];
1960
1961   (* run_<action> actions *)
1962   List.iter (
1963     fun (name, style, _, flags, _, _, _) ->
1964       pr "static int run_%s (const char *cmd, int argc, char *argv[])\n" name;
1965       pr "{\n";
1966       (match fst style with
1967        | RErr
1968        | RInt _
1969        | RBool _ -> pr "  int r;\n"
1970        | RConstString _ -> pr "  const char *r;\n"
1971        | RString _ -> pr "  char *r;\n"
1972        | RStringList _ -> pr "  char **r;\n"
1973        | RIntBool _ -> pr "  struct guestfs_int_bool *r;\n"
1974        | RPVList _ -> pr "  struct guestfs_lvm_pv_list *r;\n"
1975        | RVGList _ -> pr "  struct guestfs_lvm_vg_list *r;\n"
1976        | RLVList _ -> pr "  struct guestfs_lvm_lv_list *r;\n"
1977       );
1978       List.iter (
1979         function
1980         | String n -> pr "  const char *%s;\n" n
1981         | OptString n -> pr "  const char *%s;\n" n
1982         | Bool n -> pr "  int %s;\n" n
1983         | Int n -> pr "  int %s;\n" n
1984       ) (snd style);
1985
1986       (* Check and convert parameters. *)
1987       let argc_expected = List.length (snd style) in
1988       pr "  if (argc != %d) {\n" argc_expected;
1989       pr "    fprintf (stderr, \"%%s should have %d parameter(s)\\n\", cmd);\n"
1990         argc_expected;
1991       pr "    fprintf (stderr, \"type 'help %%s' for help on %%s\\n\", cmd, cmd);\n";
1992       pr "    return -1;\n";
1993       pr "  }\n";
1994       iteri (
1995         fun i ->
1996           function
1997           | String name -> pr "  %s = argv[%d];\n" name i
1998           | OptString name ->
1999               pr "  %s = strcmp (argv[%d], \"\") != 0 ? argv[%d] : NULL;\n"
2000                 name i i
2001           | Bool name ->
2002               pr "  %s = is_true (argv[%d]) ? 1 : 0;\n" name i
2003           | Int name ->
2004               pr "  %s = atoi (argv[%d]);\n" name i
2005       ) (snd style);
2006
2007       (* Call C API function. *)
2008       let fn =
2009         try find_map (function FishAction n -> Some n | _ -> None) flags
2010         with Not_found -> sprintf "guestfs_%s" name in
2011       pr "  r = %s " fn;
2012       generate_call_args ~handle:"g" style;
2013       pr ";\n";
2014
2015       (* Check return value for errors and display command results. *)
2016       (match fst style with
2017        | RErr -> pr "  return r;\n"
2018        | RInt _ ->
2019            pr "  if (r == -1) return -1;\n";
2020            pr "  if (r) printf (\"%%d\\n\", r);\n";
2021            pr "  return 0;\n"
2022        | RBool _ ->
2023            pr "  if (r == -1) return -1;\n";
2024            pr "  if (r) printf (\"true\\n\"); else printf (\"false\\n\");\n";
2025            pr "  return 0;\n"
2026        | RConstString _ ->
2027            pr "  if (r == NULL) return -1;\n";
2028            pr "  printf (\"%%s\\n\", r);\n";
2029            pr "  return 0;\n"
2030        | RString _ ->
2031            pr "  if (r == NULL) return -1;\n";
2032            pr "  printf (\"%%s\\n\", r);\n";
2033            pr "  free (r);\n";
2034            pr "  return 0;\n"
2035        | RStringList _ ->
2036            pr "  if (r == NULL) return -1;\n";
2037            pr "  print_strings (r);\n";
2038            pr "  free_strings (r);\n";
2039            pr "  return 0;\n"
2040        | RIntBool _ ->
2041            pr "  if (r == NULL) return -1;\n";
2042            pr "  printf (\"%%d, %%s\\n\", r->i,\n";
2043            pr "    r->b ? \"true\" : \"false\");\n";
2044            pr "  guestfs_free_int_bool (r);\n";
2045            pr "  return 0;\n"
2046        | RPVList _ ->
2047            pr "  if (r == NULL) return -1;\n";
2048            pr "  print_pv_list (r);\n";
2049            pr "  guestfs_free_lvm_pv_list (r);\n";
2050            pr "  return 0;\n"
2051        | RVGList _ ->
2052            pr "  if (r == NULL) return -1;\n";
2053            pr "  print_vg_list (r);\n";
2054            pr "  guestfs_free_lvm_vg_list (r);\n";
2055            pr "  return 0;\n"
2056        | RLVList _ ->
2057            pr "  if (r == NULL) return -1;\n";
2058            pr "  print_lv_list (r);\n";
2059            pr "  guestfs_free_lvm_lv_list (r);\n";
2060            pr "  return 0;\n"
2061       );
2062       pr "}\n";
2063       pr "\n"
2064   ) all_functions;
2065
2066   (* run_action function *)
2067   pr "int run_action (const char *cmd, int argc, char *argv[])\n";
2068   pr "{\n";
2069   List.iter (
2070     fun (name, _, _, flags, _, _, _) ->
2071       let name2 = replace_char name '_' '-' in
2072       let alias =
2073         try find_map (function FishAlias n -> Some n | _ -> None) flags
2074         with Not_found -> name in
2075       pr "  if (";
2076       pr "strcasecmp (cmd, \"%s\") == 0" name;
2077       if name <> name2 then
2078         pr " || strcasecmp (cmd, \"%s\") == 0" name2;
2079       if name <> alias then
2080         pr " || strcasecmp (cmd, \"%s\") == 0" alias;
2081       pr ")\n";
2082       pr "    return run_%s (cmd, argc, argv);\n" name;
2083       pr "  else\n";
2084   ) all_functions;
2085   pr "    {\n";
2086   pr "      fprintf (stderr, \"%%s: unknown command\\n\", cmd);\n";
2087   pr "      return -1;\n";
2088   pr "    }\n";
2089   pr "  return 0;\n";
2090   pr "}\n";
2091   pr "\n"
2092
2093 (* Generate the POD documentation for guestfish. *)
2094 and generate_fish_actions_pod () =
2095   let all_functions_sorted =
2096     List.filter (
2097       fun (_, _, _, flags, _, _, _) -> not (List.mem NotInFish flags)
2098     ) all_functions_sorted in
2099
2100   List.iter (
2101     fun (name, style, _, flags, _, _, longdesc) ->
2102       let longdesc = replace_str longdesc "C<guestfs_" "C<" in
2103       let name = replace_char name '_' '-' in
2104       let alias =
2105         try find_map (function FishAlias n -> Some n | _ -> None) flags
2106         with Not_found -> name in
2107
2108       pr "=head2 %s" name;
2109       if name <> alias then
2110         pr " | %s" alias;
2111       pr "\n";
2112       pr "\n";
2113       pr " %s" name;
2114       List.iter (
2115         function
2116         | String n -> pr " %s" n
2117         | OptString n -> pr " %s" n
2118         | Bool _ -> pr " true|false"
2119         | Int n -> pr " %s" n
2120       ) (snd style);
2121       pr "\n";
2122       pr "\n";
2123       pr "%s\n\n" longdesc
2124   ) all_functions_sorted
2125
2126 (* Generate a C function prototype. *)
2127 and generate_prototype ?(extern = true) ?(static = false) ?(semicolon = true)
2128     ?(single_line = false) ?(newline = false) ?(in_daemon = false)
2129     ?(prefix = "")
2130     ?handle name style =
2131   if extern then pr "extern ";
2132   if static then pr "static ";
2133   (match fst style with
2134    | RErr -> pr "int "
2135    | RInt _ -> pr "int "
2136    | RBool _ -> pr "int "
2137    | RConstString _ -> pr "const char *"
2138    | RString _ -> pr "char *"
2139    | RStringList _ -> pr "char **"
2140    | RIntBool _ ->
2141        if not in_daemon then pr "struct guestfs_int_bool *"
2142        else pr "guestfs_%s_ret *" name
2143    | RPVList _ ->
2144        if not in_daemon then pr "struct guestfs_lvm_pv_list *"
2145        else pr "guestfs_lvm_int_pv_list *"
2146    | RVGList _ ->
2147        if not in_daemon then pr "struct guestfs_lvm_vg_list *"
2148        else pr "guestfs_lvm_int_vg_list *"
2149    | RLVList _ ->
2150        if not in_daemon then pr "struct guestfs_lvm_lv_list *"
2151        else pr "guestfs_lvm_int_lv_list *"
2152   );
2153   pr "%s%s (" prefix name;
2154   if handle = None && List.length (snd style) = 0 then
2155     pr "void"
2156   else (
2157     let comma = ref false in
2158     (match handle with
2159      | None -> ()
2160      | Some handle -> pr "guestfs_h *%s" handle; comma := true
2161     );
2162     let next () =
2163       if !comma then (
2164         if single_line then pr ", " else pr ",\n\t\t"
2165       );
2166       comma := true
2167     in
2168     List.iter (
2169       function
2170       | String n -> next (); pr "const char *%s" n
2171       | OptString n -> next (); pr "const char *%s" n
2172       | Bool n -> next (); pr "int %s" n
2173       | Int n -> next (); pr "int %s" n
2174     ) (snd style);
2175   );
2176   pr ")";
2177   if semicolon then pr ";";
2178   if newline then pr "\n"
2179
2180 (* Generate C call arguments, eg "(handle, foo, bar)" *)
2181 and generate_call_args ?handle style =
2182   pr "(";
2183   let comma = ref false in
2184   (match handle with
2185    | None -> ()
2186    | Some handle -> pr "%s" handle; comma := true
2187   );
2188   List.iter (
2189     fun arg ->
2190       if !comma then pr ", ";
2191       comma := true;
2192       match arg with
2193       | String n -> pr "%s" n
2194       | OptString n -> pr "%s" n
2195       | Bool n -> pr "%s" n
2196       | Int n -> pr "%s" n
2197   ) (snd style);
2198   pr ")"
2199
2200 (* Generate the OCaml bindings interface. *)
2201 and generate_ocaml_mli () =
2202   generate_header OCamlStyle LGPLv2;
2203
2204   pr "\
2205 (** For API documentation you should refer to the C API
2206     in the guestfs(3) manual page.  The OCaml API uses almost
2207     exactly the same calls. *)
2208
2209 type t
2210 (** A [guestfs_h] handle. *)
2211
2212 exception Error of string
2213 (** This exception is raised when there is an error. *)
2214
2215 val create : unit -> t
2216
2217 val close : t -> unit
2218 (** Handles are closed by the garbage collector when they become
2219     unreferenced, but callers can also call this in order to
2220     provide predictable cleanup. *)
2221
2222 ";
2223   generate_ocaml_lvm_structure_decls ();
2224
2225   (* The actions. *)
2226   List.iter (
2227     fun (name, style, _, _, _, shortdesc, _) ->
2228       generate_ocaml_prototype name style;
2229       pr "(** %s *)\n" shortdesc;
2230       pr "\n"
2231   ) all_functions
2232
2233 (* Generate the OCaml bindings implementation. *)
2234 and generate_ocaml_ml () =
2235   generate_header OCamlStyle LGPLv2;
2236
2237   pr "\
2238 type t
2239 exception Error of string
2240 external create : unit -> t = \"ocaml_guestfs_create\"
2241 external close : t -> unit = \"ocaml_guestfs_close\"
2242
2243 let () =
2244   Callback.register_exception \"ocaml_guestfs_error\" (Error \"\")
2245
2246 ";
2247
2248   generate_ocaml_lvm_structure_decls ();
2249
2250   (* The actions. *)
2251   List.iter (
2252     fun (name, style, _, _, _, shortdesc, _) ->
2253       generate_ocaml_prototype ~is_external:true name style;
2254   ) all_functions
2255
2256 (* Generate the OCaml bindings C implementation. *)
2257 and generate_ocaml_c () =
2258   generate_header CStyle LGPLv2;
2259
2260   pr "#include <stdio.h>\n";
2261   pr "#include <stdlib.h>\n";
2262   pr "#include <string.h>\n";
2263   pr "\n";
2264   pr "#include <caml/config.h>\n";
2265   pr "#include <caml/alloc.h>\n";
2266   pr "#include <caml/callback.h>\n";
2267   pr "#include <caml/fail.h>\n";
2268   pr "#include <caml/memory.h>\n";
2269   pr "#include <caml/mlvalues.h>\n";
2270   pr "#include <caml/signals.h>\n";
2271   pr "\n";
2272   pr "#include <guestfs.h>\n";
2273   pr "\n";
2274   pr "#include \"guestfs_c.h\"\n";
2275   pr "\n";
2276
2277   (* LVM struct copy functions. *)
2278   List.iter (
2279     fun (typ, cols) ->
2280       let has_optpercent_col =
2281         List.exists (function (_, `OptPercent) -> true | _ -> false) cols in
2282
2283       pr "static CAMLprim value\n";
2284       pr "copy_lvm_%s (const struct guestfs_lvm_%s *%s)\n" typ typ typ;
2285       pr "{\n";
2286       pr "  CAMLparam0 ();\n";
2287       if has_optpercent_col then
2288         pr "  CAMLlocal3 (rv, v, v2);\n"
2289       else
2290         pr "  CAMLlocal2 (rv, v);\n";
2291       pr "\n";
2292       pr "  rv = caml_alloc (%d, 0);\n" (List.length cols);
2293       iteri (
2294         fun i col ->
2295           (match col with
2296            | name, `String ->
2297                pr "  v = caml_copy_string (%s->%s);\n" typ name
2298            | name, `UUID ->
2299                pr "  v = caml_alloc_string (32);\n";
2300                pr "  memcpy (String_val (v), %s->%s, 32);\n" typ name
2301            | name, `Bytes
2302            | name, `Int ->
2303                pr "  v = caml_copy_int64 (%s->%s);\n" typ name
2304            | name, `OptPercent ->
2305                pr "  if (%s->%s >= 0) { /* Some %s */\n" typ name name;
2306                pr "    v2 = caml_copy_double (%s->%s);\n" typ name;
2307                pr "    v = caml_alloc (1, 0);\n";
2308                pr "    Store_field (v, 0, v2);\n";
2309                pr "  } else /* None */\n";
2310                pr "    v = Val_int (0);\n";
2311           );
2312           pr "  Store_field (rv, %d, v);\n" i
2313       ) cols;
2314       pr "  CAMLreturn (rv);\n";
2315       pr "}\n";
2316       pr "\n";
2317
2318       pr "static CAMLprim value\n";
2319       pr "copy_lvm_%s_list (const struct guestfs_lvm_%s_list *%ss)\n"
2320         typ typ typ;
2321       pr "{\n";
2322       pr "  CAMLparam0 ();\n";
2323       pr "  CAMLlocal2 (rv, v);\n";
2324       pr "  int i;\n";
2325       pr "\n";
2326       pr "  if (%ss->len == 0)\n" typ;
2327       pr "    CAMLreturn (Atom (0));\n";
2328       pr "  else {\n";
2329       pr "    rv = caml_alloc (%ss->len, 0);\n" typ;
2330       pr "    for (i = 0; i < %ss->len; ++i) {\n" typ;
2331       pr "      v = copy_lvm_%s (&%ss->val[i]);\n" typ typ;
2332       pr "      caml_modify (&Field (rv, i), v);\n";
2333       pr "    }\n";
2334       pr "    CAMLreturn (rv);\n";
2335       pr "  }\n";
2336       pr "}\n";
2337       pr "\n";
2338   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols];
2339
2340   List.iter (
2341     fun (name, style, _, _, _, _, _) ->
2342       pr "CAMLprim value\n";
2343       pr "ocaml_guestfs_%s (value gv" name;
2344       List.iter (
2345         fun arg -> pr ", value %sv" (name_of_argt arg)
2346       ) (snd style);
2347       pr ")\n";
2348       pr "{\n";
2349       pr "  CAMLparam%d (gv" (1 + (List.length (snd style)));
2350       List.iter (
2351         fun arg -> pr ", %sv" (name_of_argt arg)
2352       ) (snd style);
2353       pr ");\n";
2354       pr "  CAMLlocal1 (rv);\n";
2355       pr "\n";
2356
2357       pr "  guestfs_h *g = Guestfs_val (gv);\n";
2358       pr "  if (g == NULL)\n";
2359       pr "    caml_failwith (\"%s: used handle after closing it\");\n" name;
2360       pr "\n";
2361
2362       List.iter (
2363         function
2364         | String n ->
2365             pr "  const char *%s = String_val (%sv);\n" n n
2366         | OptString n ->
2367             pr "  const char *%s =\n" n;
2368             pr "    %sv != Val_int (0) ? String_val (Field (%sv, 0)) : NULL;\n"
2369               n n
2370         | Bool n ->
2371             pr "  int %s = Bool_val (%sv);\n" n n
2372         | Int n ->
2373             pr "  int %s = Int_val (%sv);\n" n n
2374       ) (snd style);
2375       let error_code =
2376         match fst style with
2377         | RErr -> pr "  int r;\n"; "-1"
2378         | RInt _ -> pr "  int r;\n"; "-1"
2379         | RBool _ -> pr "  int r;\n"; "-1"
2380         | RConstString _ -> pr "  const char *r;\n"; "NULL"
2381         | RString _ -> pr "  char *r;\n"; "NULL"
2382         | RStringList _ ->
2383             pr "  int i;\n";
2384             pr "  char **r;\n";
2385             "NULL"
2386         | RIntBool _ ->
2387             pr "  struct guestfs_int_bool *r;\n";
2388             "NULL"
2389         | RPVList _ ->
2390             pr "  struct guestfs_lvm_pv_list *r;\n";
2391             "NULL"
2392         | RVGList _ ->
2393             pr "  struct guestfs_lvm_vg_list *r;\n";
2394             "NULL"
2395         | RLVList _ ->
2396             pr "  struct guestfs_lvm_lv_list *r;\n";
2397             "NULL" in
2398       pr "\n";
2399
2400       pr "  caml_enter_blocking_section ();\n";
2401       pr "  r = guestfs_%s " name;
2402       generate_call_args ~handle:"g" style;
2403       pr ";\n";
2404       pr "  caml_leave_blocking_section ();\n";
2405       pr "  if (r == %s)\n" error_code;
2406       pr "    ocaml_guestfs_raise_error (g, \"%s\");\n" name;
2407       pr "\n";
2408
2409       (match fst style with
2410        | RErr -> pr "  rv = Val_unit;\n"
2411        | RInt _ -> pr "  rv = Val_int (r);\n"
2412        | RBool _ -> pr "  rv = Val_bool (r);\n"
2413        | RConstString _ -> pr "  rv = caml_copy_string (r);\n"
2414        | RString _ ->
2415            pr "  rv = caml_copy_string (r);\n";
2416            pr "  free (r);\n"
2417        | RStringList _ ->
2418            pr "  rv = caml_copy_string_array ((const char **) r);\n";
2419            pr "  for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
2420            pr "  free (r);\n"
2421        | RIntBool _ ->
2422            pr "  rv = caml_alloc (2, 0);\n";
2423            pr "  Store_field (rv, 0, Val_int (r->i));\n";
2424            pr "  Store_field (rv, 1, Val_bool (r->b));\n";
2425            pr "  guestfs_free_int_bool (r);\n";
2426        | RPVList _ ->
2427            pr "  rv = copy_lvm_pv_list (r);\n";
2428            pr "  guestfs_free_lvm_pv_list (r);\n";
2429        | RVGList _ ->
2430            pr "  rv = copy_lvm_vg_list (r);\n";
2431            pr "  guestfs_free_lvm_vg_list (r);\n";
2432        | RLVList _ ->
2433            pr "  rv = copy_lvm_lv_list (r);\n";
2434            pr "  guestfs_free_lvm_lv_list (r);\n";
2435       );
2436
2437       pr "  CAMLreturn (rv);\n";
2438       pr "}\n";
2439       pr "\n"
2440   ) all_functions
2441
2442 and generate_ocaml_lvm_structure_decls () =
2443   List.iter (
2444     fun (typ, cols) ->
2445       pr "type lvm_%s = {\n" typ;
2446       List.iter (
2447         function
2448         | name, `String -> pr "  %s : string;\n" name
2449         | name, `UUID -> pr "  %s : string;\n" name
2450         | name, `Bytes -> pr "  %s : int64;\n" name
2451         | name, `Int -> pr "  %s : int64;\n" name
2452         | name, `OptPercent -> pr "  %s : float option;\n" name
2453       ) cols;
2454       pr "}\n";
2455       pr "\n"
2456   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols]
2457
2458 and generate_ocaml_prototype ?(is_external = false) name style =
2459   if is_external then pr "external " else pr "val ";
2460   pr "%s : t -> " name;
2461   List.iter (
2462     function
2463     | String _ -> pr "string -> "
2464     | OptString _ -> pr "string option -> "
2465     | Bool _ -> pr "bool -> "
2466     | Int _ -> pr "int -> "
2467   ) (snd style);
2468   (match fst style with
2469    | RErr -> pr "unit" (* all errors are turned into exceptions *)
2470    | RInt _ -> pr "int"
2471    | RBool _ -> pr "bool"
2472    | RConstString _ -> pr "string"
2473    | RString _ -> pr "string"
2474    | RStringList _ -> pr "string array"
2475    | RIntBool _ -> pr "int * bool"
2476    | RPVList _ -> pr "lvm_pv array"
2477    | RVGList _ -> pr "lvm_vg array"
2478    | RLVList _ -> pr "lvm_lv array"
2479   );
2480   if is_external then pr " = \"ocaml_guestfs_%s\"" name;
2481   pr "\n"
2482
2483 (* Generate Perl xs code, a sort of crazy variation of C with macros. *)
2484 and generate_perl_xs () =
2485   generate_header CStyle LGPLv2;
2486
2487   pr "\
2488 #include \"EXTERN.h\"
2489 #include \"perl.h\"
2490 #include \"XSUB.h\"
2491
2492 #include <guestfs.h>
2493
2494 #ifndef PRId64
2495 #define PRId64 \"lld\"
2496 #endif
2497
2498 static SV *
2499 my_newSVll(long long val) {
2500 #ifdef USE_64_BIT_ALL
2501   return newSViv(val);
2502 #else
2503   char buf[100];
2504   int len;
2505   len = snprintf(buf, 100, \"%%\" PRId64, val);
2506   return newSVpv(buf, len);
2507 #endif
2508 }
2509
2510 #ifndef PRIu64
2511 #define PRIu64 \"llu\"
2512 #endif
2513
2514 static SV *
2515 my_newSVull(unsigned long long val) {
2516 #ifdef USE_64_BIT_ALL
2517   return newSVuv(val);
2518 #else
2519   char buf[100];
2520   int len;
2521   len = snprintf(buf, 100, \"%%\" PRIu64, val);
2522   return newSVpv(buf, len);
2523 #endif
2524 }
2525
2526 /* XXX Not thread-safe, and in general not safe if the caller is
2527  * issuing multiple requests in parallel (on different guestfs
2528  * handles).  We should use the guestfs_h handle passed to the
2529  * error handle to distinguish these cases.
2530  */
2531 static char *last_error = NULL;
2532
2533 static void
2534 error_handler (guestfs_h *g,
2535                void *data,
2536                const char *msg)
2537 {
2538   if (last_error != NULL) free (last_error);
2539   last_error = strdup (msg);
2540 }
2541
2542 MODULE = Sys::Guestfs  PACKAGE = Sys::Guestfs
2543
2544 guestfs_h *
2545 _create ()
2546    CODE:
2547       RETVAL = guestfs_create ();
2548       if (!RETVAL)
2549         croak (\"could not create guestfs handle\");
2550       guestfs_set_error_handler (RETVAL, error_handler, NULL);
2551  OUTPUT:
2552       RETVAL
2553
2554 void
2555 DESTROY (g)
2556       guestfs_h *g;
2557  PPCODE:
2558       guestfs_close (g);
2559
2560 ";
2561
2562   List.iter (
2563     fun (name, style, _, _, _, _, _) ->
2564       (match fst style with
2565        | RErr -> pr "void\n"
2566        | RInt _ -> pr "SV *\n"
2567        | RBool _ -> pr "SV *\n"
2568        | RConstString _ -> pr "SV *\n"
2569        | RString _ -> pr "SV *\n"
2570        | RStringList _
2571        | RIntBool _
2572        | RPVList _ | RVGList _ | RLVList _ ->
2573            pr "void\n" (* all lists returned implictly on the stack *)
2574       );
2575       (* Call and arguments. *)
2576       pr "%s " name;
2577       generate_call_args ~handle:"g" style;
2578       pr "\n";
2579       pr "      guestfs_h *g;\n";
2580       List.iter (
2581         function
2582         | String n -> pr "      char *%s;\n" n
2583         | OptString n -> pr "      char *%s;\n" n
2584         | Bool n -> pr "      int %s;\n" n
2585         | Int n -> pr "      int %s;\n" n
2586       ) (snd style);
2587       (* Code. *)
2588       (match fst style with
2589        | RErr ->
2590            pr " PPCODE:\n";
2591            pr "      if (guestfs_%s " name;
2592            generate_call_args ~handle:"g" style;
2593            pr " == -1)\n";
2594            pr "        croak (\"%s: %%s\", last_error);\n" name
2595        | RInt n
2596        | RBool n ->
2597            pr "PREINIT:\n";
2598            pr "      int %s;\n" n;
2599            pr "   CODE:\n";
2600            pr "      %s = guestfs_%s " n name;
2601            generate_call_args ~handle:"g" style;
2602            pr ";\n";
2603            pr "      if (%s == -1)\n" n;
2604            pr "        croak (\"%s: %%s\", last_error);\n" name;
2605            pr "      RETVAL = newSViv (%s);\n" n;
2606            pr " OUTPUT:\n";
2607            pr "      RETVAL\n"
2608        | RConstString n ->
2609            pr "PREINIT:\n";
2610            pr "      const char *%s;\n" n;
2611            pr "   CODE:\n";
2612            pr "      %s = guestfs_%s " n name;
2613            generate_call_args ~handle:"g" style;
2614            pr ";\n";
2615            pr "      if (%s == NULL)\n" n;
2616            pr "        croak (\"%s: %%s\", last_error);\n" name;
2617            pr "      RETVAL = newSVpv (%s, 0);\n" n;
2618            pr " OUTPUT:\n";
2619            pr "      RETVAL\n"
2620        | RString n ->
2621            pr "PREINIT:\n";
2622            pr "      char *%s;\n" n;
2623            pr "   CODE:\n";
2624            pr "      %s = guestfs_%s " n name;
2625            generate_call_args ~handle:"g" style;
2626            pr ";\n";
2627            pr "      if (%s == NULL)\n" n;
2628            pr "        croak (\"%s: %%s\", last_error);\n" name;
2629            pr "      RETVAL = newSVpv (%s, 0);\n" n;
2630            pr "      free (%s);\n" n;
2631            pr " OUTPUT:\n";
2632            pr "      RETVAL\n"
2633        | RStringList n ->
2634            pr "PREINIT:\n";
2635            pr "      char **%s;\n" n;
2636            pr "      int i, n;\n";
2637            pr " PPCODE:\n";
2638            pr "      %s = guestfs_%s " n name;
2639            generate_call_args ~handle:"g" style;
2640            pr ";\n";
2641            pr "      if (%s == NULL)\n" n;
2642            pr "        croak (\"%s: %%s\", last_error);\n" name;
2643            pr "      for (n = 0; %s[n] != NULL; ++n) /**/;\n" n;
2644            pr "      EXTEND (SP, n);\n";
2645            pr "      for (i = 0; i < n; ++i) {\n";
2646            pr "        PUSHs (sv_2mortal (newSVpv (%s[i], 0)));\n" n;
2647            pr "        free (%s[i]);\n" n;
2648            pr "      }\n";
2649            pr "      free (%s);\n" n;
2650        | RIntBool _ ->
2651            pr "PREINIT:\n";
2652            pr "      struct guestfs_int_bool *r;\n";
2653            pr " PPCODE:\n";
2654            pr "      r = guestfs_%s " name;
2655            generate_call_args ~handle:"g" style;
2656            pr ";\n";
2657            pr "      if (r == NULL)\n";
2658            pr "        croak (\"%s: %%s\", last_error);\n" name;
2659            pr "      EXTEND (SP, 2);\n";
2660            pr "      PUSHs (sv_2mortal (newSViv (r->i)));\n";
2661            pr "      PUSHs (sv_2mortal (newSViv (r->b)));\n";
2662            pr "      guestfs_free_int_bool (r);\n";
2663        | RPVList n ->
2664            generate_perl_lvm_code "pv" pv_cols name style n;
2665        | RVGList n ->
2666            generate_perl_lvm_code "vg" vg_cols name style n;
2667        | RLVList n ->
2668            generate_perl_lvm_code "lv" lv_cols name style n;
2669       );
2670       pr "\n"
2671   ) all_functions
2672
2673 and generate_perl_lvm_code typ cols name style n =
2674   pr "PREINIT:\n";
2675   pr "      struct guestfs_lvm_%s_list *%s;\n" typ n;
2676   pr "      int i;\n";
2677   pr "      HV *hv;\n";
2678   pr " PPCODE:\n";
2679   pr "      %s = guestfs_%s " n name;
2680   generate_call_args ~handle:"g" style;
2681   pr ";\n";
2682   pr "      if (%s == NULL)\n" n;
2683   pr "        croak (\"%s: %%s\", last_error);\n" name;
2684   pr "      EXTEND (SP, %s->len);\n" n;
2685   pr "      for (i = 0; i < %s->len; ++i) {\n" n;
2686   pr "        hv = newHV ();\n";
2687   List.iter (
2688     function
2689     | name, `String ->
2690         pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (%s->val[i].%s, 0), 0);\n"
2691           name (String.length name) n name
2692     | name, `UUID ->
2693         pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (%s->val[i].%s, 32), 0);\n"
2694           name (String.length name) n name
2695     | name, `Bytes ->
2696         pr "        (void) hv_store (hv, \"%s\", %d, my_newSVull (%s->val[i].%s), 0);\n"
2697           name (String.length name) n name
2698     | name, `Int ->
2699         pr "        (void) hv_store (hv, \"%s\", %d, my_newSVll (%s->val[i].%s), 0);\n"
2700           name (String.length name) n name
2701     | name, `OptPercent ->
2702         pr "        (void) hv_store (hv, \"%s\", %d, newSVnv (%s->val[i].%s), 0);\n"
2703           name (String.length name) n name
2704   ) cols;
2705   pr "        PUSHs (sv_2mortal ((SV *) hv));\n";
2706   pr "      }\n";
2707   pr "      guestfs_free_lvm_%s_list (%s);\n" typ n
2708
2709 (* Generate Sys/Guestfs.pm. *)
2710 and generate_perl_pm () =
2711   generate_header HashStyle LGPLv2;
2712
2713   pr "\
2714 =pod
2715
2716 =head1 NAME
2717
2718 Sys::Guestfs - Perl bindings for libguestfs
2719
2720 =head1 SYNOPSIS
2721
2722  use Sys::Guestfs;
2723
2724  my $h = Sys::Guestfs->new ();
2725  $h->add_drive ('guest.img');
2726  $h->launch ();
2727  $h->wait_ready ();
2728  $h->mount ('/dev/sda1', '/');
2729  $h->touch ('/hello');
2730  $h->sync ();
2731
2732 =head1 DESCRIPTION
2733
2734 The C<Sys::Guestfs> module provides a Perl XS binding to the
2735 libguestfs API for examining and modifying virtual machine
2736 disk images.
2737
2738 Amongst the things this is good for: making batch configuration
2739 changes to guests, getting disk used/free statistics (see also:
2740 virt-df), migrating between virtualization systems (see also:
2741 virt-p2v), performing partial backups, performing partial guest
2742 clones, cloning guests and changing registry/UUID/hostname info, and
2743 much else besides.
2744
2745 Libguestfs uses Linux kernel and qemu code, and can access any type of
2746 guest filesystem that Linux and qemu can, including but not limited
2747 to: ext2/3/4, btrfs, FAT and NTFS, LVM, many different disk partition
2748 schemes, qcow, qcow2, vmdk.
2749
2750 Libguestfs provides ways to enumerate guest storage (eg. partitions,
2751 LVs, what filesystem is in each LV, etc.).  It can also run commands
2752 in the context of the guest.  Also you can access filesystems over FTP.
2753
2754 =head1 ERRORS
2755
2756 All errors turn into calls to C<croak> (see L<Carp(3)>).
2757
2758 =head1 METHODS
2759
2760 =over 4
2761
2762 =cut
2763
2764 package Sys::Guestfs;
2765
2766 use strict;
2767 use warnings;
2768
2769 require XSLoader;
2770 XSLoader::load ('Sys::Guestfs');
2771
2772 =item $h = Sys::Guestfs->new ();
2773
2774 Create a new guestfs handle.
2775
2776 =cut
2777
2778 sub new {
2779   my $proto = shift;
2780   my $class = ref ($proto) || $proto;
2781
2782   my $self = Sys::Guestfs::_create ();
2783   bless $self, $class;
2784   return $self;
2785 }
2786
2787 ";
2788
2789   (* Actions.  We only need to print documentation for these as
2790    * they are pulled in from the XS code automatically.
2791    *)
2792   List.iter (
2793     fun (name, style, _, flags, _, _, longdesc) ->
2794       let longdesc = replace_str longdesc "C<guestfs_" "C<$h-E<gt>" in
2795       pr "=item ";
2796       generate_perl_prototype name style;
2797       pr "\n\n";
2798       pr "%s\n\n" longdesc;
2799       if List.mem ProtocolLimitWarning flags then
2800         pr "Because of the message protocol, there is a transfer limit
2801 of somewhere between 2MB and 4MB.  To transfer large files you should use
2802 FTP.\n\n";
2803   ) all_functions_sorted;
2804
2805   (* End of file. *)
2806   pr "\
2807 =cut
2808
2809 1;
2810
2811 =back
2812
2813 =head1 COPYRIGHT
2814
2815 Copyright (C) 2009 Red Hat Inc.
2816
2817 =head1 LICENSE
2818
2819 Please see the file COPYING.LIB for the full license.
2820
2821 =head1 SEE ALSO
2822
2823 L<guestfs(3)>, L<guestfish(1)>.
2824
2825 =cut
2826 "
2827
2828 and generate_perl_prototype name style =
2829   (match fst style with
2830    | RErr -> ()
2831    | RBool n
2832    | RInt n
2833    | RConstString n
2834    | RString n -> pr "$%s = " n
2835    | RIntBool (n, m) -> pr "($%s, $%s) = " n m
2836    | RStringList n
2837    | RPVList n
2838    | RVGList n
2839    | RLVList n -> pr "@%s = " n
2840   );
2841   pr "$h->%s (" name;
2842   let comma = ref false in
2843   List.iter (
2844     fun arg ->
2845       if !comma then pr ", ";
2846       comma := true;
2847       pr "%s" (name_of_argt arg)
2848   ) (snd style);
2849   pr ");"
2850
2851 let output_to filename =
2852   let filename_new = filename ^ ".new" in
2853   chan := open_out filename_new;
2854   let close () =
2855     close_out !chan;
2856     chan := stdout;
2857     Unix.rename filename_new filename;
2858     printf "written %s\n%!" filename;
2859   in
2860   close
2861
2862 (* Main program. *)
2863 let () =
2864   check_functions ();
2865
2866   if not (Sys.file_exists "configure.ac") then (
2867     eprintf "\
2868 You are probably running this from the wrong directory.
2869 Run it from the top source directory using the command
2870   src/generator.ml
2871 ";
2872     exit 1
2873   );
2874
2875   let close = output_to "src/guestfs_protocol.x" in
2876   generate_xdr ();
2877   close ();
2878
2879   let close = output_to "src/guestfs-structs.h" in
2880   generate_structs_h ();
2881   close ();
2882
2883   let close = output_to "src/guestfs-actions.h" in
2884   generate_actions_h ();
2885   close ();
2886
2887   let close = output_to "src/guestfs-actions.c" in
2888   generate_client_actions ();
2889   close ();
2890
2891   let close = output_to "daemon/actions.h" in
2892   generate_daemon_actions_h ();
2893   close ();
2894
2895   let close = output_to "daemon/stubs.c" in
2896   generate_daemon_actions ();
2897   close ();
2898
2899   let close = output_to "tests.c" in
2900   generate_tests ();
2901   close ();
2902
2903   let close = output_to "fish/cmds.c" in
2904   generate_fish_cmds ();
2905   close ();
2906
2907   let close = output_to "guestfs-structs.pod" in
2908   generate_structs_pod ();
2909   close ();
2910
2911   let close = output_to "guestfs-actions.pod" in
2912   generate_actions_pod ();
2913   close ();
2914
2915   let close = output_to "guestfish-actions.pod" in
2916   generate_fish_actions_pod ();
2917   close ();
2918
2919   let close = output_to "ocaml/guestfs.mli" in
2920   generate_ocaml_mli ();
2921   close ();
2922
2923   let close = output_to "ocaml/guestfs.ml" in
2924   generate_ocaml_ml ();
2925   close ();
2926
2927   let close = output_to "ocaml/guestfs_c_actions.c" in
2928   generate_ocaml_c ();
2929   close ();
2930
2931   let close = output_to "perl/Guestfs.xs" in
2932   generate_perl_xs ();
2933   close ();
2934
2935   let close = output_to "perl/lib/Sys/Guestfs.pm" in
2936   generate_perl_pm ();
2937   close ();