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 all the
  28  * output files.  Note that if you are using a separate build directory you
  29  * must run generator.ml from the _source_ directory.
  30  *
  31  * IMPORTANT: This script should NOT print any warnings.  If it prints
  32  * warnings, you should treat them as errors.
  33  * [Need to add -warn-error to ocaml command line]
  34  *)
  35
  36 #load "unix.cma";;
  37 #load "str.cma";;
  38
  39 open Printf
  40
  41 type style = ret * args
  42 and ret =
  43     (* "RErr" as a return value means an int used as a simple error
  44      * indication, ie. 0 or -1.
  45      *)
  46   | RErr
  47     (* "RInt" as a return value means an int which is -1 for error
  48      * or any value >= 0 on success.  Only use this for smallish
  49      * positive ints (0 <= i < 2^30).
  50      *)
  51   | RInt of string
  52     (* "RInt64" is the same as RInt, but is guaranteed to be able
  53      * to return a full 64 bit value, _except_ that -1 means error
  54      * (so -1 cannot be a valid, non-error return value).
  55      *)
  56   | RInt64 of string
  57     (* "RBool" is a bool return value which can be true/false or
  58      * -1 for error.
  59      *)
  60   | RBool of string
  61     (* "RConstString" is a string that refers to a constant value.
  62      * Try to avoid using this.  In particular you cannot use this
  63      * for values returned from the daemon, because there is no
  64      * thread-safe way to return them in the C API.
  65      *)
  66   | RConstString of string
  67     (* "RString" and "RStringList" are caller-frees. *)
  68   | RString of string
  69   | RStringList of string
  70     (* "RStruct" is a function which returns a single named structure
  71      * or an error indication (in C, a struct, and in other languages
  72      * with varying representations, but usually very efficient).  See
  73      * after the function list below for the structures.
  74      *)
  75   | RStruct of string * string          (* name of retval, name of struct *)
  76     (* "RStructList" is a function which returns either a list/array
  77      * of structures (could be zero-length), or an error indication.
  78      *)
  79   | RStructList of string * string      (* name of retval, name of struct *)
  80     (* Key-value pairs of untyped strings.  Turns into a hashtable or
  81      * dictionary in languages which support it.  DON'T use this as a
  82      * general "bucket" for results.  Prefer a stronger typed return
  83      * value if one is available, or write a custom struct.  Don't use
  84      * this if the list could potentially be very long, since it is
  85      * inefficient.  Keys should be unique.  NULLs are not permitted.
  86      *)
  87   | RHashtable of string
  88 (* Not implemented:
  89     (* "RBufferOut" is handled almost exactly like RString, but
  90      * it allows the string to contain arbitrary 8 bit data including
  91      * ASCII NUL.  In the C API this causes an implicit extra parameter
  92      * to be added of type <size_t *size_r>.  Other programming languages
  93      * support strings with arbitrary 8 bit data.  At the RPC layer
  94      * we have to use the opaque<> type instead of string<>.
  95      *)
  96   | RBufferOut of string
  97 *)
  98
  99 and args = argt list    (* Function parameters, guestfs handle is implicit. *)
 100
 101     (* Note in future we should allow a "variable args" parameter as
 102      * the final parameter, to allow commands like
 103      *   chmod mode file [file(s)...]
 104      * This is not implemented yet, but many commands (such as chmod)
 105      * are currently defined with the argument order keeping this future
 106      * possibility in mind.
 107      *)
 108 and argt =
 109   | String of string    (* const char *name, cannot be NULL *)
 110   | OptString of string (* const char *name, may be NULL *)
 111   | StringList of string(* list of strings (each string cannot be NULL) *)
 112   | Bool of string      (* boolean *)
 113   | Int of string       (* int (smallish ints, signed, <= 31 bits) *)
 114     (* These are treated as filenames (simple string parameters) in
 115      * the C API and bindings.  But in the RPC protocol, we transfer
 116      * the actual file content up to or down from the daemon.
 117      * FileIn: local machine -> daemon (in request)
 118      * FileOut: daemon -> local machine (in reply)
 119      * In guestfish (only), the special name "-" means read from
 120      * stdin or write to stdout.
 121      *)
 122   | FileIn of string
 123   | FileOut of string
 124 (* Not implemented:
 125     (* Opaque buffer which can contain arbitrary 8 bit data.
 126      * In the C API, this is expressed as <char *, int> pair.
 127      * Most other languages have a string type which can contain
 128      * ASCII NUL.  We use whatever type is appropriate for each
 129      * language.
 130      * Buffers are limited by the total message size.  To transfer
 131      * large blocks of data, use FileIn/FileOut parameters instead.
 132      * To return an arbitrary buffer, use RBufferOut.
 133      *)
 134   | BufferIn of string
 135 *)
 136
 137 type flags =
 138   | ProtocolLimitWarning  (* display warning about protocol size limits *)
 139   | DangerWillRobinson    (* flags particularly dangerous commands *)
 140   | FishAlias of string   (* provide an alias for this cmd in guestfish *)
 141   | FishAction of string  (* call this function in guestfish *)
 142   | NotInFish             (* do not export via guestfish *)
 143   | NotInDocs             (* do not add this function to documentation *)
 144
 145 let protocol_limit_warning =
 146   "Because of the message protocol, there is a transfer limit
 147 of somewhere between 2MB and 4MB.  To transfer large files you should use
 148 FTP."
 149
 150 let danger_will_robinson =
 151   "B<This command is dangerous.  Without careful use you
 152 can easily destroy all your data>."
 153
 154 (* You can supply zero or as many tests as you want per API call.
 155  *
 156  * Note that the test environment has 3 block devices, of size 500MB,
 157  * 50MB and 10MB (respectively /dev/sda, /dev/sdb, /dev/sdc), and
 158  * a fourth squashfs block device with some known files on it (/dev/sdd).
 159  *
 160  * Note for partitioning purposes, the 500MB device has 1015 cylinders.
 161  * Number of cylinders was 63 for IDE emulated disks with precisely
 162  * the same size.  How exactly this is calculated is a mystery.
 163  *
 164  * The squashfs block device (/dev/sdd) comes from images/test.sqsh.
 165  *
 166  * To be able to run the tests in a reasonable amount of time,
 167  * the virtual machine and block devices are reused between tests.
 168  * So don't try testing kill_subprocess :-x
 169  *
 170  * Between each test we blockdev-setrw, umount-all, lvm-remove-all.
 171  *
 172  * Don't assume anything about the previous contents of the block
 173  * devices.  Use 'Init*' to create some initial scenarios.
 174  *
 175  * You can add a prerequisite clause to any individual test.  This
 176  * is a run-time check, which, if it fails, causes the test to be
 177  * skipped.  Useful if testing a command which might not work on
 178  * all variations of libguestfs builds.  A test that has prerequisite
 179  * of 'Always' is run unconditionally.
 180  *
 181  * In addition, packagers can skip individual tests by setting the
 182  * environment variables:     eg:
 183  *   SKIP_TEST_<CMD>_<NUM>=1  SKIP_TEST_COMMAND_3=1  (skips test #3 of command)
 184  *   SKIP_TEST_<CMD>=1        SKIP_TEST_ZEROFREE=1   (skips all zerofree tests)
 185  *)
 186 type tests = (test_init * test_prereq * test) list
 187 and test =
 188     (* Run the command sequence and just expect nothing to fail. *)
 189   | TestRun of seq
 190     (* Run the command sequence and expect the output of the final
 191      * command to be the string.
 192      *)
 193   | TestOutput of seq * string
 194     (* Run the command sequence and expect the output of the final
 195      * command to be the list of strings.
 196      *)
 197   | TestOutputList of seq * string list
 198     (* Run the command sequence and expect the output of the final
 199      * command to be the list of block devices (could be either
 200      * "/dev/sd.." or "/dev/hd.." form - we don't check the 5th
 201      * character of each string).
 202      *)
 203   | TestOutputListOfDevices of seq * string list
 204     (* Run the command sequence and expect the output of the final
 205      * command to be the integer.
 206      *)
 207   | TestOutputInt of seq * int
 208     (* Run the command sequence and expect the output of the final
 209      * command to be <op> <int>, eg. ">=", "1".
 210      *)
 211   | TestOutputIntOp of seq * string * int
 212     (* Run the command sequence and expect the output of the final
 213      * command to be a true value (!= 0 or != NULL).
 214      *)
 215   | TestOutputTrue of seq
 216     (* Run the command sequence and expect the output of the final
 217      * command to be a false value (== 0 or == NULL, but not an error).
 218      *)
 219   | TestOutputFalse of seq
 220     (* Run the command sequence and expect the output of the final
 221      * command to be a list of the given length (but don't care about
 222      * content).
 223      *)
 224   | TestOutputLength of seq * int
 225     (* Run the command sequence and expect the output of the final
 226      * command to be a structure.
 227      *)
 228   | TestOutputStruct of seq * test_field_compare list
 229     (* Run the command sequence and expect the final command (only)
 230      * to fail.
 231      *)
 232   | TestLastFail of seq
 233
 234 and test_field_compare =
 235   | CompareWithInt of string * int
 236   | CompareWithIntOp of string * string * int
 237   | CompareWithString of string * string
 238   | CompareFieldsIntEq of string * string
 239   | CompareFieldsStrEq of string * string
 240
 241 (* Test prerequisites. *)
 242 and test_prereq =
 243     (* Test always runs. *)
 244   | Always
 245     (* Test is currently disabled - eg. it fails, or it tests some
 246      * unimplemented feature.
 247      *)
 248   | Disabled
 249     (* 'string' is some C code (a function body) that should return
 250      * true or false.  The test will run if the code returns true.
 251      *)
 252   | If of string
 253     (* As for 'If' but the test runs _unless_ the code returns true. *)
 254   | Unless of string
 255
 256 (* Some initial scenarios for testing. *)
 257 and test_init =
 258     (* Do nothing, block devices could contain random stuff including
 259      * LVM PVs, and some filesystems might be mounted.  This is usually
 260      * a bad idea.
 261      *)
 262   | InitNone
 263     (* Block devices are empty and no filesystems are mounted. *)
 264   | InitEmpty
 265     (* /dev/sda contains a single partition /dev/sda1, which is formatted
 266      * as ext2, empty [except for lost+found] and mounted on /.
 267      * /dev/sdb and /dev/sdc may have random content.
 268      * No LVM.
 269      *)
 270   | InitBasicFS
 271     (* /dev/sda:
 272      *   /dev/sda1 (is a PV):
 273      *     /dev/VG/LV (size 8MB):
 274      *       formatted as ext2, empty [except for lost+found], mounted on /
 275      * /dev/sdb and /dev/sdc may have random content.
 276      *)
 277   | InitBasicFSonLVM
 278
 279 (* Sequence of commands for testing. *)
 280 and seq = cmd list
 281 and cmd = string list
 282
 283 (* Note about long descriptions: When referring to another
 284  * action, use the format C<guestfs_other> (ie. the full name of
 285  * the C function).  This will be replaced as appropriate in other
 286  * language bindings.
 287  *
 288  * Apart from that, long descriptions are just perldoc paragraphs.
 289  *)
 290
 291 (* These test functions are used in the language binding tests. *)
 292
 293 let test_all_args = [
 294   String "str";
 295   OptString "optstr";
 296   StringList "strlist";
 297   Bool "b";
 298   Int "integer";
 299   FileIn "filein";
 300   FileOut "fileout";
 301 ]
 302
 303 let test_all_rets = [
 304   (* except for RErr, which is tested thoroughly elsewhere *)
 305   "test0rint",         RInt "valout";
 306   "test0rint64",       RInt64 "valout";
 307   "test0rbool",        RBool "valout";
 308   "test0rconststring", RConstString "valout";
 309   "test0rstring",      RString "valout";
 310   "test0rstringlist",  RStringList "valout";
 311   "test0rstruct",      RStruct ("valout", "lvm_pv");
 312   "test0rstructlist",  RStructList ("valout", "lvm_pv");
 313   "test0rhashtable",   RHashtable "valout";
 314 ]
 315
 316 let test_functions = [
 317   ("test0", (RErr, test_all_args), -1, [NotInFish; NotInDocs],
 318    [],
 319    "internal test function - do not use",
 320    "\
 321 This is an internal test function which is used to test whether
 322 the automatically generated bindings can handle every possible
 323 parameter type correctly.
 324
 325 It echos the contents of each parameter to stdout.
 326
 327 You probably don't want to call this function.");
 328 ] @ List.flatten (
 329   List.map (
 330     fun (name, ret) ->
 331       [(name, (ret, [String "val"]), -1, [NotInFish; NotInDocs],
 332         [],
 333         "internal test function - do not use",
 334         "\
 335 This is an internal test function which is used to test whether
 336 the automatically generated bindings can handle every possible
 337 return type correctly.
 338
 339 It converts string C<val> to the return type.
 340
 341 You probably don't want to call this function.");
 342        (name ^ "err", (ret, []), -1, [NotInFish; NotInDocs],
 343         [],
 344         "internal test function - do not use",
 345         "\
 346 This is an internal test function which is used to test whether
 347 the automatically generated bindings can handle every possible
 348 return type correctly.
 349
 350 This function always returns an error.
 351
 352 You probably don't want to call this function.")]
 353   ) test_all_rets
 354 )
 355
 356 (* non_daemon_functions are any functions which don't get processed
 357  * in the daemon, eg. functions for setting and getting local
 358  * configuration values.
 359  *)
 360
 361 let non_daemon_functions = test_functions @ [
 362   ("launch", (RErr, []), -1, [FishAlias "run"; FishAction "launch"],
 363    [],
 364    "launch the qemu subprocess",
 365    "\
 366 Internally libguestfs is implemented by running a virtual machine
 367 using L<qemu(1)>.
 368
 369 You should call this after configuring the handle
 370 (eg. adding drives) but before performing any actions.");
 371
 372   ("wait_ready", (RErr, []), -1, [NotInFish],
 373    [],
 374    "wait until the qemu subprocess launches",
 375    "\
 376 Internally libguestfs is implemented by running a virtual machine
 377 using L<qemu(1)>.
 378
 379 You should call this after C<guestfs_launch> to wait for the launch
 380 to complete.");
 381
 382   ("kill_subprocess", (RErr, []), -1, [],
 383    [],
 384    "kill the qemu subprocess",
 385    "\
 386 This kills the qemu subprocess.  You should never need to call this.");
 387
 388   ("add_drive", (RErr, [String "filename"]), -1, [FishAlias "add"],
 389    [],
 390    "add an image to examine or modify",
 391    "\
 392 This function adds a virtual machine disk image C<filename> to the
 393 guest.  The first time you call this function, the disk appears as IDE
 394 disk 0 (C</dev/sda>) in the guest, the second time as C</dev/sdb>, and
 395 so on.
 396
 397 You don't necessarily need to be root when using libguestfs.  However
 398 you obviously do need sufficient permissions to access the filename
 399 for whatever operations you want to perform (ie. read access if you
 400 just want to read the image or write access if you want to modify the
 401 image).
 402
 403 This is equivalent to the qemu parameter
 404 C<-drive file=filename,cache=off,if=...>.
 405
 406 Note that this call checks for the existence of C<filename>.  This
 407 stops you from specifying other types of drive which are supported
 408 by qemu such as C<nbd:> and C<http:> URLs.  To specify those, use
 409 the general C<guestfs_config> call instead.");
 410
 411   ("add_cdrom", (RErr, [String "filename"]), -1, [FishAlias "cdrom"],
 412    [],
 413    "add a CD-ROM disk image to examine",
 414    "\
 415 This function adds a virtual CD-ROM disk image to the guest.
 416
 417 This is equivalent to the qemu parameter C<-cdrom filename>.
 418
 419 Note that this call checks for the existence of C<filename>.  This
 420 stops you from specifying other types of drive which are supported
 421 by qemu such as C<nbd:> and C<http:> URLs.  To specify those, use
 422 the general C<guestfs_config> call instead.");
 423
 424   ("add_drive_ro", (RErr, [String "filename"]), -1, [FishAlias "add-ro"],
 425    [],
 426    "add a drive in snapshot mode (read-only)",
 427    "\
 428 This adds a drive in snapshot mode, making it effectively
 429 read-only.
 430
 431 Note that writes to the device are allowed, and will be seen for
 432 the duration of the guestfs handle, but they are written
 433 to a temporary file which is discarded as soon as the guestfs
 434 handle is closed.  We don't currently have any method to enable
 435 changes to be committed, although qemu can support this.
 436
 437 This is equivalent to the qemu parameter
 438 C<-drive file=filename,snapshot=on,if=...>.
 439
 440 Note that this call checks for the existence of C<filename>.  This
 441 stops you from specifying other types of drive which are supported
 442 by qemu such as C<nbd:> and C<http:> URLs.  To specify those, use
 443 the general C<guestfs_config> call instead.");
 444
 445   ("config", (RErr, [String "qemuparam"; OptString "qemuvalue"]), -1, [],
 446    [],
 447    "add qemu parameters",
 448    "\
 449 This can be used to add arbitrary qemu command line parameters
 450 of the form C<-param value>.  Actually it's not quite arbitrary - we
 451 prevent you from setting some parameters which would interfere with
 452 parameters that we use.
 453
 454 The first character of C<param> string must be a C<-> (dash).
 455
 456 C<value> can be NULL.");
 457
 458   ("set_qemu", (RErr, [String "qemu"]), -1, [FishAlias "qemu"],
 459    [],
 460    "set the qemu binary",
 461    "\
 462 Set the qemu binary that we will use.
 463
 464 The default is chosen when the library was compiled by the
 465 configure script.
 466
 467 You can also override this by setting the C<LIBGUESTFS_QEMU>
 468 environment variable.
 469
 470 Setting C<qemu> to C<NULL> restores the default qemu binary.");
 471
 472   ("get_qemu", (RConstString "qemu", []), -1, [],
 473    [InitNone, Always, TestRun (
 474       [["get_qemu"]])],
 475    "get the qemu binary",
 476    "\
 477 Return the current qemu binary.
 478
 479 This is always non-NULL.  If it wasn't set already, then this will
 480 return the default qemu binary name.");
 481
 482   ("set_path", (RErr, [String "path"]), -1, [FishAlias "path"],
 483    [],
 484    "set the search path",
 485    "\
 486 Set the path that libguestfs searches for kernel and initrd.img.
 487
 488 The default is C<$libdir/guestfs> unless overridden by setting
 489 C<LIBGUESTFS_PATH> environment variable.
 490
 491 Setting C<path> to C<NULL> restores the default path.");
 492
 493   ("get_path", (RConstString "path", []), -1, [],
 494    [InitNone, Always, TestRun (
 495       [["get_path"]])],
 496    "get the search path",
 497    "\
 498 Return the current search path.
 499
 500 This is always non-NULL.  If it wasn't set already, then this will
 501 return the default path.");
 502
 503   ("set_append", (RErr, [String "append"]), -1, [FishAlias "append"],
 504    [],
 505    "add options to kernel command line",
 506    "\
 507 This function is used to add additional options to the
 508 guest kernel command line.
 509
 510 The default is C<NULL> unless overridden by setting
 511 C<LIBGUESTFS_APPEND> environment variable.
 512
 513 Setting C<append> to C<NULL> means I<no> additional options
 514 are passed (libguestfs always adds a few of its own).");
 515
 516   ("get_append", (RConstString "append", []), -1, [],
 517    (* This cannot be tested with the current framework.  The
 518     * function can return NULL in normal operations, which the
 519     * test framework interprets as an error.
 520     *)
 521    [],
 522    "get the additional kernel options",
 523    "\
 524 Return the additional kernel options which are added to the
 525 guest kernel command line.
 526
 527 If C<NULL> then no options are added.");
 528
 529   ("set_autosync", (RErr, [Bool "autosync"]), -1, [FishAlias "autosync"],
 530    [],
 531    "set autosync mode",
 532    "\
 533 If C<autosync> is true, this enables autosync.  Libguestfs will make a
 534 best effort attempt to run C<guestfs_umount_all> followed by
 535 C<guestfs_sync> when the handle is closed
 536 (also if the program exits without closing handles).
 537
 538 This is disabled by default (except in guestfish where it is
 539 enabled by default).");
 540
 541   ("get_autosync", (RBool "autosync", []), -1, [],
 542    [InitNone, Always, TestRun (
 543       [["get_autosync"]])],
 544    "get autosync mode",
 545    "\
 546 Get the autosync flag.");
 547
 548   ("set_verbose", (RErr, [Bool "verbose"]), -1, [FishAlias "verbose"],
 549    [],
 550    "set verbose mode",
 551    "\
 552 If C<verbose> is true, this turns on verbose messages (to C<stderr>).
 553
 554 Verbose messages are disabled unless the environment variable
 555 C<LIBGUESTFS_DEBUG> is defined and set to C<1>.");
 556
 557   ("get_verbose", (RBool "verbose", []), -1, [],
 558    [],
 559    "get verbose mode",
 560    "\
 561 This returns the verbose messages flag.");
 562
 563   ("is_ready", (RBool "ready", []), -1, [],
 564    [InitNone, Always, TestOutputTrue (
 565       [["is_ready"]])],
 566    "is ready to accept commands",
 567    "\
 568 This returns true iff this handle is ready to accept commands
 569 (in the C<READY> state).
 570
 571 For more information on states, see L<guestfs(3)>.");
 572
 573   ("is_config", (RBool "config", []), -1, [],
 574    [InitNone, Always, TestOutputFalse (
 575       [["is_config"]])],
 576    "is in configuration state",
 577    "\
 578 This returns true iff this handle is being configured
 579 (in the C<CONFIG> state).
 580
 581 For more information on states, see L<guestfs(3)>.");
 582
 583   ("is_launching", (RBool "launching", []), -1, [],
 584    [InitNone, Always, TestOutputFalse (
 585       [["is_launching"]])],
 586    "is launching subprocess",
 587    "\
 588 This returns true iff this handle is launching the subprocess
 589 (in the C<LAUNCHING> state).
 590
 591 For more information on states, see L<guestfs(3)>.");
 592
 593   ("is_busy", (RBool "busy", []), -1, [],
 594    [InitNone, Always, TestOutputFalse (
 595       [["is_busy"]])],
 596    "is busy processing a command",
 597    "\
 598 This returns true iff this handle is busy processing a command
 599 (in the C<BUSY> state).
 600
 601 For more information on states, see L<guestfs(3)>.");
 602
 603   ("get_state", (RInt "state", []), -1, [],
 604    [],
 605    "get the current state",
 606    "\
 607 This returns the current state as an opaque integer.  This is
 608 only useful for printing debug and internal error messages.
 609
 610 For more information on states, see L<guestfs(3)>.");
 611
 612   ("set_busy", (RErr, []), -1, [NotInFish],
 613    [],
 614    "set state to busy",
 615    "\
 616 This sets the state to C<BUSY>.  This is only used when implementing
 617 actions using the low-level API.
 618
 619 For more information on states, see L<guestfs(3)>.");
 620
 621   ("set_ready", (RErr, []), -1, [NotInFish],
 622    [],
 623    "set state to ready",
 624    "\
 625 This sets the state to C<READY>.  This is only used when implementing
 626 actions using the low-level API.
 627
 628 For more information on states, see L<guestfs(3)>.");
 629
 630   ("end_busy", (RErr, []), -1, [NotInFish],
 631    [],
 632    "leave the busy state",
 633    "\
 634 This sets the state to C<READY>, or if in C<CONFIG> then it leaves the
 635 state as is.  This is only used when implementing
 636 actions using the low-level API.
 637
 638 For more information on states, see L<guestfs(3)>.");
 639
 640   ("set_memsize", (RErr, [Int "memsize"]), -1, [FishAlias "memsize"],
 641    [InitNone, Always, TestOutputInt (
 642       [["set_memsize"; "500"];
 643        ["get_memsize"]], 500)],
 644    "set memory allocated to the qemu subprocess",
 645    "\
 646 This sets the memory size in megabytes allocated to the
 647 qemu subprocess.  This only has any effect if called before
 648 C<guestfs_launch>.
 649
 650 You can also change this by setting the environment
 651 variable C<LIBGUESTFS_MEMSIZE> before the handle is
 652 created.
 653
 654 For more information on the architecture of libguestfs,
 655 see L<guestfs(3)>.");
 656
 657   ("get_memsize", (RInt "memsize", []), -1, [],
 658    [InitNone, Always, TestOutputIntOp (
 659       [["get_memsize"]], ">=", 256)],
 660    "get memory allocated to the qemu subprocess",
 661    "\
 662 This gets the memory size in megabytes allocated to the
 663 qemu subprocess.
 664
 665 If C<guestfs_set_memsize> was not called
 666 on this handle, and if C<LIBGUESTFS_MEMSIZE> was not set,
 667 then this returns the compiled-in default value for memsize.
 668
 669 For more information on the architecture of libguestfs,
 670 see L<guestfs(3)>.");
 671
 672   ("get_pid", (RInt "pid", []), -1, [FishAlias "pid"],
 673    [InitNone, Always, TestOutputIntOp (
 674       [["get_pid"]], ">=", 1)],
 675    "get PID of qemu subprocess",
 676    "\
 677 Return the process ID of the qemu subprocess.  If there is no
 678 qemu subprocess, then this will return an error.
 679
 680 This is an internal call used for debugging and testing.");
 681
 682   ("version", (RStruct ("version", "version"), []), -1, [],
 683    [InitNone, Always, TestOutputStruct (
 684       [["version"]], [CompareWithInt ("major", 1)])],
 685    "get the library version number",
 686    "\
 687 Return the libguestfs version number that the program is linked
 688 against.
 689
 690 Note that because of dynamic linking this is not necessarily
 691 the version of libguestfs that you compiled against.  You can
 692 compile the program, and then at runtime dynamically link
 693 against a completely different C<libguestfs.so> library.
 694
 695 This call was added in version C<1.0.58>.  In previous
 696 versions of libguestfs there was no way to get the version
 697 number.  From C code you can use ELF weak linking tricks to find out if
 698 this symbol exists (if it doesn't, then it's an earlier version).
 699
 700 The call returns a structure with four elements.  The first
 701 three (C<major>, C<minor> and C<release>) are numbers and
 702 correspond to the usual version triplet.  The fourth element
 703 (C<extra>) is a string and is normally empty, but may be
 704 used for distro-specific information.
 705
 706 To construct the original version string:
 707 C<$major.$minor.$release$extra>
 708
 709 I<Note:> Don't use this call to test for availability
 710 of features.  Distro backports makes this unreliable.");
 711
 712 ]
 713
 714 (* daemon_functions are any functions which cause some action
 715  * to take place in the daemon.
 716  *)
 717
 718 let daemon_functions = [
 719   ("mount", (RErr, [String "device"; String "mountpoint"]), 1, [],
 720    [InitEmpty, Always, TestOutput (
 721       [["sfdiskM"; "/dev/sda"; ","];
 722        ["mkfs"; "ext2"; "/dev/sda1"];
 723        ["mount"; "/dev/sda1"; "/"];
 724        ["write_file"; "/new"; "new file contents"; "0"];
 725        ["cat"; "/new"]], "new file contents")],
 726    "mount a guest disk at a position in the filesystem",
 727    "\
 728 Mount a guest disk at a position in the filesystem.  Block devices
 729 are named C</dev/sda>, C</dev/sdb> and so on, as they were added to
 730 the guest.  If those block devices contain partitions, they will have
 731 the usual names (eg. C</dev/sda1>).  Also LVM C</dev/VG/LV>-style
 732 names can be used.
 733
 734 The rules are the same as for L<mount(2)>:  A filesystem must
 735 first be mounted on C</> before others can be mounted.  Other
 736 filesystems can only be mounted on directories which already
 737 exist.
 738
 739 The mounted filesystem is writable, if we have sufficient permissions
 740 on the underlying device.
 741
 742 The filesystem options C<sync> and C<noatime> are set with this
 743 call, in order to improve reliability.");
 744
 745   ("sync", (RErr, []), 2, [],
 746    [ InitEmpty, Always, TestRun [["sync"]]],
 747    "sync disks, writes are flushed through to the disk image",
 748    "\
 749 This syncs the disk, so that any writes are flushed through to the
 750 underlying disk image.
 751
 752 You should always call this if you have modified a disk image, before
 753 closing the handle.");
 754
 755   ("touch", (RErr, [String "path"]), 3, [],
 756    [InitBasicFS, Always, TestOutputTrue (
 757       [["touch"; "/new"];
 758        ["exists"; "/new"]])],
 759    "update file timestamps or create a new file",
 760    "\
 761 Touch acts like the L<touch(1)> command.  It can be used to
 762 update the timestamps on a file, or, if the file does not exist,
 763 to create a new zero-length file.");
 764
 765   ("cat", (RString "content", [String "path"]), 4, [ProtocolLimitWarning],
 766    [InitBasicFS, Always, TestOutput (
 767       [["write_file"; "/new"; "new file contents"; "0"];
 768        ["cat"; "/new"]], "new file contents")],
 769    "list the contents of a file",
 770    "\
 771 Return the contents of the file named C<path>.
 772
 773 Note that this function cannot correctly handle binary files
 774 (specifically, files containing C<\\0> character which is treated
 775 as end of string).  For those you need to use the C<guestfs_download>
 776 function which has a more complex interface.");
 777
 778   ("ll", (RString "listing", [String "directory"]), 5, [],
 779    [], (* XXX Tricky to test because it depends on the exact format
 780         * of the 'ls -l' command, which changes between F10 and F11.
 781         *)
 782    "list the files in a directory (long format)",
 783    "\
 784 List the files in C<directory> (relative to the root directory,
 785 there is no cwd) in the format of 'ls -la'.
 786
 787 This command is mostly useful for interactive sessions.  It
 788 is I<not> intended that you try to parse the output string.");
 789
 790   ("ls", (RStringList "listing", [String "directory"]), 6, [],
 791    [InitBasicFS, Always, TestOutputList (
 792       [["touch"; "/new"];
 793        ["touch"; "/newer"];
 794        ["touch"; "/newest"];
 795        ["ls"; "/"]], ["lost+found"; "new"; "newer"; "newest"])],
 796    "list the files in a directory",
 797    "\
 798 List the files in C<directory> (relative to the root directory,
 799 there is no cwd).  The '.' and '..' entries are not returned, but
 800 hidden files are shown.
 801
 802 This command is mostly useful for interactive sessions.  Programs
 803 should probably use C<guestfs_readdir> instead.");
 804
 805   ("list_devices", (RStringList "devices", []), 7, [],
 806    [InitEmpty, Always, TestOutputListOfDevices (
 807       [["list_devices"]], ["/dev/sda"; "/dev/sdb"; "/dev/sdc"; "/dev/sdd"])],
 808    "list the block devices",
 809    "\
 810 List all the block devices.
 811
 812 The full block device names are returned, eg. C</dev/sda>");
 813
 814   ("list_partitions", (RStringList "partitions", []), 8, [],
 815    [InitBasicFS, Always, TestOutputListOfDevices (
 816       [["list_partitions"]], ["/dev/sda1"]);
 817     InitEmpty, Always, TestOutputListOfDevices (
 818       [["sfdiskM"; "/dev/sda"; ",100 ,200 ,"];
 819        ["list_partitions"]], ["/dev/sda1"; "/dev/sda2"; "/dev/sda3"])],
 820    "list the partitions",
 821    "\
 822 List all the partitions detected on all block devices.
 823
 824 The full partition device names are returned, eg. C</dev/sda1>
 825
 826 This does not return logical volumes.  For that you will need to
 827 call C<guestfs_lvs>.");
 828
 829   ("pvs", (RStringList "physvols", []), 9, [],
 830    [InitBasicFSonLVM, Always, TestOutputListOfDevices (
 831       [["pvs"]], ["/dev/sda1"]);
 832     InitEmpty, Always, TestOutputListOfDevices (
 833       [["sfdiskM"; "/dev/sda"; ",100 ,200 ,"];
 834        ["pvcreate"; "/dev/sda1"];
 835        ["pvcreate"; "/dev/sda2"];
 836        ["pvcreate"; "/dev/sda3"];
 837        ["pvs"]], ["/dev/sda1"; "/dev/sda2"; "/dev/sda3"])],
 838    "list the LVM physical volumes (PVs)",
 839    "\
 840 List all the physical volumes detected.  This is the equivalent
 841 of the L<pvs(8)> command.
 842
 843 This returns a list of just the device names that contain
 844 PVs (eg. C</dev/sda2>).
 845
 846 See also C<guestfs_pvs_full>.");
 847
 848   ("vgs", (RStringList "volgroups", []), 10, [],
 849    [InitBasicFSonLVM, Always, TestOutputList (
 850       [["vgs"]], ["VG"]);
 851     InitEmpty, Always, TestOutputList (
 852       [["sfdiskM"; "/dev/sda"; ",100 ,200 ,"];
 853        ["pvcreate"; "/dev/sda1"];
 854        ["pvcreate"; "/dev/sda2"];
 855        ["pvcreate"; "/dev/sda3"];
 856        ["vgcreate"; "VG1"; "/dev/sda1 /dev/sda2"];
 857        ["vgcreate"; "VG2"; "/dev/sda3"];
 858        ["vgs"]], ["VG1"; "VG2"])],
 859    "list the LVM volume groups (VGs)",
 860    "\
 861 List all the volumes groups detected.  This is the equivalent
 862 of the L<vgs(8)> command.
 863
 864 This returns a list of just the volume group names that were
 865 detected (eg. C<VolGroup00>).
 866
 867 See also C<guestfs_vgs_full>.");
 868
 869   ("lvs", (RStringList "logvols", []), 11, [],
 870    [InitBasicFSonLVM, Always, TestOutputList (
 871       [["lvs"]], ["/dev/VG/LV"]);
 872     InitEmpty, Always, TestOutputList (
 873       [["sfdiskM"; "/dev/sda"; ",100 ,200 ,"];
 874        ["pvcreate"; "/dev/sda1"];
 875        ["pvcreate"; "/dev/sda2"];
 876        ["pvcreate"; "/dev/sda3"];
 877        ["vgcreate"; "VG1"; "/dev/sda1 /dev/sda2"];
 878        ["vgcreate"; "VG2"; "/dev/sda3"];
 879        ["lvcreate"; "LV1"; "VG1"; "50"];
 880        ["lvcreate"; "LV2"; "VG1"; "50"];
 881        ["lvcreate"; "LV3"; "VG2"; "50"];
 882        ["lvs"]], ["/dev/VG1/LV1"; "/dev/VG1/LV2"; "/dev/VG2/LV3"])],
 883    "list the LVM logical volumes (LVs)",
 884    "\
 885 List all the logical volumes detected.  This is the equivalent
 886 of the L<lvs(8)> command.
 887
 888 This returns a list of the logical volume device names
 889 (eg. C</dev/VolGroup00/LogVol00>).
 890
 891 See also C<guestfs_lvs_full>.");
 892
 893   ("pvs_full", (RStructList ("physvols", "lvm_pv"), []), 12, [],
 894    [], (* XXX how to test? *)
 895    "list the LVM physical volumes (PVs)",
 896    "\
 897 List all the physical volumes detected.  This is the equivalent
 898 of the L<pvs(8)> command.  The \"full\" version includes all fields.");
 899
 900   ("vgs_full", (RStructList ("volgroups", "lvm_vg"), []), 13, [],
 901    [], (* XXX how to test? *)
 902    "list the LVM volume groups (VGs)",
 903    "\
 904 List all the volumes groups detected.  This is the equivalent
 905 of the L<vgs(8)> command.  The \"full\" version includes all fields.");
 906
 907   ("lvs_full", (RStructList ("logvols", "lvm_lv"), []), 14, [],
 908    [], (* XXX how to test? *)
 909    "list the LVM logical volumes (LVs)",
 910    "\
 911 List all the logical volumes detected.  This is the equivalent
 912 of the L<lvs(8)> command.  The \"full\" version includes all fields.");
 913
 914   ("read_lines", (RStringList "lines", [String "path"]), 15, [],
 915    [InitBasicFS, Always, TestOutputList (
 916       [["write_file"; "/new"; "line1\r\nline2\nline3"; "0"];
 917        ["read_lines"; "/new"]], ["line1"; "line2"; "line3"]);
 918     InitBasicFS, Always, TestOutputList (
 919       [["write_file"; "/new"; ""; "0"];
 920        ["read_lines"; "/new"]], [])],
 921    "read file as lines",
 922    "\
 923 Return the contents of the file named C<path>.
 924
 925 The file contents are returned as a list of lines.  Trailing
 926 C<LF> and C<CRLF> character sequences are I<not> returned.
 927
 928 Note that this function cannot correctly handle binary files
 929 (specifically, files containing C<\\0> character which is treated
 930 as end of line).  For those you need to use the C<guestfs_read_file>
 931 function which has a more complex interface.");
 932
 933   ("aug_init", (RErr, [String "root"; Int "flags"]), 16, [],
 934    [], (* XXX Augeas code needs tests. *)
 935    "create a new Augeas handle",
 936    "\
 937 Create a new Augeas handle for editing configuration files.
 938 If there was any previous Augeas handle associated with this
 939 guestfs session, then it is closed.
 940
 941 You must call this before using any other C<guestfs_aug_*>
 942 commands.
 943
 944 C<root> is the filesystem root.  C<root> must not be NULL,
 945 use C</> instead.
 946
 947 The flags are the same as the flags defined in
 948 E<lt>augeas.hE<gt>, the logical I<or> of the following
 949 integers:
 950
 951 =over 4
 952
 953 =item C<AUG_SAVE_BACKUP> = 1
 954
 955 Keep the original file with a C<.augsave> extension.
 956
 957 =item C<AUG_SAVE_NEWFILE> = 2
 958
 959 Save changes into a file with extension C<.augnew>, and
 960 do not overwrite original.  Overrides C<AUG_SAVE_BACKUP>.
 961
 962 =item C<AUG_TYPE_CHECK> = 4
 963
 964 Typecheck lenses (can be expensive).
 965
 966 =item C<AUG_NO_STDINC> = 8
 967
 968 Do not use standard load path for modules.
 969
 970 =item C<AUG_SAVE_NOOP> = 16
 971
 972 Make save a no-op, just record what would have been changed.
 973
 974 =item C<AUG_NO_LOAD> = 32
 975
 976 Do not load the tree in C<guestfs_aug_init>.
 977
 978 =back
 979
 980 To close the handle, you can call C<guestfs_aug_close>.
 981
 982 To find out more about Augeas, see L<http://augeas.net/>.");
 983
 984   ("aug_close", (RErr, []), 26, [],
 985    [], (* XXX Augeas code needs tests. *)
 986    "close the current Augeas handle",
 987    "\
 988 Close the current Augeas handle and free up any resources
 989 used by it.  After calling this, you have to call
 990 C<guestfs_aug_init> again before you can use any other
 991 Augeas functions.");
 992
 993   ("aug_defvar", (RInt "nrnodes", [String "name"; OptString "expr"]), 17, [],
 994    [], (* XXX Augeas code needs tests. *)
 995    "define an Augeas variable",
 996    "\
 997 Defines an Augeas variable C<name> whose value is the result
 998 of evaluating C<expr>.  If C<expr> is NULL, then C<name> is
 999 undefined.
1000
1001 On success this returns the number of nodes in C<expr>, or
1002 C<0> if C<expr> evaluates to something which is not a nodeset.");
1003
1004   ("aug_defnode", (RStruct ("nrnodescreated", "int_bool"), [String "name"; String "expr"; String "val"]), 18, [],
1005    [], (* XXX Augeas code needs tests. *)
1006    "define an Augeas node",
1007    "\
1008 Defines a variable C<name> whose value is the result of
1009 evaluating C<expr>.
1010
1011 If C<expr> evaluates to an empty nodeset, a node is created,
1012 equivalent to calling C<guestfs_aug_set> C<expr>, C<value>.
1013 C<name> will be the nodeset containing that single node.
1014
1015 On success this returns a pair containing the
1016 number of nodes in the nodeset, and a boolean flag
1017 if a node was created.");
1018
1019   ("aug_get", (RString "val", [String "path"]), 19, [],
1020    [], (* XXX Augeas code needs tests. *)
1021    "look up the value of an Augeas path",
1022    "\
1023 Look up the value associated with C<path>.  If C<path>
1024 matches exactly one node, the C<value> is returned.");
1025
1026   ("aug_set", (RErr, [String "path"; String "val"]), 20, [],
1027    [], (* XXX Augeas code needs tests. *)
1028    "set Augeas path to value",
1029    "\
1030 Set the value associated with C<path> to C<value>.");
1031
1032   ("aug_insert", (RErr, [String "path"; String "label"; Bool "before"]), 21, [],
1033    [], (* XXX Augeas code needs tests. *)
1034    "insert a sibling Augeas node",
1035    "\
1036 Create a new sibling C<label> for C<path>, inserting it into
1037 the tree before or after C<path> (depending on the boolean
1038 flag C<before>).
1039
1040 C<path> must match exactly one existing node in the tree, and
1041 C<label> must be a label, ie. not contain C</>, C<*> or end
1042 with a bracketed index C<[N]>.");
1043
1044   ("aug_rm", (RInt "nrnodes", [String "path"]), 22, [],
1045    [], (* XXX Augeas code needs tests. *)
1046    "remove an Augeas path",
1047    "\
1048 Remove C<path> and all of its children.
1049
1050 On success this returns the number of entries which were removed.");
1051
1052   ("aug_mv", (RErr, [String "src"; String "dest"]), 23, [],
1053    [], (* XXX Augeas code needs tests. *)
1054    "move Augeas node",
1055    "\
1056 Move the node C<src> to C<dest>.  C<src> must match exactly
1057 one node.  C<dest> is overwritten if it exists.");
1058
1059   ("aug_match", (RStringList "matches", [String "path"]), 24, [],
1060    [], (* XXX Augeas code needs tests. *)
1061    "return Augeas nodes which match path",
1062    "\
1063 Returns a list of paths which match the path expression C<path>.
1064 The returned paths are sufficiently qualified so that they match
1065 exactly one node in the current tree.");
1066
1067   ("aug_save", (RErr, []), 25, [],
1068    [], (* XXX Augeas code needs tests. *)
1069    "write all pending Augeas changes to disk",
1070    "\
1071 This writes all pending changes to disk.
1072
1073 The flags which were passed to C<guestfs_aug_init> affect exactly
1074 how files are saved.");
1075
1076   ("aug_load", (RErr, []), 27, [],
1077    [], (* XXX Augeas code needs tests. *)
1078    "load files into the tree",
1079    "\
1080 Load files into the tree.
1081
1082 See C<aug_load> in the Augeas documentation for the full gory
1083 details.");
1084
1085   ("aug_ls", (RStringList "matches", [String "path"]), 28, [],
1086    [], (* XXX Augeas code needs tests. *)
1087    "list Augeas nodes under a path",
1088    "\
1089 This is just a shortcut for listing C<guestfs_aug_match>
1090 C<path/*> and sorting the resulting nodes into alphabetical order.");
1091
1092   ("rm", (RErr, [String "path"]), 29, [],
1093    [InitBasicFS, Always, TestRun
1094       [["touch"; "/new"];
1095        ["rm"; "/new"]];
1096     InitBasicFS, Always, TestLastFail
1097       [["rm"; "/new"]];
1098     InitBasicFS, Always, TestLastFail
1099       [["mkdir"; "/new"];
1100        ["rm"; "/new"]]],
1101    "remove a file",
1102    "\
1103 Remove the single file C<path>.");
1104
1105   ("rmdir", (RErr, [String "path"]), 30, [],
1106    [InitBasicFS, Always, TestRun
1107       [["mkdir"; "/new"];
1108        ["rmdir"; "/new"]];
1109     InitBasicFS, Always, TestLastFail
1110       [["rmdir"; "/new"]];
1111     InitBasicFS, Always, TestLastFail
1112       [["touch"; "/new"];
1113        ["rmdir"; "/new"]]],
1114    "remove a directory",
1115    "\
1116 Remove the single directory C<path>.");
1117
1118   ("rm_rf", (RErr, [String "path"]), 31, [],
1119    [InitBasicFS, Always, TestOutputFalse
1120       [["mkdir"; "/new"];
1121        ["mkdir"; "/new/foo"];
1122        ["touch"; "/new/foo/bar"];
1123        ["rm_rf"; "/new"];
1124        ["exists"; "/new"]]],
1125    "remove a file or directory recursively",
1126    "\
1127 Remove the file or directory C<path>, recursively removing the
1128 contents if its a directory.  This is like the C<rm -rf> shell
1129 command.");
1130
1131   ("mkdir", (RErr, [String "path"]), 32, [],
1132    [InitBasicFS, Always, TestOutputTrue
1133       [["mkdir"; "/new"];
1134        ["is_dir"; "/new"]];
1135     InitBasicFS, Always, TestLastFail
1136       [["mkdir"; "/new/foo/bar"]]],
1137    "create a directory",
1138    "\
1139 Create a directory named C<path>.");
1140
1141   ("mkdir_p", (RErr, [String "path"]), 33, [],
1142    [InitBasicFS, Always, TestOutputTrue
1143       [["mkdir_p"; "/new/foo/bar"];
1144        ["is_dir"; "/new/foo/bar"]];
1145     InitBasicFS, Always, TestOutputTrue
1146       [["mkdir_p"; "/new/foo/bar"];
1147        ["is_dir"; "/new/foo"]];
1148     InitBasicFS, Always, TestOutputTrue
1149       [["mkdir_p"; "/new/foo/bar"];
1150        ["is_dir"; "/new"]];
1151     (* Regression tests for RHBZ#503133: *)
1152     InitBasicFS, Always, TestRun
1153       [["mkdir"; "/new"];
1154        ["mkdir_p"; "/new"]];
1155     InitBasicFS, Always, TestLastFail
1156       [["touch"; "/new"];
1157        ["mkdir_p"; "/new"]]],
1158    "create a directory and parents",
1159    "\
1160 Create a directory named C<path>, creating any parent directories
1161 as necessary.  This is like the C<mkdir -p> shell command.");
1162
1163   ("chmod", (RErr, [Int "mode"; String "path"]), 34, [],
1164    [], (* XXX Need stat command to test *)
1165    "change file mode",
1166    "\
1167 Change the mode (permissions) of C<path> to C<mode>.  Only
1168 numeric modes are supported.");
1169
1170   ("chown", (RErr, [Int "owner"; Int "group"; String "path"]), 35, [],
1171    [], (* XXX Need stat command to test *)
1172    "change file owner and group",
1173    "\
1174 Change the file owner to C<owner> and group to C<group>.
1175
1176 Only numeric uid and gid are supported.  If you want to use
1177 names, you will need to locate and parse the password file
1178 yourself (Augeas support makes this relatively easy).");
1179
1180   ("exists", (RBool "existsflag", [String "path"]), 36, [],
1181    [InitBasicFS, Always, TestOutputTrue (
1182       [["touch"; "/new"];
1183        ["exists"; "/new"]]);
1184     InitBasicFS, Always, TestOutputTrue (
1185       [["mkdir"; "/new"];
1186        ["exists"; "/new"]])],
1187    "test if file or directory exists",
1188    "\
1189 This returns C<true> if and only if there is a file, directory
1190 (or anything) with the given C<path> name.
1191
1192 See also C<guestfs_is_file>, C<guestfs_is_dir>, C<guestfs_stat>.");
1193
1194   ("is_file", (RBool "fileflag", [String "path"]), 37, [],
1195    [InitBasicFS, Always, TestOutputTrue (
1196       [["touch"; "/new"];
1197        ["is_file"; "/new"]]);
1198     InitBasicFS, Always, TestOutputFalse (
1199       [["mkdir"; "/new"];
1200        ["is_file"; "/new"]])],
1201    "test if file exists",
1202    "\
1203 This returns C<true> if and only if there is a file
1204 with the given C<path> name.  Note that it returns false for
1205 other objects like directories.
1206
1207 See also C<guestfs_stat>.");
1208
1209   ("is_dir", (RBool "dirflag", [String "path"]), 38, [],
1210    [InitBasicFS, Always, TestOutputFalse (
1211       [["touch"; "/new"];
1212        ["is_dir"; "/new"]]);
1213     InitBasicFS, Always, TestOutputTrue (
1214       [["mkdir"; "/new"];
1215        ["is_dir"; "/new"]])],
1216    "test if file exists",
1217    "\
1218 This returns C<true> if and only if there is a directory
1219 with the given C<path> name.  Note that it returns false for
1220 other objects like files.
1221
1222 See also C<guestfs_stat>.");
1223
1224   ("pvcreate", (RErr, [String "device"]), 39, [],
1225    [InitEmpty, Always, TestOutputListOfDevices (
1226       [["sfdiskM"; "/dev/sda"; ",100 ,200 ,"];
1227        ["pvcreate"; "/dev/sda1"];
1228        ["pvcreate"; "/dev/sda2"];
1229        ["pvcreate"; "/dev/sda3"];
1230        ["pvs"]], ["/dev/sda1"; "/dev/sda2"; "/dev/sda3"])],
1231    "create an LVM physical volume",
1232    "\
1233 This creates an LVM physical volume on the named C<device>,
1234 where C<device> should usually be a partition name such
1235 as C</dev/sda1>.");
1236
1237   ("vgcreate", (RErr, [String "volgroup"; StringList "physvols"]), 40, [],
1238    [InitEmpty, Always, TestOutputList (
1239       [["sfdiskM"; "/dev/sda"; ",100 ,200 ,"];
1240        ["pvcreate"; "/dev/sda1"];
1241        ["pvcreate"; "/dev/sda2"];
1242        ["pvcreate"; "/dev/sda3"];
1243        ["vgcreate"; "VG1"; "/dev/sda1 /dev/sda2"];
1244        ["vgcreate"; "VG2"; "/dev/sda3"];
1245        ["vgs"]], ["VG1"; "VG2"])],
1246    "create an LVM volume group",
1247    "\
1248 This creates an LVM volume group called C<volgroup>
1249 from the non-empty list of physical volumes C<physvols>.");
1250
1251   ("lvcreate", (RErr, [String "logvol"; String "volgroup"; Int "mbytes"]), 41, [],
1252    [InitEmpty, Always, TestOutputList (
1253       [["sfdiskM"; "/dev/sda"; ",100 ,200 ,"];
1254        ["pvcreate"; "/dev/sda1"];
1255        ["pvcreate"; "/dev/sda2"];
1256        ["pvcreate"; "/dev/sda3"];
1257        ["vgcreate"; "VG1"; "/dev/sda1 /dev/sda2"];
1258        ["vgcreate"; "VG2"; "/dev/sda3"];
1259        ["lvcreate"; "LV1"; "VG1"; "50"];
1260        ["lvcreate"; "LV2"; "VG1"; "50"];
1261        ["lvcreate"; "LV3"; "VG2"; "50"];
1262        ["lvcreate"; "LV4"; "VG2"; "50"];
1263        ["lvcreate"; "LV5"; "VG2"; "50"];
1264        ["lvs"]],
1265       ["/dev/VG1/LV1"; "/dev/VG1/LV2";
1266        "/dev/VG2/LV3"; "/dev/VG2/LV4"; "/dev/VG2/LV5"])],
1267    "create an LVM volume group",
1268    "\
1269 This creates an LVM volume group called C<logvol>
1270 on the volume group C<volgroup>, with C<size> megabytes.");
1271
1272   ("mkfs", (RErr, [String "fstype"; String "device"]), 42, [],
1273    [InitEmpty, Always, TestOutput (
1274       [["sfdiskM"; "/dev/sda"; ","];
1275        ["mkfs"; "ext2"; "/dev/sda1"];
1276        ["mount"; "/dev/sda1"; "/"];
1277        ["write_file"; "/new"; "new file contents"; "0"];
1278        ["cat"; "/new"]], "new file contents")],
1279    "make a filesystem",
1280    "\
1281 This creates a filesystem on C<device> (usually a partition
1282 or LVM logical volume).  The filesystem type is C<fstype>, for
1283 example C<ext3>.");
1284
1285   ("sfdisk", (RErr, [String "device";
1286                      Int "cyls"; Int "heads"; Int "sectors";
1287                      StringList "lines"]), 43, [DangerWillRobinson],
1288    [],
1289    "create partitions on a block device",
1290    "\
1291 This is a direct interface to the L<sfdisk(8)> program for creating
1292 partitions on block devices.
1293
1294 C<device> should be a block device, for example C</dev/sda>.
1295
1296 C<cyls>, C<heads> and C<sectors> are the number of cylinders, heads
1297 and sectors on the device, which are passed directly to sfdisk as
1298 the I<-C>, I<-H> and I<-S> parameters.  If you pass C<0> for any
1299 of these, then the corresponding parameter is omitted.  Usually for
1300 'large' disks, you can just pass C<0> for these, but for small
1301 (floppy-sized) disks, sfdisk (or rather, the kernel) cannot work
1302 out the right geometry and you will need to tell it.
1303
1304 C<lines> is a list of lines that we feed to C<sfdisk>.  For more
1305 information refer to the L<sfdisk(8)> manpage.
1306
1307 To create a single partition occupying the whole disk, you would
1308 pass C<lines> as a single element list, when the single element being
1309 the string C<,> (comma).
1310
1311 See also: C<guestfs_sfdisk_l>, C<guestfs_sfdisk_N>");
1312
1313   ("write_file", (RErr, [String "path"; String "content"; Int "size"]), 44, [ProtocolLimitWarning],
1314    [InitBasicFS, Always, TestOutput (
1315       [["write_file"; "/new"; "new file contents"; "0"];
1316        ["cat"; "/new"]], "new file contents");
1317     InitBasicFS, Always, TestOutput (
1318       [["write_file"; "/new"; "\nnew file contents\n"; "0"];
1319        ["cat"; "/new"]], "\nnew file contents\n");
1320     InitBasicFS, Always, TestOutput (
1321       [["write_file"; "/new"; "\n\n"; "0"];
1322        ["cat"; "/new"]], "\n\n");
1323     InitBasicFS, Always, TestOutput (
1324       [["write_file"; "/new"; ""; "0"];
1325        ["cat"; "/new"]], "");
1326     InitBasicFS, Always, TestOutput (
1327       [["write_file"; "/new"; "\n\n\n"; "0"];
1328        ["cat"; "/new"]], "\n\n\n");
1329     InitBasicFS, Always, TestOutput (
1330       [["write_file"; "/new"; "\n"; "0"];
1331        ["cat"; "/new"]], "\n")],
1332    "create a file",
1333    "\
1334 This call creates a file called C<path>.  The contents of the
1335 file is the string C<content> (which can contain any 8 bit data),
1336 with length C<size>.
1337
1338 As a special case, if C<size> is C<0>
1339 then the length is calculated using C<strlen> (so in this case
1340 the content cannot contain embedded ASCII NULs).
1341
1342 I<NB.> Owing to a bug, writing content containing ASCII NUL
1343 characters does I<not> work, even if the length is specified.
1344 We hope to resolve this bug in a future version.  In the meantime
1345 use C<guestfs_upload>.");
1346
1347   ("umount", (RErr, [String "pathordevice"]), 45, [FishAlias "unmount"],
1348    [InitEmpty, Always, TestOutputListOfDevices (
1349       [["sfdiskM"; "/dev/sda"; ","];
1350        ["mkfs"; "ext2"; "/dev/sda1"];
1351        ["mount"; "/dev/sda1"; "/"];
1352        ["mounts"]], ["/dev/sda1"]);
1353     InitEmpty, Always, TestOutputList (
1354       [["sfdiskM"; "/dev/sda"; ","];
1355        ["mkfs"; "ext2"; "/dev/sda1"];
1356        ["mount"; "/dev/sda1"; "/"];
1357        ["umount"; "/"];
1358        ["mounts"]], [])],
1359    "unmount a filesystem",
1360    "\
1361 This unmounts the given filesystem.  The filesystem may be
1362 specified either by its mountpoint (path) or the device which
1363 contains the filesystem.");
1364
1365   ("mounts", (RStringList "devices", []), 46, [],
1366    [InitBasicFS, Always, TestOutputListOfDevices (
1367       [["mounts"]], ["/dev/sda1"])],
1368    "show mounted filesystems",
1369    "\
1370 This returns the list of currently mounted filesystems.  It returns
1371 the list of devices (eg. C</dev/sda1>, C</dev/VG/LV>).
1372
1373 Some internal mounts are not shown.
1374
1375 See also: C<guestfs_mountpoints>");
1376
1377   ("umount_all", (RErr, []), 47, [FishAlias "unmount-all"],
1378    [InitBasicFS, Always, TestOutputList (
1379       [["umount_all"];
1380        ["mounts"]], []);
1381     (* check that umount_all can unmount nested mounts correctly: *)
1382     InitEmpty, Always, TestOutputList (
1383       [["sfdiskM"; "/dev/sda"; ",100 ,200 ,"];
1384        ["mkfs"; "ext2"; "/dev/sda1"];
1385        ["mkfs"; "ext2"; "/dev/sda2"];
1386        ["mkfs"; "ext2"; "/dev/sda3"];
1387        ["mount"; "/dev/sda1"; "/"];
1388        ["mkdir"; "/mp1"];
1389        ["mount"; "/dev/sda2"; "/mp1"];
1390        ["mkdir"; "/mp1/mp2"];
1391        ["mount"; "/dev/sda3"; "/mp1/mp2"];
1392        ["mkdir"; "/mp1/mp2/mp3"];
1393        ["umount_all"];
1394        ["mounts"]], [])],
1395    "unmount all filesystems",
1396    "\
1397 This unmounts all mounted filesystems.
1398
1399 Some internal mounts are not unmounted by this call.");
1400
1401   ("lvm_remove_all", (RErr, []), 48, [DangerWillRobinson],
1402    [],
1403    "remove all LVM LVs, VGs and PVs",
1404    "\
1405 This command removes all LVM logical volumes, volume groups
1406 and physical volumes.");
1407
1408   ("file", (RString "description", [String "path"]), 49, [],
1409    [InitBasicFS, Always, TestOutput (
1410       [["touch"; "/new"];
1411        ["file"; "/new"]], "empty");
1412     InitBasicFS, Always, TestOutput (
1413       [["write_file"; "/new"; "some content\n"; "0"];
1414        ["file"; "/new"]], "ASCII text");
1415     InitBasicFS, Always, TestLastFail (
1416       [["file"; "/nofile"]])],
1417    "determine file type",
1418    "\
1419 This call uses the standard L<file(1)> command to determine
1420 the type or contents of the file.  This also works on devices,
1421 for example to find out whether a partition contains a filesystem.
1422
1423 The exact command which runs is C<file -bsL path>.  Note in
1424 particular that the filename is not prepended to the output
1425 (the C<-b> option).");
1426
1427   ("command", (RString "output", [StringList "arguments"]), 50, [ProtocolLimitWarning],
1428    [InitBasicFS, Always, TestOutput (
1429       [["upload"; "test-command"; "/test-command"];
1430        ["chmod"; "0o755"; "/test-command"];
1431        ["command"; "/test-command 1"]], "Result1");
1432     InitBasicFS, Always, TestOutput (
1433       [["upload"; "test-command"; "/test-command"];
1434        ["chmod"; "0o755"; "/test-command"];
1435        ["command"; "/test-command 2"]], "Result2\n");
1436     InitBasicFS, Always, TestOutput (
1437       [["upload"; "test-command"; "/test-command"];
1438        ["chmod"; "0o755"; "/test-command"];
1439        ["command"; "/test-command 3"]], "\nResult3");
1440     InitBasicFS, Always, TestOutput (
1441       [["upload"; "test-command"; "/test-command"];
1442        ["chmod"; "0o755"; "/test-command"];
1443        ["command"; "/test-command 4"]], "\nResult4\n");
1444     InitBasicFS, Always, TestOutput (
1445       [["upload"; "test-command"; "/test-command"];
1446        ["chmod"; "0o755"; "/test-command"];
1447        ["command"; "/test-command 5"]], "\nResult5\n\n");
1448     InitBasicFS, Always, TestOutput (
1449       [["upload"; "test-command"; "/test-command"];
1450        ["chmod"; "0o755"; "/test-command"];
1451        ["command"; "/test-command 6"]], "\n\nResult6\n\n");
1452     InitBasicFS, Always, TestOutput (
1453       [["upload"; "test-command"; "/test-command"];
1454        ["chmod"; "0o755"; "/test-command"];
1455        ["command"; "/test-command 7"]], "");
1456     InitBasicFS, Always, TestOutput (
1457       [["upload"; "test-command"; "/test-command"];
1458        ["chmod"; "0o755"; "/test-command"];
1459        ["command"; "/test-command 8"]], "\n");
1460     InitBasicFS, Always, TestOutput (
1461       [["upload"; "test-command"; "/test-command"];
1462        ["chmod"; "0o755"; "/test-command"];
1463        ["command"; "/test-command 9"]], "\n\n");
1464     InitBasicFS, Always, TestOutput (
1465       [["upload"; "test-command"; "/test-command"];
1466        ["chmod"; "0o755"; "/test-command"];
1467        ["command"; "/test-command 10"]], "Result10-1\nResult10-2\n");
1468     InitBasicFS, Always, TestOutput (
1469       [["upload"; "test-command"; "/test-command"];
1470        ["chmod"; "0o755"; "/test-command"];
1471        ["command"; "/test-command 11"]], "Result11-1\nResult11-2");
1472     InitBasicFS, Always, TestLastFail (
1473       [["upload"; "test-command"; "/test-command"];
1474        ["chmod"; "0o755"; "/test-command"];
1475        ["command"; "/test-command"]])],
1476    "run a command from the guest filesystem",
1477    "\
1478 This call runs a command from the guest filesystem.  The
1479 filesystem must be mounted, and must contain a compatible
1480 operating system (ie. something Linux, with the same
1481 or compatible processor architecture).
1482
1483 The single parameter is an argv-style list of arguments.
1484 The first element is the name of the program to run.
1485 Subsequent elements are parameters.  The list must be
1486 non-empty (ie. must contain a program name).  Note that
1487 the command runs directly, and is I<not> invoked via
1488 the shell (see C<guestfs_sh>).
1489
1490 The return value is anything printed to I<stdout> by
1491 the command.
1492
1493 If the command returns a non-zero exit status, then
1494 this function returns an error message.  The error message
1495 string is the content of I<stderr> from the command.
1496
1497 The C<$PATH> environment variable will contain at least
1498 C</usr/bin> and C</bin>.  If you require a program from
1499 another location, you should provide the full path in the
1500 first parameter.
1501
1502 Shared libraries and data files required by the program
1503 must be available on filesystems which are mounted in the
1504 correct places.  It is the caller's responsibility to ensure
1505 all filesystems that are needed are mounted at the right
1506 locations.");
1507
1508   ("command_lines", (RStringList "lines", [StringList "arguments"]), 51, [ProtocolLimitWarning],
1509    [InitBasicFS, Always, TestOutputList (
1510       [["upload"; "test-command"; "/test-command"];
1511        ["chmod"; "0o755"; "/test-command"];
1512        ["command_lines"; "/test-command 1"]], ["Result1"]);
1513     InitBasicFS, Always, TestOutputList (
1514       [["upload"; "test-command"; "/test-command"];
1515        ["chmod"; "0o755"; "/test-command"];
1516        ["command_lines"; "/test-command 2"]], ["Result2"]);
1517     InitBasicFS, Always, TestOutputList (
1518       [["upload"; "test-command"; "/test-command"];
1519        ["chmod"; "0o755"; "/test-command"];
1520        ["command_lines"; "/test-command 3"]], ["";"Result3"]);
1521     InitBasicFS, Always, TestOutputList (
1522       [["upload"; "test-command"; "/test-command"];
1523        ["chmod"; "0o755"; "/test-command"];
1524        ["command_lines"; "/test-command 4"]], ["";"Result4"]);
1525     InitBasicFS, Always, TestOutputList (
1526       [["upload"; "test-command"; "/test-command"];
1527        ["chmod"; "0o755"; "/test-command"];
1528        ["command_lines"; "/test-command 5"]], ["";"Result5";""]);
1529     InitBasicFS, Always, TestOutputList (
1530       [["upload"; "test-command"; "/test-command"];
1531        ["chmod"; "0o755"; "/test-command"];
1532        ["command_lines"; "/test-command 6"]], ["";"";"Result6";""]);
1533     InitBasicFS, Always, TestOutputList (
1534       [["upload"; "test-command"; "/test-command"];
1535        ["chmod"; "0o755"; "/test-command"];
1536        ["command_lines"; "/test-command 7"]], []);
1537     InitBasicFS, Always, TestOutputList (
1538       [["upload"; "test-command"; "/test-command"];
1539        ["chmod"; "0o755"; "/test-command"];
1540        ["command_lines"; "/test-command 8"]], [""]);
1541     InitBasicFS, Always, TestOutputList (
1542       [["upload"; "test-command"; "/test-command"];
1543        ["chmod"; "0o755"; "/test-command"];
1544        ["command_lines"; "/test-command 9"]], ["";""]);
1545     InitBasicFS, Always, TestOutputList (
1546       [["upload"; "test-command"; "/test-command"];
1547        ["chmod"; "0o755"; "/test-command"];
1548        ["command_lines"; "/test-command 10"]], ["Result10-1";"Result10-2"]);
1549     InitBasicFS, Always, TestOutputList (
1550       [["upload"; "test-command"; "/test-command"];
1551        ["chmod"; "0o755"; "/test-command"];
1552        ["command_lines"; "/test-command 11"]], ["Result11-1";"Result11-2"])],
1553    "run a command, returning lines",
1554    "\
1555 This is the same as C<guestfs_command>, but splits the
1556 result into a list of lines.
1557
1558 See also: C<guestfs_sh_lines>");
1559
1560   ("stat", (RStruct ("statbuf", "stat"), [String "path"]), 52, [],
1561    [InitBasicFS, Always, TestOutputStruct (
1562       [["touch"; "/new"];
1563        ["stat"; "/new"]], [CompareWithInt ("size", 0)])],
1564    "get file information",
1565    "\
1566 Returns file information for the given C<path>.
1567
1568 This is the same as the C<stat(2)> system call.");
1569
1570   ("lstat", (RStruct ("statbuf", "stat"), [String "path"]), 53, [],
1571    [InitBasicFS, Always, TestOutputStruct (
1572       [["touch"; "/new"];
1573        ["lstat"; "/new"]], [CompareWithInt ("size", 0)])],
1574    "get file information for a symbolic link",
1575    "\
1576 Returns file information for the given C<path>.
1577
1578 This is the same as C<guestfs_stat> except that if C<path>
1579 is a symbolic link, then the link is stat-ed, not the file it
1580 refers to.
1581
1582 This is the same as the C<lstat(2)> system call.");
1583
1584   ("statvfs", (RStruct ("statbuf", "statvfs"), [String "path"]), 54, [],
1585    [InitBasicFS, Always, TestOutputStruct (
1586       [["statvfs"; "/"]], [CompareWithInt ("namemax", 255);
1587                            CompareWithInt ("bsize", 1024)])],
1588    "get file system statistics",
1589    "\
1590 Returns file system statistics for any mounted file system.
1591 C<path> should be a file or directory in the mounted file system
1592 (typically it is the mount point itself, but it doesn't need to be).
1593
1594 This is the same as the C<statvfs(2)> system call.");
1595
1596   ("tune2fs_l", (RHashtable "superblock", [String "device"]), 55, [],
1597    [], (* XXX test *)
1598    "get ext2/ext3/ext4 superblock details",
1599    "\
1600 This returns the contents of the ext2, ext3 or ext4 filesystem
1601 superblock on C<device>.
1602
1603 It is the same as running C<tune2fs -l device>.  See L<tune2fs(8)>
1604 manpage for more details.  The list of fields returned isn't
1605 clearly defined, and depends on both the version of C<tune2fs>
1606 that libguestfs was built against, and the filesystem itself.");
1607
1608   ("blockdev_setro", (RErr, [String "device"]), 56, [],
1609    [InitEmpty, Always, TestOutputTrue (
1610       [["blockdev_setro"; "/dev/sda"];
1611        ["blockdev_getro"; "/dev/sda"]])],
1612    "set block device to read-only",
1613    "\
1614 Sets the block device named C<device> to read-only.
1615
1616 This uses the L<blockdev(8)> command.");
1617
1618   ("blockdev_setrw", (RErr, [String "device"]), 57, [],
1619    [InitEmpty, Always, TestOutputFalse (
1620       [["blockdev_setrw"; "/dev/sda"];
1621        ["blockdev_getro"; "/dev/sda"]])],
1622    "set block device to read-write",
1623    "\
1624 Sets the block device named C<device> to read-write.
1625
1626 This uses the L<blockdev(8)> command.");
1627
1628   ("blockdev_getro", (RBool "ro", [String "device"]), 58, [],
1629    [InitEmpty, Always, TestOutputTrue (
1630       [["blockdev_setro"; "/dev/sda"];
1631        ["blockdev_getro"; "/dev/sda"]])],
1632    "is block device set to read-only",
1633    "\
1634 Returns a boolean indicating if the block device is read-only
1635 (true if read-only, false if not).
1636
1637 This uses the L<blockdev(8)> command.");
1638
1639   ("blockdev_getss", (RInt "sectorsize", [String "device"]), 59, [],
1640    [InitEmpty, Always, TestOutputInt (
1641       [["blockdev_getss"; "/dev/sda"]], 512)],
1642    "get sectorsize of block device",
1643    "\
1644 This returns the size of sectors on a block device.
1645 Usually 512, but can be larger for modern devices.
1646
1647 (Note, this is not the size in sectors, use C<guestfs_blockdev_getsz>
1648 for that).
1649
1650 This uses the L<blockdev(8)> command.");
1651
1652   ("blockdev_getbsz", (RInt "blocksize", [String "device"]), 60, [],
1653    [InitEmpty, Always, TestOutputInt (
1654       [["blockdev_getbsz"; "/dev/sda"]], 4096)],
1655    "get blocksize of block device",
1656    "\
1657 This returns the block size of a device.
1658
1659 (Note this is different from both I<size in blocks> and
1660 I<filesystem block size>).
1661
1662 This uses the L<blockdev(8)> command.");
1663
1664   ("blockdev_setbsz", (RErr, [String "device"; Int "blocksize"]), 61, [],
1665    [], (* XXX test *)
1666    "set blocksize of block device",
1667    "\
1668 This sets the block size of a device.
1669
1670 (Note this is different from both I<size in blocks> and
1671 I<filesystem block size>).
1672
1673 This uses the L<blockdev(8)> command.");
1674
1675   ("blockdev_getsz", (RInt64 "sizeinsectors", [String "device"]), 62, [],
1676    [InitEmpty, Always, TestOutputInt (
1677       [["blockdev_getsz"; "/dev/sda"]], 1024000)],
1678    "get total size of device in 512-byte sectors",
1679    "\
1680 This returns the size of the device in units of 512-byte sectors
1681 (even if the sectorsize isn't 512 bytes ... weird).
1682
1683 See also C<guestfs_blockdev_getss> for the real sector size of
1684 the device, and C<guestfs_blockdev_getsize64> for the more
1685 useful I<size in bytes>.
1686
1687 This uses the L<blockdev(8)> command.");
1688
1689   ("blockdev_getsize64", (RInt64 "sizeinbytes", [String "device"]), 63, [],
1690    [InitEmpty, Always, TestOutputInt (
1691       [["blockdev_getsize64"; "/dev/sda"]], 524288000)],
1692    "get total size of device in bytes",
1693    "\
1694 This returns the size of the device in bytes.
1695
1696 See also C<guestfs_blockdev_getsz>.
1697
1698 This uses the L<blockdev(8)> command.");
1699
1700   ("blockdev_flushbufs", (RErr, [String "device"]), 64, [],
1701    [InitEmpty, Always, TestRun
1702       [["blockdev_flushbufs"; "/dev/sda"]]],
1703    "flush device buffers",
1704    "\
1705 This tells the kernel to flush internal buffers associated
1706 with C<device>.
1707
1708 This uses the L<blockdev(8)> command.");
1709
1710   ("blockdev_rereadpt", (RErr, [String "device"]), 65, [],
1711    [InitEmpty, Always, TestRun
1712       [["blockdev_rereadpt"; "/dev/sda"]]],
1713    "reread partition table",
1714    "\
1715 Reread the partition table on C<device>.
1716
1717 This uses the L<blockdev(8)> command.");
1718
1719   ("upload", (RErr, [FileIn "filename"; String "remotefilename"]), 66, [],
1720    [InitBasicFS, Always, TestOutput (
1721       (* Pick a file from cwd which isn't likely to change. *)
1722       [["upload"; "../COPYING.LIB"; "/COPYING.LIB"];
1723        ["checksum"; "md5"; "/COPYING.LIB"]], "e3eda01d9815f8d24aae2dbd89b68b06")],
1724    "upload a file from the local machine",
1725    "\
1726 Upload local file C<filename> to C<remotefilename> on the
1727 filesystem.
1728
1729 C<filename> can also be a named pipe.
1730
1731 See also C<guestfs_download>.");
1732
1733   ("download", (RErr, [String "remotefilename"; FileOut "filename"]), 67, [],
1734    [InitBasicFS, Always, TestOutput (
1735       (* Pick a file from cwd which isn't likely to change. *)
1736       [["upload"; "../COPYING.LIB"; "/COPYING.LIB"];
1737        ["download"; "/COPYING.LIB"; "testdownload.tmp"];
1738        ["upload"; "testdownload.tmp"; "/upload"];
1739        ["checksum"; "md5"; "/upload"]], "e3eda01d9815f8d24aae2dbd89b68b06")],
1740    "download a file to the local machine",
1741    "\
1742 Download file C<remotefilename> and save it as C<filename>
1743 on the local machine.
1744
1745 C<filename> can also be a named pipe.
1746
1747 See also C<guestfs_upload>, C<guestfs_cat>.");
1748
1749   ("checksum", (RString "checksum", [String "csumtype"; String "path"]), 68, [],
1750    [InitBasicFS, Always, TestOutput (
1751       [["write_file"; "/new"; "test\n"; "0"];
1752        ["checksum"; "crc"; "/new"]], "935282863");
1753     InitBasicFS, Always, TestLastFail (
1754       [["checksum"; "crc"; "/new"]]);
1755     InitBasicFS, Always, TestOutput (
1756       [["write_file"; "/new"; "test\n"; "0"];
1757        ["checksum"; "md5"; "/new"]], "d8e8fca2dc0f896fd7cb4cb0031ba249");
1758     InitBasicFS, Always, TestOutput (
1759       [["write_file"; "/new"; "test\n"; "0"];
1760        ["checksum"; "sha1"; "/new"]], "4e1243bd22c66e76c2ba9eddc1f91394e57f9f83");
1761     InitBasicFS, Always, TestOutput (
1762       [["write_file"; "/new"; "test\n"; "0"];
1763        ["checksum"; "sha224"; "/new"]], "52f1bf093f4b7588726035c176c0cdb4376cfea53819f1395ac9e6ec");
1764     InitBasicFS, Always, TestOutput (
1765       [["write_file"; "/new"; "test\n"; "0"];
1766        ["checksum"; "sha256"; "/new"]], "f2ca1bb6c7e907d06dafe4687e579fce76b37e4e93b7605022da52e6ccc26fd2");
1767     InitBasicFS, Always, TestOutput (
1768       [["write_file"; "/new"; "test\n"; "0"];
1769        ["checksum"; "sha384"; "/new"]], "109bb6b5b6d5547c1ce03c7a8bd7d8f80c1cb0957f50c4f7fda04692079917e4f9cad52b878f3d8234e1a170b154b72d");
1770     InitBasicFS, Always, TestOutput (
1771       [["write_file"; "/new"; "test\n"; "0"];
1772        ["checksum"; "sha512"; "/new"]], "0e3e75234abc68f4378a86b3f4b32a198ba301845b0cd6e50106e874345700cc6663a86c1ea125dc5e92be17c98f9a0f85ca9d5f595db2012f7cc3571945c123");
1773     InitBasicFS, Always, TestOutput (
1774       (* RHEL 5 thinks this is an HFS+ filesystem unless we give
1775        * the type explicitly.
1776        *)
1777       [["mount_vfs"; "ro"; "squashfs"; "/dev/sdd"; "/"];
1778        ["checksum"; "md5"; "/known-3"]], "46d6ca27ee07cdc6fa99c2e138cc522c")],
1779    "compute MD5, SHAx or CRC checksum of file",
1780    "\
1781 This call computes the MD5, SHAx or CRC checksum of the
1782 file named C<path>.
1783
1784 The type of checksum to compute is given by the C<csumtype>
1785 parameter which must have one of the following values:
1786
1787 =over 4
1788
1789 =item C<crc>
1790
1791 Compute the cyclic redundancy check (CRC) specified by POSIX
1792 for the C<cksum> command.
1793
1794 =item C<md5>
1795
1796 Compute the MD5 hash (using the C<md5sum> program).
1797
1798 =item C<sha1>
1799
1800 Compute the SHA1 hash (using the C<sha1sum> program).
1801
1802 =item C<sha224>
1803
1804 Compute the SHA224 hash (using the C<sha224sum> program).
1805
1806 =item C<sha256>
1807
1808 Compute the SHA256 hash (using the C<sha256sum> program).
1809
1810 =item C<sha384>
1811
1812 Compute the SHA384 hash (using the C<sha384sum> program).
1813
1814 =item C<sha512>
1815
1816 Compute the SHA512 hash (using the C<sha512sum> program).
1817
1818 =back
1819
1820 The checksum is returned as a printable string.");
1821
1822   ("tar_in", (RErr, [FileIn "tarfile"; String "directory"]), 69, [],
1823    [InitBasicFS, Always, TestOutput (
1824       [["tar_in"; "../images/helloworld.tar"; "/"];
1825        ["cat"; "/hello"]], "hello\n")],
1826    "unpack tarfile to directory",
1827    "\
1828 This command uploads and unpacks local file C<tarfile> (an
1829 I<uncompressed> tar file) into C<directory>.
1830
1831 To upload a compressed tarball, use C<guestfs_tgz_in>.");
1832
1833   ("tar_out", (RErr, [String "directory"; FileOut "tarfile"]), 70, [],
1834    [],
1835    "pack directory into tarfile",
1836    "\
1837 This command packs the contents of C<directory> and downloads
1838 it to local file C<tarfile>.
1839
1840 To download a compressed tarball, use C<guestfs_tgz_out>.");
1841
1842   ("tgz_in", (RErr, [FileIn "tarball"; String "directory"]), 71, [],
1843    [InitBasicFS, Always, TestOutput (
1844       [["tgz_in"; "../images/helloworld.tar.gz"; "/"];
1845        ["cat"; "/hello"]], "hello\n")],
1846    "unpack compressed tarball to directory",
1847    "\
1848 This command uploads and unpacks local file C<tarball> (a
1849 I<gzip compressed> tar file) into C<directory>.
1850
1851 To upload an uncompressed tarball, use C<guestfs_tar_in>.");
1852
1853   ("tgz_out", (RErr, [String "directory"; FileOut "tarball"]), 72, [],
1854    [],
1855    "pack directory into compressed tarball",
1856    "\
1857 This command packs the contents of C<directory> and downloads
1858 it to local file C<tarball>.
1859
1860 To download an uncompressed tarball, use C<guestfs_tar_out>.");
1861
1862   ("mount_ro", (RErr, [String "device"; String "mountpoint"]), 73, [],
1863    [InitBasicFS, Always, TestLastFail (
1864       [["umount"; "/"];
1865        ["mount_ro"; "/dev/sda1"; "/"];
1866        ["touch"; "/new"]]);
1867     InitBasicFS, Always, TestOutput (
1868       [["write_file"; "/new"; "data"; "0"];
1869        ["umount"; "/"];
1870        ["mount_ro"; "/dev/sda1"; "/"];
1871        ["cat"; "/new"]], "data")],
1872    "mount a guest disk, read-only",
1873    "\
1874 This is the same as the C<guestfs_mount> command, but it
1875 mounts the filesystem with the read-only (I<-o ro>) flag.");
1876
1877   ("mount_options", (RErr, [String "options"; String "device"; String "mountpoint"]), 74, [],
1878    [],
1879    "mount a guest disk with mount options",
1880    "\
1881 This is the same as the C<guestfs_mount> command, but it
1882 allows you to set the mount options as for the
1883 L<mount(8)> I<-o> flag.");
1884
1885   ("mount_vfs", (RErr, [String "options"; String "vfstype"; String "device"; String "mountpoint"]), 75, [],
1886    [],
1887    "mount a guest disk with mount options and vfstype",
1888    "\
1889 This is the same as the C<guestfs_mount> command, but it
1890 allows you to set both the mount options and the vfstype
1891 as for the L<mount(8)> I<-o> and I<-t> flags.");
1892
1893   ("debug", (RString "result", [String "subcmd"; StringList "extraargs"]), 76, [],
1894    [],
1895    "debugging and internals",
1896    "\
1897 The C<guestfs_debug> command exposes some internals of
1898 C<guestfsd> (the guestfs daemon) that runs inside the
1899 qemu subprocess.
1900
1901 There is no comprehensive help for this command.  You have
1902 to look at the file C<daemon/debug.c> in the libguestfs source
1903 to find out what you can do.");
1904
1905   ("lvremove", (RErr, [String "device"]), 77, [],
1906    [InitEmpty, Always, TestOutputList (
1907       [["sfdiskM"; "/dev/sda"; ","];
1908        ["pvcreate"; "/dev/sda1"];
1909        ["vgcreate"; "VG"; "/dev/sda1"];
1910        ["lvcreate"; "LV1"; "VG"; "50"];
1911        ["lvcreate"; "LV2"; "VG"; "50"];
1912        ["lvremove"; "/dev/VG/LV1"];
1913        ["lvs"]], ["/dev/VG/LV2"]);
1914     InitEmpty, Always, TestOutputList (
1915       [["sfdiskM"; "/dev/sda"; ","];
1916        ["pvcreate"; "/dev/sda1"];
1917        ["vgcreate"; "VG"; "/dev/sda1"];
1918        ["lvcreate"; "LV1"; "VG"; "50"];
1919        ["lvcreate"; "LV2"; "VG"; "50"];
1920        ["lvremove"; "/dev/VG"];
1921        ["lvs"]], []);
1922     InitEmpty, Always, TestOutputList (
1923       [["sfdiskM"; "/dev/sda"; ","];
1924        ["pvcreate"; "/dev/sda1"];
1925        ["vgcreate"; "VG"; "/dev/sda1"];
1926        ["lvcreate"; "LV1"; "VG"; "50"];
1927        ["lvcreate"; "LV2"; "VG"; "50"];
1928        ["lvremove"; "/dev/VG"];
1929        ["vgs"]], ["VG"])],
1930    "remove an LVM logical volume",
1931    "\
1932 Remove an LVM logical volume C<device>, where C<device> is
1933 the path to the LV, such as C</dev/VG/LV>.
1934
1935 You can also remove all LVs in a volume group by specifying
1936 the VG name, C</dev/VG>.");
1937
1938   ("vgremove", (RErr, [String "vgname"]), 78, [],
1939    [InitEmpty, Always, TestOutputList (
1940       [["sfdiskM"; "/dev/sda"; ","];
1941        ["pvcreate"; "/dev/sda1"];
1942        ["vgcreate"; "VG"; "/dev/sda1"];
1943        ["lvcreate"; "LV1"; "VG"; "50"];
1944        ["lvcreate"; "LV2"; "VG"; "50"];
1945        ["vgremove"; "VG"];
1946        ["lvs"]], []);
1947     InitEmpty, Always, TestOutputList (
1948       [["sfdiskM"; "/dev/sda"; ","];
1949        ["pvcreate"; "/dev/sda1"];
1950        ["vgcreate"; "VG"; "/dev/sda1"];
1951        ["lvcreate"; "LV1"; "VG"; "50"];
1952        ["lvcreate"; "LV2"; "VG"; "50"];
1953        ["vgremove"; "VG"];
1954        ["vgs"]], [])],
1955    "remove an LVM volume group",
1956    "\
1957 Remove an LVM volume group C<vgname>, (for example C<VG>).
1958
1959 This also forcibly removes all logical volumes in the volume
1960 group (if any).");
1961
1962   ("pvremove", (RErr, [String "device"]), 79, [],
1963    [InitEmpty, Always, TestOutputListOfDevices (
1964       [["sfdiskM"; "/dev/sda"; ","];
1965        ["pvcreate"; "/dev/sda1"];
1966        ["vgcreate"; "VG"; "/dev/sda1"];
1967        ["lvcreate"; "LV1"; "VG"; "50"];
1968        ["lvcreate"; "LV2"; "VG"; "50"];
1969        ["vgremove"; "VG"];
1970        ["pvremove"; "/dev/sda1"];
1971        ["lvs"]], []);
1972     InitEmpty, Always, TestOutputListOfDevices (
1973       [["sfdiskM"; "/dev/sda"; ","];
1974        ["pvcreate"; "/dev/sda1"];
1975        ["vgcreate"; "VG"; "/dev/sda1"];
1976        ["lvcreate"; "LV1"; "VG"; "50"];
1977        ["lvcreate"; "LV2"; "VG"; "50"];
1978        ["vgremove"; "VG"];
1979        ["pvremove"; "/dev/sda1"];
1980        ["vgs"]], []);
1981     InitEmpty, Always, TestOutputListOfDevices (
1982       [["sfdiskM"; "/dev/sda"; ","];
1983        ["pvcreate"; "/dev/sda1"];
1984        ["vgcreate"; "VG"; "/dev/sda1"];
1985        ["lvcreate"; "LV1"; "VG"; "50"];
1986        ["lvcreate"; "LV2"; "VG"; "50"];
1987        ["vgremove"; "VG"];
1988        ["pvremove"; "/dev/sda1"];
1989        ["pvs"]], [])],
1990    "remove an LVM physical volume",
1991    "\
1992 This wipes a physical volume C<device> so that LVM will no longer
1993 recognise it.
1994
1995 The implementation uses the C<pvremove> command which refuses to
1996 wipe physical volumes that contain any volume groups, so you have
1997 to remove those first.");
1998
1999   ("set_e2label", (RErr, [String "device"; String "label"]), 80, [],
2000    [InitBasicFS, Always, TestOutput (
2001       [["set_e2label"; "/dev/sda1"; "testlabel"];
2002        ["get_e2label"; "/dev/sda1"]], "testlabel")],
2003    "set the ext2/3/4 filesystem label",
2004    "\
2005 This sets the ext2/3/4 filesystem label of the filesystem on
2006 C<device> to C<label>.  Filesystem labels are limited to
2007 16 characters.
2008
2009 You can use either C<guestfs_tune2fs_l> or C<guestfs_get_e2label>
2010 to return the existing label on a filesystem.");
2011
2012   ("get_e2label", (RString "label", [String "device"]), 81, [],
2013    [],
2014    "get the ext2/3/4 filesystem label",
2015    "\
2016 This returns the ext2/3/4 filesystem label of the filesystem on
2017 C<device>.");
2018
2019   ("set_e2uuid", (RErr, [String "device"; String "uuid"]), 82, [],
2020    [InitBasicFS, Always, TestOutput (
2021       [["set_e2uuid"; "/dev/sda1"; "a3a61220-882b-4f61-89f4-cf24dcc7297d"];
2022        ["get_e2uuid"; "/dev/sda1"]], "a3a61220-882b-4f61-89f4-cf24dcc7297d");
2023     InitBasicFS, Always, TestOutput (
2024       [["set_e2uuid"; "/dev/sda1"; "clear"];
2025        ["get_e2uuid"; "/dev/sda1"]], "");
2026     (* We can't predict what UUIDs will be, so just check the commands run. *)
2027     InitBasicFS, Always, TestRun (
2028       [["set_e2uuid"; "/dev/sda1"; "random"]]);
2029     InitBasicFS, Always, TestRun (
2030       [["set_e2uuid"; "/dev/sda1"; "time"]])],
2031    "set the ext2/3/4 filesystem UUID",
2032    "\
2033 This sets the ext2/3/4 filesystem UUID of the filesystem on
2034 C<device> to C<uuid>.  The format of the UUID and alternatives
2035 such as C<clear>, C<random> and C<time> are described in the
2036 L<tune2fs(8)> manpage.
2037
2038 You can use either C<guestfs_tune2fs_l> or C<guestfs_get_e2uuid>
2039 to return the existing UUID of a filesystem.");
2040
2041   ("get_e2uuid", (RString "uuid", [String "device"]), 83, [],
2042    [],
2043    "get the ext2/3/4 filesystem UUID",
2044    "\
2045 This returns the ext2/3/4 filesystem UUID of the filesystem on
2046 C<device>.");
2047
2048   ("fsck", (RInt "status", [String "fstype"; String "device"]), 84, [],
2049    [InitBasicFS, Always, TestOutputInt (
2050       [["umount"; "/dev/sda1"];
2051        ["fsck"; "ext2"; "/dev/sda1"]], 0);
2052     InitBasicFS, Always, TestOutputInt (
2053       [["umount"; "/dev/sda1"];
2054        ["zero"; "/dev/sda1"];
2055        ["fsck"; "ext2"; "/dev/sda1"]], 8)],
2056    "run the filesystem checker",
2057    "\
2058 This runs the filesystem checker (fsck) on C<device> which
2059 should have filesystem type C<fstype>.
2060
2061 The returned integer is the status.  See L<fsck(8)> for the
2062 list of status codes from C<fsck>.
2063
2064 Notes:
2065
2066 =over 4
2067
2068 =item *
2069
2070 Multiple status codes can be summed together.
2071
2072 =item *
2073
2074 A non-zero return code can mean \"success\", for example if
2075 errors have been corrected on the filesystem.
2076
2077 =item *
2078
2079 Checking or repairing NTFS volumes is not supported
2080 (by linux-ntfs).
2081
2082 =back
2083
2084 This command is entirely equivalent to running C<fsck -a -t fstype device>.");
2085
2086   ("zero", (RErr, [String "device"]), 85, [],
2087    [InitBasicFS, Always, TestOutput (
2088       [["umount"; "/dev/sda1"];
2089        ["zero"; "/dev/sda1"];
2090        ["file"; "/dev/sda1"]], "data")],
2091    "write zeroes to the device",
2092    "\
2093 This command writes zeroes over the first few blocks of C<device>.
2094
2095 How many blocks are zeroed isn't specified (but it's I<not> enough
2096 to securely wipe the device).  It should be sufficient to remove
2097 any partition tables, filesystem superblocks and so on.
2098
2099 See also: C<guestfs_scrub_device>.");
2100
2101   ("grub_install", (RErr, [String "root"; String "device"]), 86, [],
2102    (* Test disabled because grub-install incompatible with virtio-blk driver.
2103     * See also: https://bugzilla.redhat.com/show_bug.cgi?id=479760
2104     *)
2105    [InitBasicFS, Disabled, TestOutputTrue (
2106       [["grub_install"; "/"; "/dev/sda1"];
2107        ["is_dir"; "/boot"]])],
2108    "install GRUB",
2109    "\
2110 This command installs GRUB (the Grand Unified Bootloader) on
2111 C<device>, with the root directory being C<root>.");
2112
2113   ("cp", (RErr, [String "src"; String "dest"]), 87, [],
2114    [InitBasicFS, Always, TestOutput (
2115       [["write_file"; "/old"; "file content"; "0"];
2116        ["cp"; "/old"; "/new"];
2117        ["cat"; "/new"]], "file content");
2118     InitBasicFS, Always, TestOutputTrue (
2119       [["write_file"; "/old"; "file content"; "0"];
2120        ["cp"; "/old"; "/new"];
2121        ["is_file"; "/old"]]);
2122     InitBasicFS, Always, TestOutput (
2123       [["write_file"; "/old"; "file content"; "0"];
2124        ["mkdir"; "/dir"];
2125        ["cp"; "/old"; "/dir/new"];
2126        ["cat"; "/dir/new"]], "file content")],
2127    "copy a file",
2128    "\
2129 This copies a file from C<src> to C<dest> where C<dest> is
2130 either a destination filename or destination directory.");
2131
2132   ("cp_a", (RErr, [String "src"; String "dest"]), 88, [],
2133    [InitBasicFS, Always, TestOutput (
2134       [["mkdir"; "/olddir"];
2135        ["mkdir"; "/newdir"];
2136        ["write_file"; "/olddir/file"; "file content"; "0"];
2137        ["cp_a"; "/olddir"; "/newdir"];
2138        ["cat"; "/newdir/olddir/file"]], "file content")],
2139    "copy a file or directory recursively",
2140    "\
2141 This copies a file or directory from C<src> to C<dest>
2142 recursively using the C<cp -a> command.");
2143
2144   ("mv", (RErr, [String "src"; String "dest"]), 89, [],
2145    [InitBasicFS, Always, TestOutput (
2146       [["write_file"; "/old"; "file content"; "0"];
2147        ["mv"; "/old"; "/new"];
2148        ["cat"; "/new"]], "file content");
2149     InitBasicFS, Always, TestOutputFalse (
2150       [["write_file"; "/old"; "file content"; "0"];
2151        ["mv"; "/old"; "/new"];
2152        ["is_file"; "/old"]])],
2153    "move a file",
2154    "\
2155 This moves a file from C<src> to C<dest> where C<dest> is
2156 either a destination filename or destination directory.");
2157
2158   ("drop_caches", (RErr, [Int "whattodrop"]), 90, [],
2159    [InitEmpty, Always, TestRun (
2160       [["drop_caches"; "3"]])],
2161    "drop kernel page cache, dentries and inodes",
2162    "\
2163 This instructs the guest kernel to drop its page cache,
2164 and/or dentries and inode caches.  The parameter C<whattodrop>
2165 tells the kernel what precisely to drop, see
2166 L<http://linux-mm.org/Drop_Caches>
2167
2168 Setting C<whattodrop> to 3 should drop everything.
2169
2170 This automatically calls L<sync(2)> before the operation,
2171 so that the maximum guest memory is freed.");
2172
2173   ("dmesg", (RString "kmsgs", []), 91, [],
2174    [InitEmpty, Always, TestRun (
2175       [["dmesg"]])],
2176    "return kernel messages",
2177    "\
2178 This returns the kernel messages (C<dmesg> output) from
2179 the guest kernel.  This is sometimes useful for extended
2180 debugging of problems.
2181
2182 Another way to get the same information is to enable
2183 verbose messages with C<guestfs_set_verbose> or by setting
2184 the environment variable C<LIBGUESTFS_DEBUG=1> before
2185 running the program.");
2186
2187   ("ping_daemon", (RErr, []), 92, [],
2188    [InitEmpty, Always, TestRun (
2189       [["ping_daemon"]])],
2190    "ping the guest daemon",
2191    "\
2192 This is a test probe into the guestfs daemon running inside
2193 the qemu subprocess.  Calling this function checks that the
2194 daemon responds to the ping message, without affecting the daemon
2195 or attached block device(s) in any other way.");
2196
2197   ("equal", (RBool "equality", [String "file1"; String "file2"]), 93, [],
2198    [InitBasicFS, Always, TestOutputTrue (
2199       [["write_file"; "/file1"; "contents of a file"; "0"];
2200        ["cp"; "/file1"; "/file2"];
2201        ["equal"; "/file1"; "/file2"]]);
2202     InitBasicFS, Always, TestOutputFalse (
2203       [["write_file"; "/file1"; "contents of a file"; "0"];
2204        ["write_file"; "/file2"; "contents of another file"; "0"];
2205        ["equal"; "/file1"; "/file2"]]);
2206     InitBasicFS, Always, TestLastFail (
2207       [["equal"; "/file1"; "/file2"]])],
2208    "test if two files have equal contents",
2209    "\
2210 This compares the two files C<file1> and C<file2> and returns
2211 true if their content is exactly equal, or false otherwise.
2212
2213 The external L<cmp(1)> program is used for the comparison.");
2214
2215   ("strings", (RStringList "stringsout", [String "path"]), 94, [ProtocolLimitWarning],
2216    [InitBasicFS, Always, TestOutputList (
2217       [["write_file"; "/new"; "hello\nworld\n"; "0"];
2218        ["strings"; "/new"]], ["hello"; "world"]);
2219     InitBasicFS, Always, TestOutputList (
2220       [["touch"; "/new"];
2221        ["strings"; "/new"]], [])],
2222    "print the printable strings in a file",
2223    "\
2224 This runs the L<strings(1)> command on a file and returns
2225 the list of printable strings found.");
2226
2227   ("strings_e", (RStringList "stringsout", [String "encoding"; String "path"]), 95, [ProtocolLimitWarning],
2228    [InitBasicFS, Always, TestOutputList (
2229       [["write_file"; "/new"; "hello\nworld\n"; "0"];
2230        ["strings_e"; "b"; "/new"]], []);
2231     InitBasicFS, Disabled, TestOutputList (
2232       [["write_file"; "/new"; "\000h\000e\000l\000l\000o\000\n\000w\000o\000r\000l\000d\000\n"; "24"];
2233        ["strings_e"; "b"; "/new"]], ["hello"; "world"])],
2234    "print the printable strings in a file",
2235    "\
2236 This is like the C<guestfs_strings> command, but allows you to
2237 specify the encoding.
2238
2239 See the L<strings(1)> manpage for the full list of encodings.
2240
2241 Commonly useful encodings are C<l> (lower case L) which will
2242 show strings inside Windows/x86 files.
2243
2244 The returned strings are transcoded to UTF-8.");
2245
2246   ("hexdump", (RString "dump", [String "path"]), 96, [ProtocolLimitWarning],
2247    [InitBasicFS, Always, TestOutput (
2248       [["write_file"; "/new"; "hello\nworld\n"; "12"];
2249        ["hexdump"; "/new"]], "00000000  68 65 6c 6c 6f 0a 77 6f  72 6c 64 0a              |hello.world.|\n0000000c\n");
2250     (* Test for RHBZ#501888c2 regression which caused large hexdump
2251      * commands to segfault.
2252      *)
2253     InitBasicFS, Always, TestRun (
2254       [["mount_vfs"; "ro"; "squashfs"; "/dev/sdd"; "/"];
2255        ["hexdump"; "/100krandom"]])],
2256    "dump a file in hexadecimal",
2257    "\
2258 This runs C<hexdump -C> on the given C<path>.  The result is
2259 the human-readable, canonical hex dump of the file.");
2260
2261   ("zerofree", (RErr, [String "device"]), 97, [],
2262    [InitNone, Always, TestOutput (
2263       [["sfdiskM"; "/dev/sda"; ","];
2264        ["mkfs"; "ext3"; "/dev/sda1"];
2265        ["mount"; "/dev/sda1"; "/"];
2266        ["write_file"; "/new"; "test file"; "0"];
2267        ["umount"; "/dev/sda1"];
2268        ["zerofree"; "/dev/sda1"];
2269        ["mount"; "/dev/sda1"; "/"];
2270        ["cat"; "/new"]], "test file")],
2271    "zero unused inodes and disk blocks on ext2/3 filesystem",
2272    "\
2273 This runs the I<zerofree> program on C<device>.  This program
2274 claims to zero unused inodes and disk blocks on an ext2/3
2275 filesystem, thus making it possible to compress the filesystem
2276 more effectively.
2277
2278 You should B<not> run this program if the filesystem is
2279 mounted.
2280
2281 It is possible that using this program can damage the filesystem
2282 or data on the filesystem.");
2283
2284   ("pvresize", (RErr, [String "device"]), 98, [],
2285    [],
2286    "resize an LVM physical volume",
2287    "\
2288 This resizes (expands or shrinks) an existing LVM physical
2289 volume to match the new size of the underlying device.");
2290
2291   ("sfdisk_N", (RErr, [String "device"; Int "partnum";
2292                        Int "cyls"; Int "heads"; Int "sectors";
2293                        String "line"]), 99, [DangerWillRobinson],
2294    [],
2295    "modify a single partition on a block device",
2296    "\
2297 This runs L<sfdisk(8)> option to modify just the single
2298 partition C<n> (note: C<n> counts from 1).
2299
2300 For other parameters, see C<guestfs_sfdisk>.  You should usually
2301 pass C<0> for the cyls/heads/sectors parameters.");
2302
2303   ("sfdisk_l", (RString "partitions", [String "device"]), 100, [],
2304    [],
2305    "display the partition table",
2306    "\
2307 This displays the partition table on C<device>, in the
2308 human-readable output of the L<sfdisk(8)> command.  It is
2309 not intended to be parsed.");
2310
2311   ("sfdisk_kernel_geometry", (RString "partitions", [String "device"]), 101, [],
2312    [],
2313    "display the kernel geometry",
2314    "\
2315 This displays the kernel's idea of the geometry of C<device>.
2316
2317 The result is in human-readable format, and not designed to
2318 be parsed.");
2319
2320   ("sfdisk_disk_geometry", (RString "partitions", [String "device"]), 102, [],
2321    [],
2322    "display the disk geometry from the partition table",
2323    "\
2324 This displays the disk geometry of C<device> read from the
2325 partition table.  Especially in the case where the underlying
2326 block device has been resized, this can be different from the
2327 kernel's idea of the geometry (see C<guestfs_sfdisk_kernel_geometry>).
2328
2329 The result is in human-readable format, and not designed to
2330 be parsed.");
2331
2332   ("vg_activate_all", (RErr, [Bool "activate"]), 103, [],
2333    [],
2334    "activate or deactivate all volume groups",
2335    "\
2336 This command activates or (if C<activate> is false) deactivates
2337 all logical volumes in all volume groups.
2338 If activated, then they are made known to the
2339 kernel, ie. they appear as C</dev/mapper> devices.  If deactivated,
2340 then those devices disappear.
2341
2342 This command is the same as running C<vgchange -a y|n>");
2343
2344   ("vg_activate", (RErr, [Bool "activate"; StringList "volgroups"]), 104, [],
2345    [],
2346    "activate or deactivate some volume groups",
2347    "\
2348 This command activates or (if C<activate> is false) deactivates
2349 all logical volumes in the listed volume groups C<volgroups>.
2350 If activated, then they are made known to the
2351 kernel, ie. they appear as C</dev/mapper> devices.  If deactivated,
2352 then those devices disappear.
2353
2354 This command is the same as running C<vgchange -a y|n volgroups...>
2355
2356 Note that if C<volgroups> is an empty list then B<all> volume groups
2357 are activated or deactivated.");
2358
2359   ("lvresize", (RErr, [String "device"; Int "mbytes"]), 105, [],
2360    [InitNone, Always, TestOutput (
2361       [["sfdiskM"; "/dev/sda"; ","];
2362        ["pvcreate"; "/dev/sda1"];
2363        ["vgcreate"; "VG"; "/dev/sda1"];
2364        ["lvcreate"; "LV"; "VG"; "10"];
2365        ["mkfs"; "ext2"; "/dev/VG/LV"];
2366        ["mount"; "/dev/VG/LV"; "/"];
2367        ["write_file"; "/new"; "test content"; "0"];
2368        ["umount"; "/"];
2369        ["lvresize"; "/dev/VG/LV"; "20"];
2370        ["e2fsck_f"; "/dev/VG/LV"];
2371        ["resize2fs"; "/dev/VG/LV"];
2372        ["mount"; "/dev/VG/LV"; "/"];
2373        ["cat"; "/new"]], "test content")],
2374    "resize an LVM logical volume",
2375    "\
2376 This resizes (expands or shrinks) an existing LVM logical
2377 volume to C<mbytes>.  When reducing, data in the reduced part
2378 is lost.");
2379
2380   ("resize2fs", (RErr, [String "device"]), 106, [],
2381    [], (* lvresize tests this *)
2382    "resize an ext2/ext3 filesystem",
2383    "\
2384 This resizes an ext2 or ext3 filesystem to match the size of
2385 the underlying device.
2386
2387 I<Note:> It is sometimes required that you run C<guestfs_e2fsck_f>
2388 on the C<device> before calling this command.  For unknown reasons
2389 C<resize2fs> sometimes gives an error about this and sometimes not.
2390 In any case, it is always safe to call C<guestfs_e2fsck_f> before
2391 calling this function.");
2392
2393   ("find", (RStringList "names", [String "directory"]), 107, [],
2394    [InitBasicFS, Always, TestOutputList (
2395       [["find"; "/"]], ["lost+found"]);
2396     InitBasicFS, Always, TestOutputList (
2397       [["touch"; "/a"];
2398        ["mkdir"; "/b"];
2399        ["touch"; "/b/c"];
2400        ["find"; "/"]], ["a"; "b"; "b/c"; "lost+found"]);
2401     InitBasicFS, Always, TestOutputList (
2402       [["mkdir_p"; "/a/b/c"];
2403        ["touch"; "/a/b/c/d"];
2404        ["find"; "/a/b/"]], ["c"; "c/d"])],
2405    "find all files and directories",
2406    "\
2407 This command lists out all files and directories, recursively,
2408 starting at C<directory>.  It is essentially equivalent to
2409 running the shell command C<find directory -print> but some
2410 post-processing happens on the output, described below.
2411
2412 This returns a list of strings I<without any prefix>.  Thus
2413 if the directory structure was:
2414
2415  /tmp/a
2416  /tmp/b
2417  /tmp/c/d
2418
2419 then the returned list from C<guestfs_find> C</tmp> would be
2420 4 elements:
2421
2422  a
2423  b
2424  c
2425  c/d
2426
2427 If C<directory> is not a directory, then this command returns
2428 an error.
2429
2430 The returned list is sorted.");
2431
2432   ("e2fsck_f", (RErr, [String "device"]), 108, [],
2433    [], (* lvresize tests this *)
2434    "check an ext2/ext3 filesystem",
2435    "\
2436 This runs C<e2fsck -p -f device>, ie. runs the ext2/ext3
2437 filesystem checker on C<device>, noninteractively (C<-p>),
2438 even if the filesystem appears to be clean (C<-f>).
2439
2440 This command is only needed because of C<guestfs_resize2fs>
2441 (q.v.).  Normally you should use C<guestfs_fsck>.");
2442
2443   ("sleep", (RErr, [Int "secs"]), 109, [],
2444    [InitNone, Always, TestRun (
2445       [["sleep"; "1"]])],
2446    "sleep for some seconds",
2447    "\
2448 Sleep for C<secs> seconds.");
2449
2450   ("ntfs_3g_probe", (RInt "status", [Bool "rw"; String "device"]), 110, [],
2451    [InitNone, Always, TestOutputInt (
2452       [["sfdiskM"; "/dev/sda"; ","];
2453        ["mkfs"; "ntfs"; "/dev/sda1"];
2454        ["ntfs_3g_probe"; "true"; "/dev/sda1"]], 0);
2455     InitNone, Always, TestOutputInt (
2456       [["sfdiskM"; "/dev/sda"; ","];
2457        ["mkfs"; "ext2"; "/dev/sda1"];
2458        ["ntfs_3g_probe"; "true"; "/dev/sda1"]], 12)],
2459    "probe NTFS volume",
2460    "\
2461 This command runs the L<ntfs-3g.probe(8)> command which probes
2462 an NTFS C<device> for mountability.  (Not all NTFS volumes can
2463 be mounted read-write, and some cannot be mounted at all).
2464
2465 C<rw> is a boolean flag.  Set it to true if you want to test
2466 if the volume can be mounted read-write.  Set it to false if
2467 you want to test if the volume can be mounted read-only.
2468
2469 The return value is an integer which C<0> if the operation
2470 would succeed, or some non-zero value documented in the
2471 L<ntfs-3g.probe(8)> manual page.");
2472
2473   ("sh", (RString "output", [String "command"]), 111, [],
2474    [], (* XXX needs tests *)
2475    "run a command via the shell",
2476    "\
2477 This call runs a command from the guest filesystem via the
2478 guest's C</bin/sh>.
2479
2480 This is like C<guestfs_command>, but passes the command to:
2481
2482  /bin/sh -c \"command\"
2483
2484 Depending on the guest's shell, this usually results in
2485 wildcards being expanded, shell expressions being interpolated
2486 and so on.
2487
2488 All the provisos about C<guestfs_command> apply to this call.");
2489
2490   ("sh_lines", (RStringList "lines", [String "command"]), 112, [],
2491    [], (* XXX needs tests *)
2492    "run a command via the shell returning lines",
2493    "\
2494 This is the same as C<guestfs_sh>, but splits the result
2495 into a list of lines.
2496
2497 See also: C<guestfs_command_lines>");
2498
2499   ("glob_expand", (RStringList "paths", [String "pattern"]), 113, [],
2500    [InitBasicFS, Always, TestOutputList (
2501       [["mkdir_p"; "/a/b/c"];
2502        ["touch"; "/a/b/c/d"];
2503        ["touch"; "/a/b/c/e"];
2504        ["glob_expand"; "/a/b/c/*"]], ["/a/b/c/d"; "/a/b/c/e"]);
2505     InitBasicFS, Always, TestOutputList (
2506       [["mkdir_p"; "/a/b/c"];
2507        ["touch"; "/a/b/c/d"];
2508        ["touch"; "/a/b/c/e"];
2509        ["glob_expand"; "/a/*/c/*"]], ["/a/b/c/d"; "/a/b/c/e"]);
2510     InitBasicFS, Always, TestOutputList (
2511       [["mkdir_p"; "/a/b/c"];
2512        ["touch"; "/a/b/c/d"];
2513        ["touch"; "/a/b/c/e"];
2514        ["glob_expand"; "/a/*/x/*"]], [])],
2515    "expand a wildcard path",
2516    "\
2517 This command searches for all the pathnames matching
2518 C<pattern> according to the wildcard expansion rules
2519 used by the shell.
2520
2521 If no paths match, then this returns an empty list
2522 (note: not an error).
2523
2524 It is just a wrapper around the C L<glob(3)> function
2525 with flags C<GLOB_MARK|GLOB_BRACE>.
2526 See that manual page for more details.");
2527
2528   ("scrub_device", (RErr, [String "device"]), 114, [DangerWillRobinson],
2529    [InitNone, Always, TestRun ( (* use /dev/sdc because it's smaller *)
2530       [["scrub_device"; "/dev/sdc"]])],
2531    "scrub (securely wipe) a device",
2532    "\
2533 This command writes patterns over C<device> to make data retrieval
2534 more difficult.
2535
2536 It is an interface to the L<scrub(1)> program.  See that
2537 manual page for more details.");
2538
2539   ("scrub_file", (RErr, [String "file"]), 115, [],
2540    [InitBasicFS, Always, TestRun (
2541       [["write_file"; "/file"; "content"; "0"];
2542        ["scrub_file"; "/file"]])],
2543    "scrub (securely wipe) a file",
2544    "\
2545 This command writes patterns over a file to make data retrieval
2546 more difficult.
2547
2548 The file is I<removed> after scrubbing.
2549
2550 It is an interface to the L<scrub(1)> program.  See that
2551 manual page for more details.");
2552
2553   ("scrub_freespace", (RErr, [String "dir"]), 116, [],
2554    [], (* XXX needs testing *)
2555    "scrub (securely wipe) free space",
2556    "\
2557 This command creates the directory C<dir> and then fills it
2558 with files until the filesystem is full, and scrubs the files
2559 as for C<guestfs_scrub_file>, and deletes them.
2560 The intention is to scrub any free space on the partition
2561 containing C<dir>.
2562
2563 It is an interface to the L<scrub(1)> program.  See that
2564 manual page for more details.");
2565
2566   ("mkdtemp", (RString "dir", [String "template"]), 117, [],
2567    [InitBasicFS, Always, TestRun (
2568       [["mkdir"; "/tmp"];
2569        ["mkdtemp"; "/tmp/tmpXXXXXX"]])],
2570    "create a temporary directory",
2571    "\
2572 This command creates a temporary directory.  The
2573 C<template> parameter should be a full pathname for the
2574 temporary directory name with the final six characters being
2575 \"XXXXXX\".
2576
2577 For example: \"/tmp/myprogXXXXXX\" or \"/Temp/myprogXXXXXX\",
2578 the second one being suitable for Windows filesystems.
2579
2580 The name of the temporary directory that was created
2581 is returned.
2582
2583 The temporary directory is created with mode 0700
2584 and is owned by root.
2585
2586 The caller is responsible for deleting the temporary
2587 directory and its contents after use.
2588
2589 See also: L<mkdtemp(3)>");
2590
2591   ("wc_l", (RInt "lines", [String "path"]), 118, [],
2592    [InitBasicFS, Always, TestOutputInt (
2593       [["mount_vfs"; "ro"; "squashfs"; "/dev/sdd"; "/"];
2594        ["wc_l"; "/10klines"]], 10000)],
2595    "count lines in a file",
2596    "\
2597 This command counts the lines in a file, using the
2598 C<wc -l> external command.");
2599
2600   ("wc_w", (RInt "words", [String "path"]), 119, [],
2601    [InitBasicFS, Always, TestOutputInt (
2602       [["mount_vfs"; "ro"; "squashfs"; "/dev/sdd"; "/"];
2603        ["wc_w"; "/10klines"]], 10000)],
2604    "count words in a file",
2605    "\
2606 This command counts the words in a file, using the
2607 C<wc -w> external command.");
2608
2609   ("wc_c", (RInt "chars", [String "path"]), 120, [],
2610    [InitBasicFS, Always, TestOutputInt (
2611       [["mount_vfs"; "ro"; "squashfs"; "/dev/sdd"; "/"];
2612        ["wc_c"; "/100kallspaces"]], 102400)],
2613    "count characters in a file",
2614    "\
2615 This command counts the characters in a file, using the
2616 C<wc -c> external command.");
2617
2618   ("head", (RStringList "lines", [String "path"]), 121, [ProtocolLimitWarning],
2619    [InitBasicFS, Always, TestOutputList (
2620       [["mount_vfs"; "ro"; "squashfs"; "/dev/sdd"; "/"];
2621        ["head"; "/10klines"]], ["0abcdefghijklmnopqrstuvwxyz";"1abcdefghijklmnopqrstuvwxyz";"2abcdefghijklmnopqrstuvwxyz";"3abcdefghijklmnopqrstuvwxyz";"4abcdefghijklmnopqrstuvwxyz";"5abcdefghijklmnopqrstuvwxyz";"6abcdefghijklmnopqrstuvwxyz";"7abcdefghijklmnopqrstuvwxyz";"8abcdefghijklmnopqrstuvwxyz";"9abcdefghijklmnopqrstuvwxyz"])],
2622    "return first 10 lines of a file",
2623    "\
2624 This command returns up to the first 10 lines of a file as
2625 a list of strings.");
2626
2627   ("head_n", (RStringList "lines", [Int "nrlines"; String "path"]), 122, [ProtocolLimitWarning],
2628    [InitBasicFS, Always, TestOutputList (
2629       [["mount_vfs"; "ro"; "squashfs"; "/dev/sdd"; "/"];
2630        ["head_n"; "3"; "/10klines"]], ["0abcdefghijklmnopqrstuvwxyz";"1abcdefghijklmnopqrstuvwxyz";"2abcdefghijklmnopqrstuvwxyz"]);
2631     InitBasicFS, Always, TestOutputList (
2632       [["mount_vfs"; "ro"; "squashfs"; "/dev/sdd"; "/"];
2633        ["head_n"; "-9997"; "/10klines"]], ["0abcdefghijklmnopqrstuvwxyz";"1abcdefghijklmnopqrstuvwxyz";"2abcdefghijklmnopqrstuvwxyz"]);
2634     InitBasicFS, Always, TestOutputList (
2635       [["mount_vfs"; "ro"; "squashfs"; "/dev/sdd"; "/"];
2636        ["head_n"; "0"; "/10klines"]], [])],
2637    "return first N lines of a file",
2638    "\
2639 If the parameter C<nrlines> is a positive number, this returns the first
2640 C<nrlines> lines of the file C<path>.
2641
2642 If the parameter C<nrlines> is a negative number, this returns lines
2643 from the file C<path>, excluding the last C<nrlines> lines.
2644
2645 If the parameter C<nrlines> is zero, this returns an empty list.");
2646
2647   ("tail", (RStringList "lines", [String "path"]), 123, [ProtocolLimitWarning],
2648    [InitBasicFS, Always, TestOutputList (
2649       [["mount_vfs"; "ro"; "squashfs"; "/dev/sdd"; "/"];
2650        ["tail"; "/10klines"]], ["9990abcdefghijklmnopqrstuvwxyz";"9991abcdefghijklmnopqrstuvwxyz";"9992abcdefghijklmnopqrstuvwxyz";"9993abcdefghijklmnopqrstuvwxyz";"9994abcdefghijklmnopqrstuvwxyz";"9995abcdefghijklmnopqrstuvwxyz";"9996abcdefghijklmnopqrstuvwxyz";"9997abcdefghijklmnopqrstuvwxyz";"9998abcdefghijklmnopqrstuvwxyz";"9999abcdefghijklmnopqrstuvwxyz"])],
2651    "return last 10 lines of a file",
2652    "\
2653 This command returns up to the last 10 lines of a file as
2654 a list of strings.");
2655
2656   ("tail_n", (RStringList "lines", [Int "nrlines"; String "path"]), 124, [ProtocolLimitWarning],
2657    [InitBasicFS, Always, TestOutputList (
2658       [["mount_vfs"; "ro"; "squashfs"; "/dev/sdd"; "/"];
2659        ["tail_n"; "3"; "/10klines"]], ["9997abcdefghijklmnopqrstuvwxyz";"9998abcdefghijklmnopqrstuvwxyz";"9999abcdefghijklmnopqrstuvwxyz"]);
2660     InitBasicFS, Always, TestOutputList (
2661       [["mount_vfs"; "ro"; "squashfs"; "/dev/sdd"; "/"];
2662        ["tail_n"; "-9998"; "/10klines"]], ["9997abcdefghijklmnopqrstuvwxyz";"9998abcdefghijklmnopqrstuvwxyz";"9999abcdefghijklmnopqrstuvwxyz"]);
2663     InitBasicFS, Always, TestOutputList (
2664       [["mount_vfs"; "ro"; "squashfs"; "/dev/sdd"; "/"];
2665        ["tail_n"; "0"; "/10klines"]], [])],
2666    "return last N lines of a file",
2667    "\
2668 If the parameter C<nrlines> is a positive number, this returns the last
2669 C<nrlines> lines of the file C<path>.
2670
2671 If the parameter C<nrlines> is a negative number, this returns lines
2672 from the file C<path>, starting with the C<-nrlines>th line.
2673
2674 If the parameter C<nrlines> is zero, this returns an empty list.");
2675
2676   ("df", (RString "output", []), 125, [],
2677    [], (* XXX Tricky to test because it depends on the exact format
2678         * of the 'df' command and other imponderables.
2679         *)
2680    "report file system disk space usage",
2681    "\
2682 This command runs the C<df> command to report disk space used.
2683
2684 This command is mostly useful for interactive sessions.  It
2685 is I<not> intended that you try to parse the output string.
2686 Use C<statvfs> from programs.");
2687
2688   ("df_h", (RString "output", []), 126, [],
2689    [], (* XXX Tricky to test because it depends on the exact format
2690         * of the 'df' command and other imponderables.
2691         *)
2692    "report file system disk space usage (human readable)",
2693    "\
2694 This command runs the C<df -h> command to report disk space used
2695 in human-readable format.
2696
2697 This command is mostly useful for interactive sessions.  It
2698 is I<not> intended that you try to parse the output string.
2699 Use C<statvfs> from programs.");
2700
2701   ("du", (RInt64 "sizekb", [String "path"]), 127, [],
2702    [InitBasicFS, Always, TestOutputInt (
2703       [["mkdir"; "/p"];
2704        ["du"; "/p"]], 1 (* ie. 1 block, so depends on ext3 blocksize *))],
2705    "estimate file space usage",
2706    "\
2707 This command runs the C<du -s> command to estimate file space
2708 usage for C<path>.
2709
2710 C<path> can be a file or a directory.  If C<path> is a directory
2711 then the estimate includes the contents of the directory and all
2712 subdirectories (recursively).
2713
2714 The result is the estimated size in I<kilobytes>
2715 (ie. units of 1024 bytes).");
2716
2717   ("initrd_list", (RStringList "filenames", [String "path"]), 128, [],
2718    [InitBasicFS, Always, TestOutputList (
2719       [["mount_vfs"; "ro"; "squashfs"; "/dev/sdd"; "/"];
2720        ["initrd_list"; "/initrd"]], ["empty";"known-1";"known-2";"known-3"])],
2721    "list files in an initrd",
2722    "\
2723 This command lists out files contained in an initrd.
2724
2725 The files are listed without any initial C</> character.  The
2726 files are listed in the order they appear (not necessarily
2727 alphabetical).  Directory names are listed as separate items.
2728
2729 Old Linux kernels (2.4 and earlier) used a compressed ext2
2730 filesystem as initrd.  We I<only> support the newer initramfs
2731 format (compressed cpio files).");
2732
2733   ("mount_loop", (RErr, [String "file"; String "mountpoint"]), 129, [],
2734    [],
2735    "mount a file using the loop device",
2736    "\
2737 This command lets you mount C<file> (a filesystem image
2738 in a file) on a mount point.  It is entirely equivalent to
2739 the command C<mount -o loop file mountpoint>.");
2740
2741   ("mkswap", (RErr, [String "device"]), 130, [],
2742    [InitEmpty, Always, TestRun (
2743       [["sfdiskM"; "/dev/sda"; ","];
2744        ["mkswap"; "/dev/sda1"]])],
2745    "create a swap partition",
2746    "\
2747 Create a swap partition on C<device>.");
2748
2749   ("mkswap_L", (RErr, [String "label"; String "device"]), 131, [],
2750    [InitEmpty, Always, TestRun (
2751       [["sfdiskM"; "/dev/sda"; ","];
2752        ["mkswap_L"; "hello"; "/dev/sda1"]])],
2753    "create a swap partition with a label",
2754    "\
2755 Create a swap partition on C<device> with label C<label>.");
2756
2757   ("mkswap_U", (RErr, [String "uuid"; String "device"]), 132, [],
2758    [InitEmpty, Always, TestRun (
2759       [["sfdiskM"; "/dev/sda"; ","];
2760        ["mkswap_U"; "a3a61220-882b-4f61-89f4-cf24dcc7297d"; "/dev/sda1"]])],
2761    "create a swap partition with an explicit UUID",
2762    "\
2763 Create a swap partition on C<device> with UUID C<uuid>.");
2764
2765   ("mknod", (RErr, [Int "mode"; Int "devmajor"; Int "devminor"; String "path"]), 133, [],
2766    [InitBasicFS, Always, TestOutputStruct (
2767       [["mknod"; "0o10777"; "0"; "0"; "/node"];
2768        (* NB: default umask 022 means 0777 -> 0755 in these tests *)
2769        ["stat"; "/node"]], [CompareWithInt ("mode", 0o10755)]);
2770     InitBasicFS, Always, TestOutputStruct (
2771       [["mknod"; "0o60777"; "66"; "99"; "/node"];
2772        ["stat"; "/node"]], [CompareWithInt ("mode", 0o60755)])],
2773    "make block, character or FIFO devices",
2774    "\
2775 This call creates block or character special devices, or
2776 named pipes (FIFOs).
2777
2778 The C<mode> parameter should be the mode, using the standard
2779 constants.  C<devmajor> and C<devminor> are the
2780 device major and minor numbers, only used when creating block
2781 and character special devices.");
2782
2783   ("mkfifo", (RErr, [Int "mode"; String "path"]), 134, [],
2784    [InitBasicFS, Always, TestOutputStruct (
2785       [["mkfifo"; "0o777"; "/node"];
2786        ["stat"; "/node"]], [CompareWithInt ("mode", 0o10755)])],
2787    "make FIFO (named pipe)",
2788    "\
2789 This call creates a FIFO (named pipe) called C<path> with
2790 mode C<mode>.  It is just a convenient wrapper around
2791 C<guestfs_mknod>.");
2792
2793   ("mknod_b", (RErr, [Int "mode"; Int "devmajor"; Int "devminor"; String "path"]), 135, [],
2794    [InitBasicFS, Always, TestOutputStruct (
2795       [["mknod_b"; "0o777"; "99"; "66"; "/node"];
2796        ["stat"; "/node"]], [CompareWithInt ("mode", 0o60755)])],
2797    "make block device node",
2798    "\
2799 This call creates a block device node called C<path> with
2800 mode C<mode> and device major/minor C<devmajor> and C<devminor>.
2801 It is just a convenient wrapper around C<guestfs_mknod>.");
2802
2803   ("mknod_c", (RErr, [Int "mode"; Int "devmajor"; Int "devminor"; String "path"]), 136, [],
2804    [InitBasicFS, Always, TestOutputStruct (
2805       [["mknod_c"; "0o777"; "99"; "66"; "/node"];
2806        ["stat"; "/node"]], [CompareWithInt ("mode", 0o20755)])],
2807    "make char device node",
2808    "\
2809 This call creates a char device node called C<path> with
2810 mode C<mode> and device major/minor C<devmajor> and C<devminor>.
2811 It is just a convenient wrapper around C<guestfs_mknod>.");
2812
2813   ("umask", (RInt "oldmask", [Int "mask"]), 137, [],
2814    [], (* XXX umask is one of those stateful things that we should
2815         * reset between each test.
2816         *)
2817    "set file mode creation mask (umask)",
2818    "\
2819 This function sets the mask used for creating new files and
2820 device nodes to C<mask & 0777>.
2821
2822 Typical umask values would be C<022> which creates new files
2823 with permissions like \"-rw-r--r--\" or \"-rwxr-xr-x\", and
2824 C<002> which creates new files with permissions like
2825 \"-rw-rw-r--\" or \"-rwxrwxr-x\".
2826
2827 The default umask is C<022>.  This is important because it
2828 means that directories and device nodes will be created with
2829 C<0644> or C<0755> mode even if you specify C<0777>.
2830
2831 See also L<umask(2)>, C<guestfs_mknod>, C<guestfs_mkdir>.
2832
2833 This call returns the previous umask.");
2834
2835   ("readdir", (RStructList ("entries", "dirent"), [String "dir"]), 138, [],
2836    [],
2837    "read directories entries",
2838    "\
2839 This returns the list of directory entries in directory C<dir>.
2840
2841 All entries in the directory are returned, including C<.> and
2842 C<..>.  The entries are I<not> sorted, but returned in the same
2843 order as the underlying filesystem.
2844
2845 This function is primarily intended for use by programs.  To
2846 get a simple list of names, use C<guestfs_ls>.  To get a printable
2847 directory for human consumption, use C<guestfs_ll>.");
2848
2849   ("sfdiskM", (RErr, [String "device"; StringList "lines"]), 139, [DangerWillRobinson],
2850    [],
2851    "create partitions on a block device",
2852    "\
2853 This is a simplified interface to the C<guestfs_sfdisk>
2854 command, where partition sizes are specified in megabytes
2855 only (rounded to the nearest cylinder) and you don't need
2856 to specify the cyls, heads and sectors parameters which
2857 were rarely if ever used anyway.
2858
2859 See also C<guestfs_sfdisk> and the L<sfdisk(8)> manpage.");
2860
2861   ("zfile", (RString "description", [String "method"; String "path"]), 140, [],
2862    [],
2863    "determine file type inside a compressed file",
2864    "\
2865 This command runs C<file> after first decompressing C<path>
2866 using C<method>.
2867
2868 C<method> must be one of C<gzip>, C<compress> or C<bzip2>.
2869
2870 See also: C<guestfs_file>");
2871
2872   ("getxattrs", (RStructList ("xattrs", "xattr"), [String "path"]), 141, [],
2873    [],
2874    "list extended attributes of a file or directory",
2875    "\
2876 This call lists the extended attributes of the file or directory
2877 C<path>.
2878
2879 At the system call level, this is a combination of the
2880 L<listxattr(2)> and L<getxattr(2)> calls.
2881
2882 See also: C<guestfs_lgetxattrs>, L<attr(5)>.");
2883
2884   ("lgetxattrs", (RStructList ("xattrs", "xattr"), [String "path"]), 142, [],
2885    [],
2886    "list extended attributes of a file or directory",
2887    "\
2888 This is the same as C<guestfs_getxattrs>, but if C<path>
2889 is a symbolic link, then it returns the extended attributes
2890 of the link itself.");
2891
2892   ("setxattr", (RErr, [String "xattr";
2893                        String "val"; Int "vallen"; (* will be BufferIn *)
2894                        String "path"]), 143, [],
2895    [],
2896    "set extended attribute of a file or directory",
2897    "\
2898 This call sets the extended attribute named C<xattr>
2899 of the file C<path> to the value C<val> (of length C<vallen>).
2900 The value is arbitrary 8 bit data.
2901
2902 See also: C<guestfs_lsetxattr>, L<attr(5)>.");
2903
2904   ("lsetxattr", (RErr, [String "xattr";
2905                         String "val"; Int "vallen"; (* will be BufferIn *)
2906                         String "path"]), 144, [],
2907    [],
2908    "set extended attribute of a file or directory",
2909    "\
2910 This is the same as C<guestfs_setxattr>, but if C<path>
2911 is a symbolic link, then it sets an extended attribute
2912 of the link itself.");
2913
2914   ("removexattr", (RErr, [String "xattr"; String "path"]), 145, [],
2915    [],
2916    "remove extended attribute of a file or directory",
2917    "\
2918 This call removes the extended attribute named C<xattr>
2919 of the file C<path>.
2920
2921 See also: C<guestfs_lremovexattr>, L<attr(5)>.");
2922
2923   ("lremovexattr", (RErr, [String "xattr"; String "path"]), 146, [],
2924    [],
2925    "remove extended attribute of a file or directory",
2926    "\
2927 This is the same as C<guestfs_removexattr>, but if C<path>
2928 is a symbolic link, then it removes an extended attribute
2929 of the link itself.");
2930
2931   ("mountpoints", (RHashtable "mps", []), 147, [],
2932    [],
2933    "show mountpoints",
2934    "\
2935 This call is similar to C<guestfs_mounts>.  That call returns
2936 a list of devices.  This one returns a hash table (map) of
2937 device name to directory where the device is mounted.");
2938
2939   ("mkmountpoint", (RErr, [String "path"]), 148, [],
2940    [],
2941    "create a mountpoint",
2942    "\
2943 C<guestfs_mkmountpoint> and C<guestfs_rmmountpoint> are
2944 specialized calls that can be used to create extra mountpoints
2945 before mounting the first filesystem.
2946
2947 These calls are I<only> necessary in some very limited circumstances,
2948 mainly the case where you want to mount a mix of unrelated and/or
2949 read-only filesystems together.
2950
2951 For example, live CDs often contain a \"Russian doll\" nest of
2952 filesystems, an ISO outer layer, with a squashfs image inside, with
2953 an ext2/3 image inside that.  You can unpack this as follows
2954 in guestfish:
2955
2956  add-ro Fedora-11-i686-Live.iso
2957  run
2958  mkmountpoint /cd
2959  mkmountpoint /squash
2960  mkmountpoint /ext3
2961  mount /dev/sda /cd
2962  mount-loop /cd/LiveOS/squashfs.img /squash
2963  mount-loop /squash/LiveOS/ext3fs.img /ext3
2964
2965 The inner filesystem is now unpacked under the /ext3 mountpoint.");
2966
2967   ("rmmountpoint", (RErr, [String "path"]), 149, [],
2968    [],
2969    "remove a mountpoint",
2970    "\
2971 This calls removes a mountpoint that was previously created
2972 with C<guestfs_mkmountpoint>.  See C<guestfs_mkmountpoint>
2973 for full details.");
2974
2975 ]
2976
2977 let all_functions = non_daemon_functions @ daemon_functions
2978
2979 (* In some places we want the functions to be displayed sorted
2980  * alphabetically, so this is useful:
2981  *)
2982 let all_functions_sorted =
2983   List.sort (fun (n1,_,_,_,_,_,_) (n2,_,_,_,_,_,_) ->
2984                compare n1 n2) all_functions
2985
2986 (* Field types for structures. *)
2987 type field =
2988   | FChar                       (* C 'char' (really, a 7 bit byte). *)
2989   | FString                     (* nul-terminated ASCII string. *)
2990   | FBuffer                     (* opaque buffer of bytes, (char *, int) pair *)
2991   | FUInt32
2992   | FInt32
2993   | FUInt64
2994   | FInt64
2995   | FBytes                      (* Any int measure that counts bytes. *)
2996   | FUUID                       (* 32 bytes long, NOT nul-terminated. *)
2997   | FOptPercent                 (* [0..100], or -1 meaning "not present". *)
2998
2999 (* Because we generate extra parsing code for LVM command line tools,
3000  * we have to pull out the LVM columns separately here.
3001  *)
3002 let lvm_pv_cols = [
3003   "pv_name", FString;
3004   "pv_uuid", FUUID;
3005   "pv_fmt", FString;
3006   "pv_size", FBytes;
3007   "dev_size", FBytes;
3008   "pv_free", FBytes;
3009   "pv_used", FBytes;
3010   "pv_attr", FString (* XXX *);
3011   "pv_pe_count", FInt64;
3012   "pv_pe_alloc_count", FInt64;
3013   "pv_tags", FString;
3014   "pe_start", FBytes;
3015   "pv_mda_count", FInt64;
3016   "pv_mda_free", FBytes;
3017   (* Not in Fedora 10:
3018      "pv_mda_size", FBytes;
3019   *)
3020 ]
3021 let lvm_vg_cols = [
3022   "vg_name", FString;
3023   "vg_uuid", FUUID;
3024   "vg_fmt", FString;
3025   "vg_attr", FString (* XXX *);
3026   "vg_size", FBytes;
3027   "vg_free", FBytes;
3028   "vg_sysid", FString;
3029   "vg_extent_size", FBytes;
3030   "vg_extent_count", FInt64;
3031   "vg_free_count", FInt64;
3032   "max_lv", FInt64;
3033   "max_pv", FInt64;
3034   "pv_count", FInt64;
3035   "lv_count", FInt64;
3036   "snap_count", FInt64;
3037   "vg_seqno", FInt64;
3038   "vg_tags", FString;
3039   "vg_mda_count", FInt64;
3040   "vg_mda_free", FBytes;
3041   (* Not in Fedora 10:
3042      "vg_mda_size", FBytes;
3043   *)
3044 ]
3045 let lvm_lv_cols = [
3046   "lv_name", FString;
3047   "lv_uuid", FUUID;
3048   "lv_attr", FString (* XXX *);
3049   "lv_major", FInt64;
3050   "lv_minor", FInt64;
3051   "lv_kernel_major", FInt64;
3052   "lv_kernel_minor", FInt64;
3053   "lv_size", FBytes;
3054   "seg_count", FInt64;
3055   "origin", FString;
3056   "snap_percent", FOptPercent;
3057   "copy_percent", FOptPercent;
3058   "move_pv", FString;
3059   "lv_tags", FString;
3060   "mirror_log", FString;
3061   "modules", FString;
3062 ]
3063
3064 (* Names and fields in all structures (in RStruct and RStructList)
3065  * that we support.
3066  *)
3067 let structs = [
3068   (* The old RIntBool return type, only ever used for aug_defnode.  Do
3069    * not use this struct in any new code.
3070    *)
3071   "int_bool", [
3072     "i", FInt32;                (* for historical compatibility *)
3073     "b", FInt32;                (* for historical compatibility *)
3074   ];
3075
3076   (* LVM PVs, VGs, LVs. *)
3077   "lvm_pv", lvm_pv_cols;
3078   "lvm_vg", lvm_vg_cols;
3079   "lvm_lv", lvm_lv_cols;
3080
3081   (* Column names and types from stat structures.
3082    * NB. Can't use things like 'st_atime' because glibc header files
3083    * define some of these as macros.  Ugh.
3084    *)
3085   "stat", [
3086     "dev", FInt64;
3087     "ino", FInt64;
3088     "mode", FInt64;
3089     "nlink", FInt64;
3090     "uid", FInt64;
3091     "gid", FInt64;
3092     "rdev", FInt64;
3093     "size", FInt64;
3094     "blksize", FInt64;
3095     "blocks", FInt64;
3096     "atime", FInt64;
3097     "mtime", FInt64;
3098     "ctime", FInt64;
3099   ];
3100   "statvfs", [
3101     "bsize", FInt64;
3102     "frsize", FInt64;
3103     "blocks", FInt64;
3104     "bfree", FInt64;
3105     "bavail", FInt64;
3106     "files", FInt64;
3107     "ffree", FInt64;
3108     "favail", FInt64;
3109     "fsid", FInt64;
3110     "flag", FInt64;
3111     "namemax", FInt64;
3112   ];
3113
3114   (* Column names in dirent structure. *)
3115   "dirent", [
3116     "ino", FInt64;
3117     (* 'b' 'c' 'd' 'f' (FIFO) 'l' 'r' (regular file) 's' 'u' '?' *)
3118     "ftyp", FChar;
3119     "name", FString;
3120   ];
3121
3122   (* Version numbers. *)
3123   "version", [
3124     "major", FInt64;
3125     "minor", FInt64;
3126     "release", FInt64;
3127     "extra", FString;
3128   ];
3129
3130   (* Extended attribute. *)
3131   "xattr", [
3132     "attrname", FString;
3133     "attrval", FBuffer;
3134   ];
3135 ] (* end of structs *)
3136
3137 (* Ugh, Java has to be different ..
3138  * These names are also used by the Haskell bindings.
3139  *)
3140 let java_structs = [
3141   "int_bool", "IntBool";
3142   "lvm_pv", "PV";
3143   "lvm_vg", "VG";
3144   "lvm_lv", "LV";
3145   "stat", "Stat";
3146   "statvfs", "StatVFS";
3147   "dirent", "Dirent";
3148   "version", "Version";
3149   "xattr", "XAttr";
3150 ]
3151
3152 (* Used for testing language bindings. *)
3153 type callt =
3154   | CallString of string
3155   | CallOptString of string option
3156   | CallStringList of string list
3157   | CallInt of int
3158   | CallBool of bool
3159
3160 (* Used to memoize the result of pod2text. *)
3161 let pod2text_memo_filename = "src/.pod2text.data"
3162 let pod2text_memo : ((int * string * string), string list) Hashtbl.t =
3163   try
3164     let chan = open_in pod2text_memo_filename in
3165     let v = input_value chan in
3166     close_in chan;
3167     v
3168   with
3169     _ -> Hashtbl.create 13
3170
3171 (* Useful functions.
3172  * Note we don't want to use any external OCaml libraries which
3173  * makes this a bit harder than it should be.
3174  *)
3175 let failwithf fs = ksprintf failwith fs
3176
3177 let replace_char s c1 c2 =
3178   let s2 = String.copy s in
3179   let r = ref false in
3180   for i = 0 to String.length s2 - 1 do
3181     if String.unsafe_get s2 i = c1 then (
3182       String.unsafe_set s2 i c2;
3183       r := true
3184     )
3185   done;
3186   if not !r then s else s2
3187
3188 let isspace c =
3189   c = ' '
3190   (* || c = '\f' *) || c = '\n' || c = '\r' || c = '\t' (* || c = '\v' *)
3191
3192 let triml ?(test = isspace) str =
3193   let i = ref 0 in
3194   let n = ref (String.length str) in
3195   while !n > 0 && test str.[!i]; do
3196     decr n;
3197     incr i
3198   done;
3199   if !i = 0 then str
3200   else String.sub str !i !n
3201
3202 let trimr ?(test = isspace) str =
3203   let n = ref (String.length str) in
3204   while !n > 0 && test str.[!n-1]; do
3205     decr n
3206   done;
3207   if !n = String.length str then str
3208   else String.sub str 0 !n
3209
3210 let trim ?(test = isspace) str =
3211   trimr ~test (triml ~test str)
3212
3213 let rec find s sub =
3214   let len = String.length s in
3215   let sublen = String.length sub in
3216   let rec loop i =
3217     if i <= len-sublen then (
3218       let rec loop2 j =
3219         if j < sublen then (
3220           if s.[i+j] = sub.[j] then loop2 (j+1)
3221           else -1
3222         ) else
3223           i (* found *)
3224       in
3225       let r = loop2 0 in
3226       if r = -1 then loop (i+1) else r
3227     ) else
3228       -1 (* not found *)
3229   in
3230   loop 0
3231
3232 let rec replace_str s s1 s2 =
3233   let len = String.length s in
3234   let sublen = String.length s1 in
3235   let i = find s s1 in
3236   if i = -1 then s
3237   else (
3238     let s' = String.sub s 0 i in
3239     let s'' = String.sub s (i+sublen) (len-i-sublen) in
3240     s' ^ s2 ^ replace_str s'' s1 s2
3241   )
3242
3243 let rec string_split sep str =
3244   let len = String.length str in
3245   let seplen = String.length sep in
3246   let i = find str sep in
3247   if i = -1 then [str]
3248   else (
3249     let s' = String.sub str 0 i in
3250     let s'' = String.sub str (i+seplen) (len-i-seplen) in
3251     s' :: string_split sep s''
3252   )
3253
3254 let files_equal n1 n2 =
3255   let cmd = sprintf "cmp -s %s %s" (Filename.quote n1) (Filename.quote n2) in
3256   match Sys.command cmd with
3257   | 0 -> true
3258   | 1 -> false
3259   | i -> failwithf "%s: failed with error code %d" cmd i
3260
3261 let rec find_map f = function
3262   | [] -> raise Not_found
3263   | x :: xs ->
3264       match f x with
3265       | Some y -> y
3266       | None -> find_map f xs
3267
3268 let iteri f xs =
3269   let rec loop i = function
3270     | [] -> ()
3271     | x :: xs -> f i x; loop (i+1) xs
3272   in
3273   loop 0 xs
3274
3275 let mapi f xs =
3276   let rec loop i = function
3277     | [] -> []
3278     | x :: xs -> let r = f i x in r :: loop (i+1) xs
3279   in
3280   loop 0 xs
3281
3282 let name_of_argt = function
3283   | String n | OptString n | StringList n | Bool n | Int n
3284   | FileIn n | FileOut n -> n
3285
3286 let java_name_of_struct typ =
3287   try List.assoc typ java_structs
3288   with Not_found ->
3289     failwithf
3290       "java_name_of_struct: no java_structs entry corresponding to %s" typ
3291
3292 let cols_of_struct typ =
3293   try List.assoc typ structs
3294   with Not_found ->
3295     failwithf "cols_of_struct: unknown struct %s" typ
3296
3297 let seq_of_test = function
3298   | TestRun s | TestOutput (s, _) | TestOutputList (s, _)
3299   | TestOutputListOfDevices (s, _)
3300   | TestOutputInt (s, _) | TestOutputIntOp (s, _, _)
3301   | TestOutputTrue s | TestOutputFalse s
3302   | TestOutputLength (s, _) | TestOutputStruct (s, _)
3303   | TestLastFail s -> s
3304
3305 (* Check function names etc. for consistency. *)
3306 let check_functions () =
3307   let contains_uppercase str =
3308     let len = String.length str in
3309     let rec loop i =
3310       if i >= len then false
3311       else (
3312         let c = str.[i] in
3313         if c >= 'A' && c <= 'Z' then true
3314         else loop (i+1)
3315       )
3316     in
3317     loop 0
3318   in
3319
3320   (* Check function names. *)
3321   List.iter (
3322     fun (name, _, _, _, _, _, _) ->
3323       if String.length name >= 7 && String.sub name 0 7 = "guestfs" then
3324         failwithf "function name %s does not need 'guestfs' prefix" name;
3325       if name = "" then
3326         failwithf "function name is empty";
3327       if name.[0] < 'a' || name.[0] > 'z' then
3328         failwithf "function name %s must start with lowercase a-z" name;
3329       if String.contains name '-' then
3330         failwithf "function name %s should not contain '-', use '_' instead."
3331           name
3332   ) all_functions;
3333
3334   (* Check function parameter/return names. *)
3335   List.iter (
3336     fun (name, style, _, _, _, _, _) ->
3337       let check_arg_ret_name n =
3338         if contains_uppercase n then
3339           failwithf "%s param/ret %s should not contain uppercase chars"
3340             name n;
3341         if String.contains n '-' || String.contains n '_' then
3342           failwithf "%s param/ret %s should not contain '-' or '_'"
3343             name n;
3344         if n = "value" then
3345           failwithf "%s has a param/ret called 'value', which causes conflicts in the OCaml bindings, use something like 'val' or a more descriptive name" name;
3346         if n = "int" || n = "char" || n = "short" || n = "long" then
3347           failwithf "%s has a param/ret which conflicts with a C type (eg. 'int', 'char' etc.)" name;
3348         if n = "i" || n = "n" then
3349           failwithf "%s has a param/ret called 'i' or 'n', which will cause some conflicts in the generated code" name;
3350         if n = "argv" || n = "args" then
3351           failwithf "%s has a param/ret called 'argv' or 'args', which will cause some conflicts in the generated code" name
3352       in
3353
3354       (match fst style with
3355        | RErr -> ()
3356        | RInt n | RInt64 n | RBool n | RConstString n | RString n
3357        | RStringList n | RStruct (n, _) | RStructList (n, _)
3358        | RHashtable n ->
3359            check_arg_ret_name n
3360       );
3361       List.iter (fun arg -> check_arg_ret_name (name_of_argt arg)) (snd style)
3362   ) all_functions;
3363
3364   (* Check short descriptions. *)
3365   List.iter (
3366     fun (name, _, _, _, _, shortdesc, _) ->
3367       if shortdesc.[0] <> Char.lowercase shortdesc.[0] then
3368         failwithf "short description of %s should begin with lowercase." name;
3369       let c = shortdesc.[String.length shortdesc-1] in
3370       if c = '\n' || c = '.' then
3371         failwithf "short description of %s should not end with . or \\n." name
3372   ) all_functions;
3373
3374   (* Check long dscriptions. *)
3375   List.iter (
3376     fun (name, _, _, _, _, _, longdesc) ->
3377       if longdesc.[String.length longdesc-1] = '\n' then
3378         failwithf "long description of %s should not end with \\n." name
3379   ) all_functions;
3380
3381   (* Check proc_nrs. *)
3382   List.iter (
3383     fun (name, _, proc_nr, _, _, _, _) ->
3384       if proc_nr <= 0 then
3385         failwithf "daemon function %s should have proc_nr > 0" name
3386   ) daemon_functions;
3387
3388   List.iter (
3389     fun (name, _, proc_nr, _, _, _, _) ->
3390       if proc_nr <> -1 then
3391         failwithf "non-daemon function %s should have proc_nr -1" name
3392   ) non_daemon_functions;
3393
3394   let proc_nrs =
3395     List.map (fun (name, _, proc_nr, _, _, _, _) -> name, proc_nr)
3396       daemon_functions in
3397   let proc_nrs =
3398     List.sort (fun (_,nr1) (_,nr2) -> compare nr1 nr2) proc_nrs in
3399   let rec loop = function
3400     | [] -> ()
3401     | [_] -> ()
3402     | (name1,nr1) :: ((name2,nr2) :: _ as rest) when nr1 < nr2 ->
3403         loop rest
3404     | (name1,nr1) :: (name2,nr2) :: _ ->
3405         failwithf "%s and %s have conflicting procedure numbers (%d, %d)"
3406           name1 name2 nr1 nr2
3407   in
3408   loop proc_nrs;
3409
3410   (* Check tests. *)
3411   List.iter (
3412     function
3413       (* Ignore functions that have no tests.  We generate a
3414        * warning when the user does 'make check' instead.
3415        *)
3416     | name, _, _, _, [], _, _ -> ()
3417     | name, _, _, _, tests, _, _ ->
3418         let funcs =
3419           List.map (
3420             fun (_, _, test) ->
3421               match seq_of_test test with
3422               | [] ->
3423                   failwithf "%s has a test containing an empty sequence" name
3424               | cmds -> List.map List.hd cmds
3425           ) tests in
3426         let funcs = List.flatten funcs in
3427
3428         let tested = List.mem name funcs in
3429
3430         if not tested then
3431           failwithf "function %s has tests but does not test itself" name
3432   ) all_functions
3433
3434 (* 'pr' prints to the current output file. *)
3435 let chan = ref stdout
3436 let pr fs = ksprintf (output_string !chan) fs
3437
3438 (* Generate a header block in a number of standard styles. *)
3439 type comment_style = CStyle | HashStyle | OCamlStyle | HaskellStyle
3440 type license = GPLv2 | LGPLv2
3441
3442 let generate_header comment license =
3443   let c = match comment with
3444     | CStyle ->     pr "/* "; " *"
3445     | HashStyle ->  pr "# ";  "#"
3446     | OCamlStyle -> pr "(* "; " *"
3447     | HaskellStyle -> pr "{- "; "  " in
3448   pr "libguestfs generated file\n";
3449   pr "%s WARNING: THIS FILE IS GENERATED BY 'src/generator.ml'.\n" c;
3450   pr "%s ANY CHANGES YOU MAKE TO THIS FILE WILL BE LOST.\n" c;
3451   pr "%s\n" c;
3452   pr "%s Copyright (C) 2009 Red Hat Inc.\n" c;
3453   pr "%s\n" c;
3454   (match license with
3455    | GPLv2 ->
3456        pr "%s This program is free software; you can redistribute it and/or modify\n" c;
3457        pr "%s it under the terms of the GNU General Public License as published by\n" c;
3458        pr "%s the Free Software Foundation; either version 2 of the License, or\n" c;
3459        pr "%s (at your option) any later version.\n" c;
3460        pr "%s\n" c;
3461        pr "%s This program is distributed in the hope that it will be useful,\n" c;
3462        pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
3463        pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the\n" c;
3464        pr "%s GNU General Public License for more details.\n" c;
3465        pr "%s\n" c;
3466        pr "%s You should have received a copy of the GNU General Public License along\n" c;
3467        pr "%s with this program; if not, write to the Free Software Foundation, Inc.,\n" c;
3468        pr "%s 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n" c;
3469
3470    | LGPLv2 ->
3471        pr "%s This library is free software; you can redistribute it and/or\n" c;
3472        pr "%s modify it under the terms of the GNU Lesser General Public\n" c;
3473        pr "%s License as published by the Free Software Foundation; either\n" c;
3474        pr "%s version 2 of the License, or (at your option) any later version.\n" c;
3475        pr "%s\n" c;
3476        pr "%s This library is distributed in the hope that it will be useful,\n" c;
3477        pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
3478        pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU\n" c;
3479        pr "%s Lesser General Public License for more details.\n" c;
3480        pr "%s\n" c;
3481        pr "%s You should have received a copy of the GNU Lesser General Public\n" c;
3482        pr "%s License along with this library; if not, write to the Free Software\n" c;
3483        pr "%s Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA\n" c;
3484   );
3485   (match comment with
3486    | CStyle -> pr " */\n"
3487    | HashStyle -> ()
3488    | OCamlStyle -> pr " *)\n"
3489    | HaskellStyle -> pr "-}\n"
3490   );
3491   pr "\n"
3492
3493 (* Start of main code generation functions below this line. *)
3494
3495 (* Generate the pod documentation for the C API. *)
3496 let rec generate_actions_pod () =
3497   List.iter (
3498     fun (shortname, style, _, flags, _, _, longdesc) ->
3499       if not (List.mem NotInDocs flags) then (
3500         let name = "guestfs_" ^ shortname in
3501         pr "=head2 %s\n\n" name;
3502         pr " ";
3503         generate_prototype ~extern:false ~handle:"handle" name style;
3504         pr "\n\n";
3505         pr "%s\n\n" longdesc;
3506         (match fst style with
3507          | RErr ->
3508              pr "This function returns 0 on success or -1 on error.\n\n"
3509          | RInt _ ->
3510              pr "On error this function returns -1.\n\n"
3511          | RInt64 _ ->
3512              pr "On error this function returns -1.\n\n"
3513          | RBool _ ->
3514              pr "This function returns a C truth value on success or -1 on error.\n\n"
3515          | RConstString _ ->
3516              pr "This function returns a string, or NULL on error.
3517 The string is owned by the guest handle and must I<not> be freed.\n\n"
3518          | RString _ ->
3519              pr "This function returns a string, or NULL on error.
3520 I<The caller must free the returned string after use>.\n\n"
3521          | RStringList _ ->
3522              pr "This function returns a NULL-terminated array of strings
3523 (like L<environ(3)>), or NULL if there was an error.
3524 I<The caller must free the strings and the array after use>.\n\n"
3525          | RStruct (_, typ) ->
3526              pr "This function returns a C<struct guestfs_%s *>,
3527 or NULL if there was an error.
3528 I<The caller must call C<guestfs_free_%s> after use>.\n\n" typ typ
3529          | RStructList (_, typ) ->
3530              pr "This function returns a C<struct guestfs_%s_list *>
3531 (see E<lt>guestfs-structs.hE<gt>),
3532 or NULL if there was an error.
3533 I<The caller must call C<guestfs_free_%s_list> after use>.\n\n" typ typ
3534          | RHashtable _ ->
3535              pr "This function returns a NULL-terminated array of
3536 strings, or NULL if there was an error.
3537 The array of strings will always have length C<2n+1>, where
3538 C<n> keys and values alternate, followed by the trailing NULL entry.
3539 I<The caller must free the strings and the array after use>.\n\n"
3540         );
3541         if List.mem ProtocolLimitWarning flags then
3542           pr "%s\n\n" protocol_limit_warning;
3543         if List.mem DangerWillRobinson flags then
3544           pr "%s\n\n" danger_will_robinson
3545       )
3546   ) all_functions_sorted
3547
3548 and generate_structs_pod () =
3549   (* Structs documentation. *)
3550   List.iter (
3551     fun (typ, cols) ->
3552       pr "=head2 guestfs_%s\n" typ;
3553       pr "\n";
3554       pr " struct guestfs_%s {\n" typ;
3555       List.iter (
3556         function
3557         | name, FChar -> pr "   char %s;\n" name
3558         | name, FUInt32 -> pr "   uint32_t %s;\n" name
3559         | name, FInt32 -> pr "   int32_t %s;\n" name
3560         | name, (FUInt64|FBytes) -> pr "   uint64_t %s;\n" name
3561         | name, FInt64 -> pr "   int64_t %s;\n" name
3562         | name, FString -> pr "   char *%s;\n" name
3563         | name, FBuffer ->
3564             pr "   /* The next two fields describe a byte array. */\n";
3565             pr "   uint32_t %s_len;\n" name;
3566             pr "   char *%s;\n" name
3567         | name, FUUID ->
3568             pr "   /* The next field is NOT nul-terminated, be careful when printing it: */\n";
3569             pr "   char %s[32];\n" name
3570         | name, FOptPercent ->
3571             pr "   /* The next field is [0..100] or -1 meaning 'not present': */\n";
3572             pr "   float %s;\n" name
3573       ) cols;
3574       pr " };\n";
3575       pr " \n";
3576       pr " struct guestfs_%s_list {\n" typ;
3577       pr "   uint32_t len; /* Number of elements in list. */\n";
3578       pr "   struct guestfs_%s *val; /* Elements. */\n" typ;
3579       pr " };\n";
3580       pr " \n";
3581       pr " void guestfs_free_%s (struct guestfs_free_%s *);\n" typ typ;
3582       pr " void guestfs_free_%s_list (struct guestfs_free_%s_list *);\n"
3583         typ typ;
3584       pr "\n"
3585   ) structs
3586
3587 (* Generate the protocol (XDR) file, 'guestfs_protocol.x' and
3588  * indirectly 'guestfs_protocol.h' and 'guestfs_protocol.c'.
3589  *
3590  * We have to use an underscore instead of a dash because otherwise
3591  * rpcgen generates incorrect code.
3592  *
3593  * This header is NOT exported to clients, but see also generate_structs_h.
3594  *)
3595 and generate_xdr () =
3596   generate_header CStyle LGPLv2;
3597
3598   (* This has to be defined to get around a limitation in Sun's rpcgen. *)
3599   pr "typedef string str<>;\n";
3600   pr "\n";
3601
3602   (* Internal structures. *)
3603   List.iter (
3604     function
3605     | typ, cols ->
3606         pr "struct guestfs_int_%s {\n" typ;
3607         List.iter (function
3608                    | name, FChar -> pr "  char %s;\n" name
3609                    | name, FString -> pr "  string %s<>;\n" name
3610                    | name, FBuffer -> pr "  opaque %s<>;\n" name
3611                    | name, FUUID -> pr "  opaque %s[32];\n" name
3612                    | name, (FInt32|FUInt32) -> pr "  int %s;\n" name
3613                    | name, (FInt64|FUInt64|FBytes) -> pr "  hyper %s;\n" name
3614                    | name, FOptPercent -> pr "  float %s;\n" name
3615                   ) cols;
3616         pr "};\n";
3617         pr "\n";
3618         pr "typedef struct guestfs_int_%s guestfs_int_%s_list<>;\n" typ typ;
3619         pr "\n";
3620   ) structs;
3621
3622   List.iter (
3623     fun (shortname, style, _, _, _, _, _) ->
3624       let name = "guestfs_" ^ shortname in
3625
3626       (match snd style with
3627        | [] -> ()
3628        | args ->
3629            pr "struct %s_args {\n" name;
3630            List.iter (
3631              function
3632              | String n -> pr "  string %s<>;\n" n
3633              | OptString n -> pr "  str *%s;\n" n
3634              | StringList n -> pr "  str %s<>;\n" n
3635              | Bool n -> pr "  bool %s;\n" n
3636              | Int n -> pr "  int %s;\n" n
3637              | FileIn _ | FileOut _ -> ()
3638            ) args;
3639            pr "};\n\n"
3640       );
3641       (match fst style with
3642        | RErr -> ()
3643        | RInt n ->
3644            pr "struct %s_ret {\n" name;
3645            pr "  int %s;\n" n;
3646            pr "};\n\n"
3647        | RInt64 n ->
3648            pr "struct %s_ret {\n" name;
3649            pr "  hyper %s;\n" n;
3650            pr "};\n\n"
3651        | RBool n ->
3652            pr "struct %s_ret {\n" name;
3653            pr "  bool %s;\n" n;
3654            pr "};\n\n"
3655        | RConstString _ ->
3656            failwithf "RConstString cannot be returned from a daemon function"
3657        | RString n ->
3658            pr "struct %s_ret {\n" name;
3659            pr "  string %s<>;\n" n;
3660            pr "};\n\n"
3661        | RStringList n ->
3662            pr "struct %s_ret {\n" name;
3663            pr "  str %s<>;\n" n;
3664            pr "};\n\n"
3665        | RStruct (n, typ) ->
3666            pr "struct %s_ret {\n" name;
3667            pr "  guestfs_int_%s %s;\n" typ n;
3668            pr "};\n\n"
3669        | RStructList (n, typ) ->
3670            pr "struct %s_ret {\n" name;
3671            pr "  guestfs_int_%s_list %s;\n" typ n;
3672            pr "};\n\n"
3673        | RHashtable n ->
3674            pr "struct %s_ret {\n" name;
3675            pr "  str %s<>;\n" n;
3676            pr "};\n\n"
3677       );
3678   ) daemon_functions;
3679
3680   (* Table of procedure numbers. *)
3681   pr "enum guestfs_procedure {\n";
3682   List.iter (
3683     fun (shortname, _, proc_nr, _, _, _, _) ->
3684       pr "  GUESTFS_PROC_%s = %d,\n" (String.uppercase shortname) proc_nr
3685   ) daemon_functions;
3686   pr "  GUESTFS_PROC_NR_PROCS\n";
3687   pr "};\n";
3688   pr "\n";
3689
3690   (* Having to choose a maximum message size is annoying for several
3691    * reasons (it limits what we can do in the API), but it (a) makes
3692    * the protocol a lot simpler, and (b) provides a bound on the size
3693    * of the daemon which operates in limited memory space.  For large
3694    * file transfers you should use FTP.
3695    *)
3696   pr "const GUESTFS_MESSAGE_MAX = %d;\n" (4 * 1024 * 1024);
3697   pr "\n";
3698
3699   (* Message header, etc. *)
3700   pr "\
3701 /* The communication protocol is now documented in the guestfs(3)
3702  * manpage.
3703  */
3704
3705 const GUESTFS_PROGRAM = 0x2000F5F5;
3706 const GUESTFS_PROTOCOL_VERSION = 1;
3707
3708 /* These constants must be larger than any possible message length. */
3709 const GUESTFS_LAUNCH_FLAG = 0xf5f55ff5;
3710 const GUESTFS_CANCEL_FLAG = 0xffffeeee;
3711
3712 enum guestfs_message_direction {
3713   GUESTFS_DIRECTION_CALL = 0,        /* client -> daemon */
3714   GUESTFS_DIRECTION_REPLY = 1        /* daemon -> client */
3715 };
3716
3717 enum guestfs_message_status {
3718   GUESTFS_STATUS_OK = 0,
3719   GUESTFS_STATUS_ERROR = 1
3720 };
3721
3722 const GUESTFS_ERROR_LEN = 256;
3723
3724 struct guestfs_message_error {
3725   string error_message<GUESTFS_ERROR_LEN>;
3726 };
3727
3728 struct guestfs_message_header {
3729   unsigned prog;                     /* GUESTFS_PROGRAM */
3730   unsigned vers;                     /* GUESTFS_PROTOCOL_VERSION */
3731   guestfs_procedure proc;            /* GUESTFS_PROC_x */
3732   guestfs_message_direction direction;
3733   unsigned serial;                   /* message serial number */
3734   guestfs_message_status status;
3735 };
3736
3737 const GUESTFS_MAX_CHUNK_SIZE = 8192;
3738
3739 struct guestfs_chunk {
3740   int cancel;                        /* if non-zero, transfer is cancelled */
3741   /* data size is 0 bytes if the transfer has finished successfully */
3742   opaque data<GUESTFS_MAX_CHUNK_SIZE>;
3743 };
3744 "
3745
3746 (* Generate the guestfs-structs.h file. *)
3747 and generate_structs_h () =
3748   generate_header CStyle LGPLv2;
3749
3750   (* This is a public exported header file containing various
3751    * structures.  The structures are carefully written to have
3752    * exactly the same in-memory format as the XDR structures that
3753    * we use on the wire to the daemon.  The reason for creating
3754    * copies of these structures here is just so we don't have to
3755    * export the whole of guestfs_protocol.h (which includes much
3756    * unrelated and XDR-dependent stuff that we don't want to be
3757    * public, or required by clients).
3758    *
3759    * To reiterate, we will pass these structures to and from the
3760    * client with a simple assignment or memcpy, so the format
3761    * must be identical to what rpcgen / the RFC defines.
3762    *)
3763
3764   (* Public structures. *)
3765   List.iter (
3766     fun (typ, cols) ->
3767       pr "struct guestfs_%s {\n" typ;
3768       List.iter (
3769         function
3770         | name, FChar -> pr "  char %s;\n" name
3771         | name, FString -> pr "  char *%s;\n" name
3772         | name, FBuffer ->
3773             pr "  uint32_t %s_len;\n" name;
3774             pr "  char *%s;\n" name
3775         | name, FUUID -> pr "  char %s[32]; /* this is NOT nul-terminated, be careful when printing */\n" name
3776         | name, FUInt32 -> pr "  uint32_t %s;\n" name
3777         | name, FInt32 -> pr "  int32_t %s;\n" name
3778         | name, (FUInt64|FBytes) -> pr "  uint64_t %s;\n" name
3779         | name, FInt64 -> pr "  int64_t %s;\n" name
3780         | name, FOptPercent -> pr "  float %s; /* [0..100] or -1 */\n" name
3781       ) cols;
3782       pr "};\n";
3783       pr "\n";
3784       pr "struct guestfs_%s_list {\n" typ;
3785       pr "  uint32_t len;\n";
3786       pr "  struct guestfs_%s *val;\n" typ;
3787       pr "};\n";
3788       pr "\n";
3789       pr "extern void guestfs_free_%s (struct guestfs_%s *);\n" typ typ;
3790       pr "extern void guestfs_free_%s_list (struct guestfs_%s_list *);\n" typ typ;
3791       pr "\n"
3792   ) structs
3793
3794 (* Generate the guestfs-actions.h file. *)
3795 and generate_actions_h () =
3796   generate_header CStyle LGPLv2;
3797   List.iter (
3798     fun (shortname, style, _, _, _, _, _) ->
3799       let name = "guestfs_" ^ shortname in
3800       generate_prototype ~single_line:true ~newline:true ~handle:"handle"
3801         name style
3802   ) all_functions
3803
3804 (* Generate the client-side dispatch stubs. *)
3805 and generate_client_actions () =
3806   generate_header CStyle LGPLv2;
3807
3808   pr "\
3809 #include <stdio.h>
3810 #include <stdlib.h>
3811
3812 #include \"guestfs.h\"
3813 #include \"guestfs_protocol.h\"
3814
3815 #define error guestfs_error
3816 #define perrorf guestfs_perrorf
3817 #define safe_malloc guestfs_safe_malloc
3818 #define safe_realloc guestfs_safe_realloc
3819 #define safe_strdup guestfs_safe_strdup
3820 #define safe_memdup guestfs_safe_memdup
3821
3822 /* Check the return message from a call for validity. */
3823 static int
3824 check_reply_header (guestfs_h *g,
3825                     const struct guestfs_message_header *hdr,
3826                     int proc_nr, int serial)
3827 {
3828   if (hdr->prog != GUESTFS_PROGRAM) {
3829     error (g, \"wrong program (%%d/%%d)\", hdr->prog, GUESTFS_PROGRAM);
3830     return -1;
3831   }
3832   if (hdr->vers != GUESTFS_PROTOCOL_VERSION) {
3833     error (g, \"wrong protocol version (%%d/%%d)\",
3834            hdr->vers, GUESTFS_PROTOCOL_VERSION);
3835     return -1;
3836   }
3837   if (hdr->direction != GUESTFS_DIRECTION_REPLY) {
3838     error (g, \"unexpected message direction (%%d/%%d)\",
3839            hdr->direction, GUESTFS_DIRECTION_REPLY);
3840     return -1;
3841   }
3842   if (hdr->proc != proc_nr) {
3843     error (g, \"unexpected procedure number (%%d/%%d)\", hdr->proc, proc_nr);
3844     return -1;
3845   }
3846   if (hdr->serial != serial) {
3847     error (g, \"unexpected serial (%%d/%%d)\", hdr->serial, serial);
3848     return -1;
3849   }
3850
3851   return 0;
3852 }
3853
3854 /* Check we are in the right state to run a high-level action. */
3855 static int
3856 check_state (guestfs_h *g, const char *caller)
3857 {
3858   if (!guestfs_is_ready (g)) {
3859     if (guestfs_is_config (g))
3860       error (g, \"%%s: call launch before using this function\\n(in guestfish, don't forget to use the 'run' command)\",
3861         caller);
3862     else if (guestfs_is_launching (g))
3863       error (g, \"%%s: call wait_ready() before using this function\",
3864         caller);
3865     else
3866       error (g, \"%%s called from the wrong state, %%d != READY\",
3867         caller, guestfs_get_state (g));
3868     return -1;
3869   }
3870   return 0;
3871 }
3872
3873 ";
3874
3875   (* Client-side stubs for each function. *)
3876   List.iter (
3877     fun (shortname, style, _, _, _, _, _) ->
3878       let name = "guestfs_" ^ shortname in
3879
3880       (* Generate the context struct which stores the high-level
3881        * state between callback functions.
3882        *)
3883       pr "struct %s_ctx {\n" shortname;
3884       pr "  /* This flag is set by the callbacks, so we know we've done\n";
3885       pr "   * the callbacks as expected, and in the right sequence.\n";
3886       pr "   * 0 = not called, 1 = reply_cb called.\n";
3887       pr "   */\n";
3888       pr "  int cb_sequence;\n";
3889       pr "  struct guestfs_message_header hdr;\n";
3890       pr "  struct guestfs_message_error err;\n";
3891       (match fst style with
3892        | RErr -> ()
3893        | RConstString _ ->
3894            failwithf "RConstString cannot be returned from a daemon function"
3895        | RInt _ | RInt64 _
3896        | RBool _ | RString _ | RStringList _
3897        | RStruct _ | RStructList _
3898        | RHashtable _ ->
3899            pr "  struct %s_ret ret;\n" name
3900       );
3901       pr "};\n";
3902       pr "\n";
3903
3904       (* Generate the reply callback function. *)
3905       pr "static void %s_reply_cb (guestfs_h *g, void *data, XDR *xdr)\n" shortname;
3906       pr "{\n";
3907       pr "  guestfs_main_loop *ml = guestfs_get_main_loop (g);\n";
3908       pr "  struct %s_ctx *ctx = (struct %s_ctx *) data;\n" shortname shortname;
3909       pr "\n";
3910       pr "  /* This should definitely not happen. */\n";
3911       pr "  if (ctx->cb_sequence != 0) {\n";
3912       pr "    ctx->cb_sequence = 9999;\n";
3913       pr "    error (g, \"%%s: internal error: reply callback called twice\", \"%s\");\n" name;
3914       pr "    return;\n";
3915       pr "  }\n";
3916       pr "\n";
3917       pr "  ml->main_loop_quit (ml, g);\n";
3918       pr "\n";
3919       pr "  if (!xdr_guestfs_message_header (xdr, &ctx->hdr)) {\n";
3920       pr "    error (g, \"%%s: failed to parse reply header\", \"%s\");\n" name;
3921       pr "    return;\n";
3922       pr "  }\n";
3923       pr "  if (ctx->hdr.status == GUESTFS_STATUS_ERROR) {\n";
3924       pr "    if (!xdr_guestfs_message_error (xdr, &ctx->err)) {\n";
3925       pr "      error (g, \"%%s: failed to parse reply error\", \"%s\");\n"
3926         name;
3927       pr "      return;\n";
3928       pr "    }\n";
3929       pr "    goto done;\n";
3930       pr "  }\n";
3931
3932       (match fst style with
3933        | RErr -> ()
3934        | RConstString _ ->
3935            failwithf "RConstString cannot be returned from a daemon function"
3936        | RInt _ | RInt64 _
3937        | RBool _ | RString _ | RStringList _
3938        | RStruct _ | RStructList _
3939        | RHashtable _ ->
3940            pr "  if (!xdr_%s_ret (xdr, &ctx->ret)) {\n" name;
3941            pr "    error (g, \"%%s: failed to parse reply\", \"%s\");\n" name;
3942            pr "    return;\n";
3943            pr "  }\n";
3944       );
3945
3946       pr " done:\n";
3947       pr "  ctx->cb_sequence = 1;\n";
3948       pr "}\n\n";
3949
3950       (* Generate the action stub. *)
3951       generate_prototype ~extern:false ~semicolon:false ~newline:true
3952         ~handle:"g" name style;
3953
3954       let error_code =
3955         match fst style with
3956         | RErr | RInt _ | RInt64 _ | RBool _ -> "-1"
3957         | RConstString _ ->
3958             failwithf "RConstString cannot be returned from a daemon function"
3959         | RString _ | RStringList _
3960         | RStruct _ | RStructList _
3961         | RHashtable _ ->
3962             "NULL" in
3963
3964       pr "{\n";
3965
3966       (match snd style with
3967        | [] -> ()
3968        | _ -> pr "  struct %s_args args;\n" name
3969       );
3970
3971       pr "  struct %s_ctx ctx;\n" shortname;
3972       pr "  guestfs_main_loop *ml = guestfs_get_main_loop (g);\n";
3973       pr "  int serial;\n";
3974       pr "\n";
3975       pr "  if (check_state (g, \"%s\") == -1) return %s;\n" name error_code;
3976       pr "  guestfs_set_busy (g);\n";
3977       pr "\n";
3978       pr "  memset (&ctx, 0, sizeof ctx);\n";
3979       pr "\n";
3980
3981       (* Send the main header and arguments. *)
3982       (match snd style with
3983        | [] ->
3984            pr "  serial = guestfs__send_sync (g, GUESTFS_PROC_%s, NULL, NULL);\n"
3985              (String.uppercase shortname)
3986        | args ->
3987            List.iter (
3988              function
3989              | String n ->
3990                  pr "  args.%s = (char *) %s;\n" n n
3991              | OptString n ->
3992                  pr "  args.%s = %s ? (char **) &%s : NULL;\n" n n n
3993              | StringList n ->
3994                  pr "  args.%s.%s_val = (char **) %s;\n" n n n;
3995                  pr "  for (args.%s.%s_len = 0; %s[args.%s.%s_len]; args.%s.%s_len++) ;\n" n n n n n n n;
3996              | Bool n ->
3997                  pr "  args.%s = %s;\n" n n
3998              | Int n ->
3999                  pr "  args.%s = %s;\n" n n
4000              | FileIn _ | FileOut _ -> ()
4001            ) args;
4002            pr "  serial = guestfs__send_sync (g, GUESTFS_PROC_%s,\n"
4003              (String.uppercase shortname);
4004            pr "        (xdrproc_t) xdr_%s_args, (char *) &args);\n"
4005              name;
4006       );
4007       pr "  if (serial == -1) {\n";
4008       pr "    guestfs_end_busy (g);\n";
4009       pr "    return %s;\n" error_code;
4010       pr "  }\n";
4011       pr "\n";
4012
4013       (* Send any additional files (FileIn) requested. *)
4014       let need_read_reply_label = ref false in
4015       List.iter (
4016         function
4017         | FileIn n ->
4018             pr "  {\n";
4019             pr "    int r;\n";
4020             pr "\n";
4021             pr "    r = guestfs__send_file_sync (g, %s);\n" n;
4022             pr "    if (r == -1) {\n";
4023             pr "      guestfs_end_busy (g);\n";
4024             pr "      return %s;\n" error_code;
4025             pr "    }\n";
4026             pr "    if (r == -2) /* daemon cancelled */\n";
4027             pr "      goto read_reply;\n";
4028             need_read_reply_label := true;
4029             pr "  }\n";
4030             pr "\n";
4031         | _ -> ()
4032       ) (snd style);
4033
4034       (* Wait for the reply from the remote end. *)
4035       if !need_read_reply_label then pr " read_reply:\n";
4036       pr "  guestfs__switch_to_receiving (g);\n";
4037       pr "  ctx.cb_sequence = 0;\n";
4038       pr "  guestfs_set_reply_callback (g, %s_reply_cb, &ctx);\n" shortname;
4039       pr "  (void) ml->main_loop_run (ml, g);\n";
4040       pr "  guestfs_set_reply_callback (g, NULL, NULL);\n";
4041       pr "  if (ctx.cb_sequence != 1) {\n";
4042       pr "    error (g, \"%%s reply failed, see earlier error messages\", \"%s\");\n" name;
4043       pr "    guestfs_end_busy (g);\n";
4044       pr "    return %s;\n" error_code;
4045       pr "  }\n";
4046       pr "\n";
4047
4048       pr "  if (check_reply_header (g, &ctx.hdr, GUESTFS_PROC_%s, serial) == -1) {\n"
4049         (String.uppercase shortname);
4050       pr "    guestfs_end_busy (g);\n";
4051       pr "    return %s;\n" error_code;
4052       pr "  }\n";
4053       pr "\n";
4054
4055       pr "  if (ctx.hdr.status == GUESTFS_STATUS_ERROR) {\n";
4056       pr "    error (g, \"%%s\", ctx.err.error_message);\n";
4057       pr "    free (ctx.err.error_message);\n";
4058       pr "    guestfs_end_busy (g);\n";
4059       pr "    return %s;\n" error_code;
4060       pr "  }\n";
4061       pr "\n";
4062
4063       (* Expecting to receive further files (FileOut)? *)
4064       List.iter (
4065         function
4066         | FileOut n ->
4067             pr "  if (guestfs__receive_file_sync (g, %s) == -1) {\n" n;
4068             pr "    guestfs_end_busy (g);\n";
4069             pr "    return %s;\n" error_code;
4070             pr "  }\n";
4071             pr "\n";
4072         | _ -> ()
4073       ) (snd style);
4074
4075       pr "  guestfs_end_busy (g);\n";
4076
4077       (match fst style with
4078        | RErr -> pr "  return 0;\n"
4079        | RInt n | RInt64 n | RBool n ->
4080            pr "  return ctx.ret.%s;\n" n
4081        | RConstString _ ->
4082            failwithf "RConstString cannot be returned from a daemon function"
4083        | RString n ->
4084            pr "  return ctx.ret.%s; /* caller will free */\n" n
4085        | RStringList n | RHashtable n ->
4086            pr "  /* caller will free this, but we need to add a NULL entry */\n";
4087            pr "  ctx.ret.%s.%s_val =\n" n n;
4088            pr "    safe_realloc (g, ctx.ret.%s.%s_val,\n" n n;
4089            pr "                  sizeof (char *) * (ctx.ret.%s.%s_len + 1));\n"
4090              n n;
4091            pr "  ctx.ret.%s.%s_val[ctx.ret.%s.%s_len] = NULL;\n" n n n n;
4092            pr "  return ctx.ret.%s.%s_val;\n" n n
4093        | RStruct (n, _) ->
4094            pr "  /* caller will free this */\n";
4095            pr "  return safe_memdup (g, &ctx.ret.%s, sizeof (ctx.ret.%s));\n" n n
4096        | RStructList (n, _) ->
4097            pr "  /* caller will free this */\n";
4098            pr "  return safe_memdup (g, &ctx.ret.%s, sizeof (ctx.ret.%s));\n" n n
4099       );
4100
4101       pr "}\n\n"
4102   ) daemon_functions;
4103
4104   (* Functions to free structures. *)
4105   pr "/* Structure-freeing functions.  These rely on the fact that the\n";
4106   pr " * structure format is identical to the XDR format.  See note in\n";
4107   pr " * generator.ml.\n";
4108   pr " */\n";
4109   pr "\n";
4110
4111   List.iter (
4112     fun (typ, _) ->
4113       pr "void\n";
4114       pr "guestfs_free_%s (struct guestfs_%s *x)\n" typ typ;
4115       pr "{\n";
4116       pr "  xdr_free ((xdrproc_t) xdr_guestfs_int_%s, (char *) x);\n" typ;
4117       pr "  free (x);\n";
4118       pr "}\n";
4119       pr "\n";
4120
4121       pr "void\n";
4122       pr "guestfs_free_%s_list (struct guestfs_%s_list *x)\n" typ typ;
4123       pr "{\n";
4124       pr "  xdr_free ((xdrproc_t) xdr_guestfs_int_%s_list, (char *) x);\n" typ;
4125       pr "  free (x);\n";
4126       pr "}\n";
4127       pr "\n";
4128
4129   ) structs;
4130
4131 (* Generate daemon/actions.h. *)
4132 and generate_daemon_actions_h () =
4133   generate_header CStyle GPLv2;
4134
4135   pr "#include \"../src/guestfs_protocol.h\"\n";
4136   pr "\n";
4137
4138   List.iter (
4139     fun (name, style, _, _, _, _, _) ->
4140       generate_prototype
4141         ~single_line:true ~newline:true ~in_daemon:true ~prefix:"do_"
4142         name style;
4143   ) daemon_functions
4144
4145 (* Generate the server-side stubs. *)
4146 and generate_daemon_actions () =
4147   generate_header CStyle GPLv2;
4148
4149   pr "#include <config.h>\n";
4150   pr "\n";
4151   pr "#include <stdio.h>\n";
4152   pr "#include <stdlib.h>\n";
4153   pr "#include <string.h>\n";
4154   pr "#include <inttypes.h>\n";
4155   pr "#include <ctype.h>\n";
4156   pr "#include <rpc/types.h>\n";
4157   pr "#include <rpc/xdr.h>\n";
4158   pr "\n";
4159   pr "#include \"daemon.h\"\n";
4160   pr "#include \"../src/guestfs_protocol.h\"\n";
4161   pr "#include \"actions.h\"\n";
4162   pr "\n";
4163
4164   List.iter (
4165     fun (name, style, _, _, _, _, _) ->
4166       (* Generate server-side stubs. *)
4167       pr "static void %s_stub (XDR *xdr_in)\n" name;
4168       pr "{\n";
4169       let error_code =
4170         match fst style with
4171         | RErr | RInt _ -> pr "  int r;\n"; "-1"
4172         | RInt64 _ -> pr "  int64_t r;\n"; "-1"
4173         | RBool _ -> pr "  int r;\n"; "-1"
4174         | RConstString _ ->
4175             failwithf "RConstString cannot be returned from a daemon function"
4176         | RString _ -> pr "  char *r;\n"; "NULL"
4177         | RStringList _ | RHashtable _ -> pr "  char **r;\n"; "NULL"
4178         | RStruct (_, typ) -> pr "  guestfs_int_%s *r;\n" typ; "NULL"
4179         | RStructList (_, typ) -> pr "  guestfs_int_%s_list *r;\n" typ; "NULL" in
4180
4181       (match snd style with
4182        | [] -> ()
4183        | args ->
4184            pr "  struct guestfs_%s_args args;\n" name;
4185            List.iter (
4186              function
4187                (* Note we allow the string to be writable, in order to
4188                 * allow device name translation.  This is safe because
4189                 * we can modify the string (passed from RPC).
4190                 *)
4191              | String n
4192              | OptString n -> pr "  char *%s;\n" n
4193              | StringList n -> pr "  char **%s;\n" n
4194              | Bool n -> pr "  int %s;\n" n
4195              | Int n -> pr "  int %s;\n" n
4196              | FileIn _ | FileOut _ -> ()
4197            ) args
4198       );
4199       pr "\n";
4200
4201       (match snd style with
4202        | [] -> ()
4203        | args ->
4204            pr "  memset (&args, 0, sizeof args);\n";
4205            pr "\n";
4206            pr "  if (!xdr_guestfs_%s_args (xdr_in, &args)) {\n" name;
4207            pr "    reply_with_error (\"%%s: daemon failed to decode procedure arguments\", \"%s\");\n" name;
4208            pr "    return;\n";
4209            pr "  }\n";
4210            List.iter (
4211              function
4212              | String n -> pr "  %s = args.%s;\n" n n
4213              | OptString n -> pr "  %s = args.%s ? *args.%s : NULL;\n" n n n
4214              | StringList n ->
4215                  pr "  %s = realloc (args.%s.%s_val,\n" n n n;
4216                  pr "                sizeof (char *) * (args.%s.%s_len+1));\n" n n;
4217                  pr "  if (%s == NULL) {\n" n;
4218                  pr "    reply_with_perror (\"realloc\");\n";
4219                  pr "    goto done;\n";
4220                  pr "  }\n";
4221                  pr "  %s[args.%s.%s_len] = NULL;\n" n n n;
4222                  pr "  args.%s.%s_val = %s;\n" n n n;
4223              | Bool n -> pr "  %s = args.%s;\n" n n
4224              | Int n -> pr "  %s = args.%s;\n" n n
4225              | FileIn _ | FileOut _ -> ()
4226            ) args;
4227            pr "\n"
4228       );
4229
4230       (* Don't want to call the impl with any FileIn or FileOut
4231        * parameters, since these go "outside" the RPC protocol.
4232        *)
4233       let argsnofile =
4234         List.filter (function FileIn _ | FileOut _ -> false | _ -> true)
4235           (snd style) in
4236       pr "  r = do_%s " name;
4237       generate_call_args argsnofile;
4238       pr ";\n";
4239
4240       pr "  if (r == %s)\n" error_code;
4241       pr "    /* do_%s has already called reply_with_error */\n" name;
4242       pr "    goto done;\n";
4243       pr "\n";
4244
4245       (* If there are any FileOut parameters, then the impl must
4246        * send its own reply.
4247        *)
4248       let no_reply =
4249         List.exists (function FileOut _ -> true | _ -> false) (snd style) in
4250       if no_reply then
4251         pr "  /* do_%s has already sent a reply */\n" name
4252       else (
4253         match fst style with
4254         | RErr -> pr "  reply (NULL, NULL);\n"
4255         | RInt n | RInt64 n | RBool n ->
4256             pr "  struct guestfs_%s_ret ret;\n" name;
4257             pr "  ret.%s = r;\n" n;
4258             pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n"
4259               name
4260         | RConstString _ ->
4261             failwithf "RConstString cannot be returned from a daemon function"
4262         | RString n ->
4263             pr "  struct guestfs_%s_ret ret;\n" name;
4264             pr "  ret.%s = r;\n" n;
4265             pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n"
4266               name;
4267             pr "  free (r);\n"
4268         | RStringList n | RHashtable n ->
4269             pr "  struct guestfs_%s_ret ret;\n" name;
4270             pr "  ret.%s.%s_len = count_strings (r);\n" n n;
4271             pr "  ret.%s.%s_val = r;\n" n n;
4272             pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n"
4273               name;
4274             pr "  free_strings (r);\n"
4275         | RStruct (n, _) ->
4276             pr "  struct guestfs_%s_ret ret;\n" name;
4277             pr "  ret.%s = *r;\n" n;
4278             pr "  reply ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n"
4279               name;
4280             pr "  xdr_free ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n"
4281               name
4282         | RStructList (n, _) ->
4283             pr "  struct guestfs_%s_ret ret;\n" name;
4284             pr "  ret.%s = *r;\n" n;
4285             pr "  reply ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n"
4286               name;
4287             pr "  xdr_free ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n"
4288               name
4289       );
4290
4291       (* Free the args. *)
4292       (match snd style with
4293        | [] ->
4294            pr "done: ;\n";
4295        | _ ->
4296            pr "done:\n";
4297            pr "  xdr_free ((xdrproc_t) xdr_guestfs_%s_args, (char *) &args);\n"
4298              name
4299       );
4300
4301       pr "}\n\n";
4302   ) daemon_functions;
4303
4304   (* Dispatch function. *)
4305   pr "void dispatch_incoming_message (XDR *xdr_in)\n";
4306   pr "{\n";
4307   pr "  switch (proc_nr) {\n";
4308
4309   List.iter (
4310     fun (name, style, _, _, _, _, _) ->
4311       pr "    case GUESTFS_PROC_%s:\n" (String.uppercase name);
4312       pr "      %s_stub (xdr_in);\n" name;
4313       pr "      break;\n"
4314   ) daemon_functions;
4315
4316   pr "    default:\n";
4317   pr "      reply_with_error (\"dispatch_incoming_message: unknown procedure number %%d, set LIBGUESTFS_PATH to point to the matching libguestfs appliance directory\", proc_nr);\n";
4318   pr "  }\n";
4319   pr "}\n";
4320   pr "\n";
4321
4322   (* LVM columns and tokenization functions. *)
4323   (* XXX This generates crap code.  We should rethink how we
4324    * do this parsing.
4325    *)
4326   List.iter (
4327     function
4328     | typ, cols ->
4329         pr "static const char *lvm_%s_cols = \"%s\";\n"
4330           typ (String.concat "," (List.map fst cols));
4331         pr "\n";
4332
4333         pr "static int lvm_tokenize_%s (char *str, guestfs_int_lvm_%s *r)\n" typ typ;
4334         pr "{\n";
4335         pr "  char *tok, *p, *next;\n";
4336         pr "  int i, j;\n";
4337         pr "\n";
4338         (*
4339           pr "  fprintf (stderr, \"%%s: <<%%s>>\\n\", __func__, str);\n";
4340           pr "\n";
4341         *)
4342         pr "  if (!str) {\n";
4343         pr "    fprintf (stderr, \"%%s: failed: passed a NULL string\\n\", __func__);\n";
4344         pr "    return -1;\n";
4345         pr "  }\n";
4346         pr "  if (!*str || isspace (*str)) {\n";
4347         pr "    fprintf (stderr, \"%%s: failed: passed a empty string or one beginning with whitespace\\n\", __func__);\n";
4348         pr "    return -1;\n";
4349         pr "  }\n";
4350         pr "  tok = str;\n";
4351         List.iter (
4352           fun (name, coltype) ->
4353             pr "  if (!tok) {\n";
4354             pr "    fprintf (stderr, \"%%s: failed: string finished early, around token %%s\\n\", __func__, \"%s\");\n" name;
4355             pr "    return -1;\n";
4356             pr "  }\n";
4357             pr "  p = strchrnul (tok, ',');\n";
4358             pr "  if (*p) next = p+1; else next = NULL;\n";
4359             pr "  *p = '\\0';\n";
4360             (match coltype with
4361              | FString ->
4362                  pr "  r->%s = strdup (tok);\n" name;
4363                  pr "  if (r->%s == NULL) {\n" name;
4364                  pr "    perror (\"strdup\");\n";
4365                  pr "    return -1;\n";
4366                  pr "  }\n"
4367              | FUUID ->
4368                  pr "  for (i = j = 0; i < 32; ++j) {\n";
4369                  pr "    if (tok[j] == '\\0') {\n";
4370                  pr "      fprintf (stderr, \"%%s: failed to parse UUID from '%%s'\\n\", __func__, tok);\n";
4371                  pr "      return -1;\n";
4372                  pr "    } else if (tok[j] != '-')\n";
4373                  pr "      r->%s[i++] = tok[j];\n" name;
4374                  pr "  }\n";
4375              | FBytes ->
4376                  pr "  if (sscanf (tok, \"%%\"SCNu64, &r->%s) != 1) {\n" name;
4377                  pr "    fprintf (stderr, \"%%s: failed to parse size '%%s' from token %%s\\n\", __func__, tok, \"%s\");\n" name;
4378                  pr "    return -1;\n";
4379                  pr "  }\n";
4380              | FInt64 ->
4381                  pr "  if (sscanf (tok, \"%%\"SCNi64, &r->%s) != 1) {\n" name;
4382                  pr "    fprintf (stderr, \"%%s: failed to parse int '%%s' from token %%s\\n\", __func__, tok, \"%s\");\n" name;
4383                  pr "    return -1;\n";
4384                  pr "  }\n";
4385              | FOptPercent ->
4386                  pr "  if (tok[0] == '\\0')\n";
4387                  pr "    r->%s = -1;\n" name;
4388                  pr "  else if (sscanf (tok, \"%%f\", &r->%s) != 1) {\n" name;
4389                  pr "    fprintf (stderr, \"%%s: failed to parse float '%%s' from token %%s\\n\", __func__, tok, \"%s\");\n" name;
4390                  pr "    return -1;\n";
4391                  pr "  }\n";
4392              | FBuffer | FInt32 | FUInt32 | FUInt64 | FChar ->
4393                  assert false (* can never be an LVM column *)
4394             );
4395             pr "  tok = next;\n";
4396         ) cols;
4397
4398         pr "  if (tok != NULL) {\n";
4399         pr "    fprintf (stderr, \"%%s: failed: extra tokens at end of string\\n\", __func__);\n";
4400         pr "    return -1;\n";
4401         pr "  }\n";
4402         pr "  return 0;\n";
4403         pr "}\n";
4404         pr "\n";
4405
4406         pr "guestfs_int_lvm_%s_list *\n" typ;
4407         pr "parse_command_line_%ss (void)\n" typ;
4408         pr "{\n";
4409         pr "  char *out, *err;\n";
4410         pr "  char *p, *pend;\n";
4411         pr "  int r, i;\n";
4412         pr "  guestfs_int_lvm_%s_list *ret;\n" typ;
4413         pr "  void *newp;\n";
4414         pr "\n";
4415         pr "  ret = malloc (sizeof *ret);\n";
4416         pr "  if (!ret) {\n";
4417         pr "    reply_with_perror (\"malloc\");\n";
4418         pr "    return NULL;\n";
4419         pr "  }\n";
4420         pr "\n";
4421         pr "  ret->guestfs_int_lvm_%s_list_len = 0;\n" typ;
4422         pr "  ret->guestfs_int_lvm_%s_list_val = NULL;\n" typ;
4423         pr "\n";
4424         pr "  r = command (&out, &err,\n";
4425         pr "           \"/sbin/lvm\", \"%ss\",\n" typ;
4426         pr "           \"-o\", lvm_%s_cols, \"--unbuffered\", \"--noheadings\",\n" typ;
4427         pr "           \"--nosuffix\", \"--separator\", \",\", \"--units\", \"b\", NULL);\n";
4428         pr "  if (r == -1) {\n";
4429         pr "    reply_with_error (\"%%s\", err);\n";
4430         pr "    free (out);\n";
4431         pr "    free (err);\n";
4432         pr "    free (ret);\n";
4433         pr "    return NULL;\n";
4434         pr "  }\n";
4435         pr "\n";
4436         pr "  free (err);\n";
4437         pr "\n";
4438         pr "  /* Tokenize each line of the output. */\n";
4439         pr "  p = out;\n";
4440         pr "  i = 0;\n";
4441         pr "  while (p) {\n";
4442         pr "    pend = strchr (p, '\\n');       /* Get the next line of output. */\n";
4443         pr "    if (pend) {\n";
4444         pr "      *pend = '\\0';\n";
4445         pr "      pend++;\n";
4446         pr "    }\n";
4447         pr "\n";
4448         pr "    while (*p && isspace (*p))      /* Skip any leading whitespace. */\n";
4449         pr "      p++;\n";
4450         pr "\n";
4451         pr "    if (!*p) {                      /* Empty line?  Skip it. */\n";
4452         pr "      p = pend;\n";
4453         pr "      continue;\n";
4454         pr "    }\n";
4455         pr "\n";
4456         pr "    /* Allocate some space to store this next entry. */\n";
4457         pr "    newp = realloc (ret->guestfs_int_lvm_%s_list_val,\n" typ;
4458         pr "                sizeof (guestfs_int_lvm_%s) * (i+1));\n" typ;
4459         pr "    if (newp == NULL) {\n";
4460         pr "      reply_with_perror (\"realloc\");\n";
4461         pr "      free (ret->guestfs_int_lvm_%s_list_val);\n" typ;
4462         pr "      free (ret);\n";
4463         pr "      free (out);\n";
4464         pr "      return NULL;\n";
4465         pr "    }\n";
4466         pr "    ret->guestfs_int_lvm_%s_list_val = newp;\n" typ;
4467         pr "\n";
4468         pr "    /* Tokenize the next entry. */\n";
4469         pr "    r = lvm_tokenize_%s (p, &ret->guestfs_int_lvm_%s_list_val[i]);\n" typ typ;
4470         pr "    if (r == -1) {\n";
4471         pr "      reply_with_error (\"failed to parse output of '%ss' command\");\n" typ;
4472         pr "      free (ret->guestfs_int_lvm_%s_list_val);\n" typ;
4473         pr "      free (ret);\n";
4474         pr "      free (out);\n";
4475         pr "      return NULL;\n";
4476         pr "    }\n";
4477         pr "\n";
4478         pr "    ++i;\n";
4479         pr "    p = pend;\n";
4480         pr "  }\n";
4481         pr "\n";
4482         pr "  ret->guestfs_int_lvm_%s_list_len = i;\n" typ;
4483         pr "\n";
4484         pr "  free (out);\n";
4485         pr "  return ret;\n";
4486         pr "}\n"
4487
4488   ) ["pv", lvm_pv_cols; "vg", lvm_vg_cols; "lv", lvm_lv_cols]
4489
4490 (* Generate a list of function names, for debugging in the daemon.. *)
4491 and generate_daemon_names () =
4492   generate_header CStyle GPLv2;
4493
4494   pr "#include <config.h>\n";
4495   pr "\n";
4496   pr "#include \"daemon.h\"\n";
4497   pr "\n";
4498
4499   pr "/* This array is indexed by proc_nr.  See guestfs_protocol.x. */\n";
4500   pr "const char *function_names[] = {\n";
4501   List.iter (
4502     fun (name, _, proc_nr, _, _, _, _) -> pr "  [%d] = \"%s\",\n" proc_nr name
4503   ) daemon_functions;
4504   pr "};\n";
4505
4506 (* Generate the tests. *)
4507 and generate_tests () =
4508   generate_header CStyle GPLv2;
4509
4510   pr "\
4511 #include <stdio.h>
4512 #include <stdlib.h>
4513 #include <string.h>
4514 #include <unistd.h>
4515 #include <sys/types.h>
4516 #include <fcntl.h>
4517
4518 #include \"guestfs.h\"
4519
4520 static guestfs_h *g;
4521 static int suppress_error = 0;
4522
4523 static void print_error (guestfs_h *g, void *data, const char *msg)
4524 {
4525   if (!suppress_error)
4526     fprintf (stderr, \"%%s\\n\", msg);
4527 }
4528
4529 static void print_strings (char * const * const argv)
4530 {
4531   int argc;
4532
4533   for (argc = 0; argv[argc] != NULL; ++argc)
4534     printf (\"\\t%%s\\n\", argv[argc]);
4535 }
4536
4537 /*
4538 static void print_table (char * const * const argv)
4539 {
4540   int i;
4541
4542   for (i = 0; argv[i] != NULL; i += 2)
4543     printf (\"%%s: %%s\\n\", argv[i], argv[i+1]);
4544 }
4545 */
4546
4547 static void no_test_warnings (void)
4548 {
4549 ";
4550
4551   List.iter (
4552     function
4553     | name, _, _, _, [], _, _ ->
4554         pr "  fprintf (stderr, \"warning: \\\"guestfs_%s\\\" has no tests\\n\");\n" name
4555     | name, _, _, _, tests, _, _ -> ()
4556   ) all_functions;
4557
4558   pr "}\n";
4559   pr "\n";
4560
4561   (* Generate the actual tests.  Note that we generate the tests
4562    * in reverse order, deliberately, so that (in general) the
4563    * newest tests run first.  This makes it quicker and easier to
4564    * debug them.
4565    *)
4566   let test_names =
4567     List.map (
4568       fun (name, _, _, _, tests, _, _) ->
4569         mapi (generate_one_test name) tests
4570     ) (List.rev all_functions) in
4571   let test_names = List.concat test_names in
4572   let nr_tests = List.length test_names in
4573
4574   pr "\
4575 int main (int argc, char *argv[])
4576 {
4577   char c = 0;
4578   int failed = 0;
4579   const char *filename;
4580   int fd;
4581   int nr_tests, test_num = 0;
4582
4583   setbuf (stdout, NULL);
4584
4585   no_test_warnings ();
4586
4587   g = guestfs_create ();
4588   if (g == NULL) {
4589     printf (\"guestfs_create FAILED\\n\");
4590     exit (1);
4591   }
4592
4593   guestfs_set_error_handler (g, print_error, NULL);
4594
4595   guestfs_set_path (g, \"../appliance\");
4596
4597   filename = \"test1.img\";
4598   fd = open (filename, O_WRONLY|O_CREAT|O_NOCTTY|O_NONBLOCK|O_TRUNC, 0666);
4599   if (fd == -1) {
4600     perror (filename);
4601     exit (1);
4602   }
4603   if (lseek (fd, %d, SEEK_SET) == -1) {
4604     perror (\"lseek\");
4605     close (fd);
4606     unlink (filename);
4607     exit (1);
4608   }
4609   if (write (fd, &c, 1) == -1) {
4610     perror (\"write\");
4611     close (fd);
4612     unlink (filename);
4613     exit (1);
4614   }
4615   if (close (fd) == -1) {
4616     perror (filename);
4617     unlink (filename);
4618     exit (1);
4619   }
4620   if (guestfs_add_drive (g, filename) == -1) {
4621     printf (\"guestfs_add_drive %%s FAILED\\n\", filename);
4622     exit (1);
4623   }
4624
4625   filename = \"test2.img\";
4626   fd = open (filename, O_WRONLY|O_CREAT|O_NOCTTY|O_NONBLOCK|O_TRUNC, 0666);
4627   if (fd == -1) {
4628     perror (filename);
4629     exit (1);
4630   }
4631   if (lseek (fd, %d, SEEK_SET) == -1) {
4632     perror (\"lseek\");
4633     close (fd);
4634     unlink (filename);
4635     exit (1);
4636   }
4637   if (write (fd, &c, 1) == -1) {
4638     perror (\"write\");
4639     close (fd);
4640     unlink (filename);
4641     exit (1);
4642   }
4643   if (close (fd) == -1) {
4644     perror (filename);
4645     unlink (filename);
4646     exit (1);
4647   }
4648   if (guestfs_add_drive (g, filename) == -1) {
4649     printf (\"guestfs_add_drive %%s FAILED\\n\", filename);
4650     exit (1);
4651   }
4652
4653   filename = \"test3.img\";
4654   fd = open (filename, O_WRONLY|O_CREAT|O_NOCTTY|O_NONBLOCK|O_TRUNC, 0666);
4655   if (fd == -1) {
4656     perror (filename);
4657     exit (1);
4658   }
4659   if (lseek (fd, %d, SEEK_SET) == -1) {
4660     perror (\"lseek\");
4661     close (fd);
4662     unlink (filename);
4663     exit (1);
4664   }
4665   if (write (fd, &c, 1) == -1) {
4666     perror (\"write\");
4667     close (fd);
4668     unlink (filename);
4669     exit (1);
4670   }
4671   if (close (fd) == -1) {
4672     perror (filename);
4673     unlink (filename);
4674     exit (1);
4675   }
4676   if (guestfs_add_drive (g, filename) == -1) {
4677     printf (\"guestfs_add_drive %%s FAILED\\n\", filename);
4678     exit (1);
4679   }
4680
4681   if (guestfs_add_drive_ro (g, \"../images/test.sqsh\") == -1) {
4682     printf (\"guestfs_add_drive_ro ../images/test.sqsh FAILED\\n\");
4683     exit (1);
4684   }
4685
4686   if (guestfs_launch (g) == -1) {
4687     printf (\"guestfs_launch FAILED\\n\");
4688     exit (1);
4689   }
4690
4691   /* Set a timeout in case qemu hangs during launch (RHBZ#505329). */
4692   alarm (600);
4693
4694   if (guestfs_wait_ready (g) == -1) {
4695     printf (\"guestfs_wait_ready FAILED\\n\");
4696     exit (1);
4697   }
4698
4699   /* Cancel previous alarm. */
4700   alarm (0);
4701
4702   nr_tests = %d;
4703
4704 " (500 * 1024 * 1024) (50 * 1024 * 1024) (10 * 1024 * 1024) nr_tests;
4705
4706   iteri (
4707     fun i test_name ->
4708       pr "  test_num++;\n";
4709       pr "  printf (\"%%3d/%%3d %s\\n\", test_num, nr_tests);\n" test_name;
4710       pr "  if (%s () == -1) {\n" test_name;
4711       pr "    printf (\"%s FAILED\\n\");\n" test_name;
4712       pr "    failed++;\n";
4713       pr "  }\n";
4714   ) test_names;
4715   pr "\n";
4716
4717   pr "  guestfs_close (g);\n";
4718   pr "  unlink (\"test1.img\");\n";
4719   pr "  unlink (\"test2.img\");\n";
4720   pr "  unlink (\"test3.img\");\n";
4721   pr "\n";
4722
4723   pr "  if (failed > 0) {\n";
4724   pr "    printf (\"***** %%d / %%d tests FAILED *****\\n\", failed, nr_tests);\n";
4725   pr "    exit (1);\n";
4726   pr "  }\n";
4727   pr "\n";
4728
4729   pr "  exit (0);\n";
4730   pr "}\n"
4731
4732 and generate_one_test name i (init, prereq, test) =
4733   let test_name = sprintf "test_%s_%d" name i in
4734
4735   pr "\
4736 static int %s_skip (void)
4737 {
4738   const char *str;
4739
4740   str = getenv (\"TEST_ONLY\");
4741   if (str)
4742     return strstr (str, \"%s\") == NULL;
4743   str = getenv (\"SKIP_%s\");
4744   if (str && strcmp (str, \"1\") == 0) return 1;
4745   str = getenv (\"SKIP_TEST_%s\");
4746   if (str && strcmp (str, \"1\") == 0) return 1;
4747   return 0;
4748 }
4749
4750 " test_name name (String.uppercase test_name) (String.uppercase name);
4751
4752   (match prereq with
4753    | Disabled | Always -> ()
4754    | If code | Unless code ->
4755        pr "static int %s_prereq (void)\n" test_name;
4756        pr "{\n";
4757        pr "  %s\n" code;
4758        pr "}\n";
4759        pr "\n";
4760   );
4761
4762   pr "\
4763 static int %s (void)
4764 {
4765   if (%s_skip ()) {
4766     printf (\"        %%s skipped (reason: environment variable set)\\n\", \"%s\");
4767     return 0;
4768   }
4769
4770 " test_name test_name test_name;
4771
4772   (match prereq with
4773    | Disabled ->
4774        pr "  printf (\"        %%s skipped (reason: test disabled in generator)\\n\", \"%s\");\n" test_name
4775    | If _ ->
4776        pr "  if (! %s_prereq ()) {\n" test_name;
4777        pr "    printf (\"        %%s skipped (reason: test prerequisite)\\n\", \"%s\");\n" test_name;
4778        pr "    return 0;\n";
4779        pr "  }\n";
4780        pr "\n";
4781        generate_one_test_body name i test_name init test;
4782    | Unless _ ->
4783        pr "  if (%s_prereq ()) {\n" test_name;
4784        pr "    printf (\"        %%s skipped (reason: test prerequisite)\\n\", \"%s\");\n" test_name;
4785        pr "    return 0;\n";
4786        pr "  }\n";
4787        pr "\n";
4788        generate_one_test_body name i test_name init test;
4789    | Always ->
4790        generate_one_test_body name i test_name init test
4791   );
4792
4793   pr "  return 0;\n";
4794   pr "}\n";
4795   pr "\n";
4796   test_name
4797
4798 and generate_one_test_body name i test_name init test =
4799   (match init with
4800    | InitNone (* XXX at some point, InitNone and InitEmpty became
4801                * folded together as the same thing.  Really we should
4802                * make InitNone do nothing at all, but the tests may
4803                * need to be checked to make sure this is OK.
4804                *)
4805    | InitEmpty ->
4806        pr "  /* InitNone|InitEmpty for %s */\n" test_name;
4807        List.iter (generate_test_command_call test_name)
4808          [["blockdev_setrw"; "/dev/sda"];
4809           ["umount_all"];
4810           ["lvm_remove_all"]]
4811    | InitBasicFS ->
4812        pr "  /* InitBasicFS for %s: create ext2 on /dev/sda1 */\n" test_name;
4813        List.iter (generate_test_command_call test_name)
4814          [["blockdev_setrw"; "/dev/sda"];
4815           ["umount_all"];
4816           ["lvm_remove_all"];
4817           ["sfdiskM"; "/dev/sda"; ","];
4818           ["mkfs"; "ext2"; "/dev/sda1"];
4819           ["mount"; "/dev/sda1"; "/"]]
4820    | InitBasicFSonLVM ->
4821        pr "  /* InitBasicFSonLVM for %s: create ext2 on /dev/VG/LV */\n"
4822          test_name;
4823        List.iter (generate_test_command_call test_name)
4824          [["blockdev_setrw"; "/dev/sda"];
4825           ["umount_all"];
4826           ["lvm_remove_all"];
4827           ["sfdiskM"; "/dev/sda"; ","];
4828           ["pvcreate"; "/dev/sda1"];
4829           ["vgcreate"; "VG"; "/dev/sda1"];
4830           ["lvcreate"; "LV"; "VG"; "8"];
4831           ["mkfs"; "ext2"; "/dev/VG/LV"];
4832           ["mount"; "/dev/VG/LV"; "/"]]
4833   );
4834
4835   let get_seq_last = function
4836     | [] ->
4837         failwithf "%s: you cannot use [] (empty list) when expecting a command"
4838           test_name
4839     | seq ->
4840         let seq = List.rev seq in
4841         List.rev (List.tl seq), List.hd seq
4842   in
4843
4844   match test with
4845   | TestRun seq ->
4846       pr "  /* TestRun for %s (%d) */\n" name i;
4847       List.iter (generate_test_command_call test_name) seq
4848   | TestOutput (seq, expected) ->
4849       pr "  /* TestOutput for %s (%d) */\n" name i;
4850       pr "  const char *expected = \"%s\";\n" (c_quote expected);
4851       let seq, last = get_seq_last seq in
4852       let test () =
4853         pr "    if (strcmp (r, expected) != 0) {\n";
4854         pr "      fprintf (stderr, \"%s: expected \\\"%%s\\\" but got \\\"%%s\\\"\\n\", expected, r);\n" test_name;
4855         pr "      return -1;\n";
4856         pr "    }\n"
4857       in
4858       List.iter (generate_test_command_call test_name) seq;
4859       generate_test_command_call ~test test_name last
4860   | TestOutputList (seq, expected) ->
4861       pr "  /* TestOutputList for %s (%d) */\n" name i;
4862       let seq, last = get_seq_last seq in
4863       let test () =
4864         iteri (
4865           fun i str ->
4866             pr "    if (!r[%d]) {\n" i;
4867             pr "      fprintf (stderr, \"%s: short list returned from command\\n\");\n" test_name;
4868             pr "      print_strings (r);\n";
4869             pr "      return -1;\n";
4870             pr "    }\n";
4871             pr "    {\n";
4872             pr "      const char *expected = \"%s\";\n" (c_quote str);
4873             pr "      if (strcmp (r[%d], expected) != 0) {\n" i;
4874             pr "        fprintf (stderr, \"%s: expected \\\"%%s\\\" but got \\\"%%s\\\"\\n\", expected, r[%d]);\n" test_name i;
4875             pr "        return -1;\n";
4876             pr "      }\n";
4877             pr "    }\n"
4878         ) expected;
4879         pr "    if (r[%d] != NULL) {\n" (List.length expected);
4880         pr "      fprintf (stderr, \"%s: extra elements returned from command\\n\");\n"
4881           test_name;
4882         pr "      print_strings (r);\n";
4883         pr "      return -1;\n";
4884         pr "    }\n"
4885       in
4886       List.iter (generate_test_command_call test_name) seq;
4887       generate_test_command_call ~test test_name last
4888   | TestOutputListOfDevices (seq, expected) ->
4889       pr "  /* TestOutputListOfDevices for %s (%d) */\n" name i;
4890       let seq, last = get_seq_last seq in
4891       let test () =
4892         iteri (
4893           fun i str ->
4894             pr "    if (!r[%d]) {\n" i;
4895             pr "      fprintf (stderr, \"%s: short list returned from command\\n\");\n" test_name;
4896             pr "      print_strings (r);\n";
4897             pr "      return -1;\n";
4898             pr "    }\n";
4899             pr "    {\n";
4900             pr "      const char *expected = \"%s\";\n" (c_quote str);
4901             pr "      r[%d][5] = 's';\n" i;
4902             pr "      if (strcmp (r[%d], expected) != 0) {\n" i;
4903             pr "        fprintf (stderr, \"%s: expected \\\"%%s\\\" but got \\\"%%s\\\"\\n\", expected, r[%d]);\n" test_name i;
4904             pr "        return -1;\n";
4905             pr "      }\n";
4906             pr "    }\n"
4907         ) expected;
4908         pr "    if (r[%d] != NULL) {\n" (List.length expected);
4909         pr "      fprintf (stderr, \"%s: extra elements returned from command\\n\");\n"
4910           test_name;
4911         pr "      print_strings (r);\n";
4912         pr "      return -1;\n";
4913         pr "    }\n"
4914       in
4915       List.iter (generate_test_command_call test_name) seq;
4916       generate_test_command_call ~test test_name last
4917   | TestOutputInt (seq, expected) ->
4918       pr "  /* TestOutputInt for %s (%d) */\n" name i;
4919       let seq, last = get_seq_last seq in
4920       let test () =
4921         pr "    if (r != %d) {\n" expected;
4922         pr "      fprintf (stderr, \"%s: expected %d but got %%d\\n\","
4923           test_name expected;
4924         pr "               (int) r);\n";
4925         pr "      return -1;\n";
4926         pr "    }\n"
4927       in
4928       List.iter (generate_test_command_call test_name) seq;
4929       generate_test_command_call ~test test_name last
4930   | TestOutputIntOp (seq, op, expected) ->
4931       pr "  /* TestOutputIntOp for %s (%d) */\n" name i;
4932       let seq, last = get_seq_last seq in
4933       let test () =
4934         pr "    if (! (r %s %d)) {\n" op expected;
4935         pr "      fprintf (stderr, \"%s: expected %s %d but got %%d\\n\","
4936           test_name op expected;
4937         pr "               (int) r);\n";
4938         pr "      return -1;\n";
4939         pr "    }\n"
4940       in
4941       List.iter (generate_test_command_call test_name) seq;
4942       generate_test_command_call ~test test_name last
4943   | TestOutputTrue seq ->
4944       pr "  /* TestOutputTrue for %s (%d) */\n" name i;
4945       let seq, last = get_seq_last seq in
4946       let test () =
4947         pr "    if (!r) {\n";
4948         pr "      fprintf (stderr, \"%s: expected true, got false\\n\");\n"
4949           test_name;
4950         pr "      return -1;\n";
4951         pr "    }\n"
4952       in
4953       List.iter (generate_test_command_call test_name) seq;
4954       generate_test_command_call ~test test_name last
4955   | TestOutputFalse seq ->
4956       pr "  /* TestOutputFalse for %s (%d) */\n" name i;
4957       let seq, last = get_seq_last seq in
4958       let test () =
4959         pr "    if (r) {\n";
4960         pr "      fprintf (stderr, \"%s: expected false, got true\\n\");\n"
4961           test_name;
4962         pr "      return -1;\n";
4963         pr "    }\n"
4964       in
4965       List.iter (generate_test_command_call test_name) seq;
4966       generate_test_command_call ~test test_name last
4967   | TestOutputLength (seq, expected) ->
4968       pr "  /* TestOutputLength for %s (%d) */\n" name i;
4969       let seq, last = get_seq_last seq in
4970       let test () =
4971         pr "    int j;\n";
4972         pr "    for (j = 0; j < %d; ++j)\n" expected;
4973         pr "      if (r[j] == NULL) {\n";
4974         pr "        fprintf (stderr, \"%s: short list returned\\n\");\n"
4975           test_name;
4976         pr "        print_strings (r);\n";
4977         pr "        return -1;\n";
4978         pr "      }\n";
4979         pr "    if (r[j] != NULL) {\n";
4980         pr "      fprintf (stderr, \"%s: long list returned\\n\");\n"
4981           test_name;
4982         pr "      print_strings (r);\n";
4983         pr "      return -1;\n";
4984         pr "    }\n"
4985       in
4986       List.iter (generate_test_command_call test_name) seq;
4987       generate_test_command_call ~test test_name last
4988   | TestOutputStruct (seq, checks) ->
4989       pr "  /* TestOutputStruct for %s (%d) */\n" name i;
4990       let seq, last = get_seq_last seq in
4991       let test () =
4992         List.iter (
4993           function
4994           | CompareWithInt (field, expected) ->
4995               pr "    if (r->%s != %d) {\n" field expected;
4996               pr "      fprintf (stderr, \"%s: %s was %%d, expected %d\\n\",\n"
4997                 test_name field expected;
4998               pr "               (int) r->%s);\n" field;
4999               pr "      return -1;\n";
5000               pr "    }\n"
5001           | CompareWithIntOp (field, op, expected) ->
5002               pr "    if (!(r->%s %s %d)) {\n" field op expected;
5003               pr "      fprintf (stderr, \"%s: %s was %%d, expected %s %d\\n\",\n"
5004                 test_name field op expected;
5005               pr "               (int) r->%s);\n" field;
5006               pr "      return -1;\n";
5007               pr "    }\n"
5008           | CompareWithString (field, expected) ->
5009               pr "    if (strcmp (r->%s, \"%s\") != 0) {\n" field expected;
5010               pr "      fprintf (stderr, \"%s: %s was \"%%s\", expected \"%s\"\\n\",\n"
5011                 test_name field expected;
5012               pr "               r->%s);\n" field;
5013               pr "      return -1;\n";
5014               pr "    }\n"
5015           | CompareFieldsIntEq (field1, field2) ->
5016               pr "    if (r->%s != r->%s) {\n" field1 field2;
5017               pr "      fprintf (stderr, \"%s: %s (%%d) <> %s (%%d)\\n\",\n"
5018                 test_name field1 field2;
5019               pr "               (int) r->%s, (int) r->%s);\n" field1 field2;
5020               pr "      return -1;\n";
5021               pr "    }\n"
5022           | CompareFieldsStrEq (field1, field2) ->
5023               pr "    if (strcmp (r->%s, r->%s) != 0) {\n" field1 field2;
5024               pr "      fprintf (stderr, \"%s: %s (\"%%s\") <> %s (\"%%s\")\\n\",\n"
5025                 test_name field1 field2;
5026               pr "               r->%s, r->%s);\n" field1 field2;
5027               pr "      return -1;\n";
5028               pr "    }\n"
5029         ) checks
5030       in
5031       List.iter (generate_test_command_call test_name) seq;
5032       generate_test_command_call ~test test_name last
5033   | TestLastFail seq ->
5034       pr "  /* TestLastFail for %s (%d) */\n" name i;
5035       let seq, last = get_seq_last seq in
5036       List.iter (generate_test_command_call test_name) seq;
5037       generate_test_command_call test_name ~expect_error:true last
5038
5039 (* Generate the code to run a command, leaving the result in 'r'.
5040  * If you expect to get an error then you should set expect_error:true.
5041  *)
5042 and generate_test_command_call ?(expect_error = false) ?test test_name cmd =
5043   match cmd with
5044   | [] -> assert false
5045   | name :: args ->
5046       (* Look up the command to find out what args/ret it has. *)
5047       let style =
5048         try
5049           let _, style, _, _, _, _, _ =
5050             List.find (fun (n, _, _, _, _, _, _) -> n = name) all_functions in
5051           style
5052         with Not_found ->
5053           failwithf "%s: in test, command %s was not found" test_name name in
5054
5055       if List.length (snd style) <> List.length args then
5056         failwithf "%s: in test, wrong number of args given to %s"
5057           test_name name;
5058
5059       pr "  {\n";
5060
5061       List.iter (
5062         function
5063         | OptString n, "NULL" -> ()
5064         | String n, arg
5065         | OptString n, arg ->
5066             pr "    const char *%s = \"%s\";\n" n (c_quote arg);
5067         | Int _, _
5068         | Bool _, _
5069         | FileIn _, _ | FileOut _, _ -> ()
5070         | StringList n, arg ->
5071             let strs = string_split " " arg in
5072             iteri (
5073               fun i str ->
5074                 pr "    const char *%s_%d = \"%s\";\n" n i (c_quote str);
5075             ) strs;
5076             pr "    const char *%s[] = {\n" n;
5077             iteri (
5078               fun i _ -> pr "      %s_%d,\n" n i
5079             ) strs;
5080             pr "      NULL\n";
5081             pr "    };\n";
5082       ) (List.combine (snd style) args);
5083
5084       let error_code =
5085         match fst style with
5086         | RErr | RInt _ | RBool _ -> pr "    int r;\n"; "-1"
5087         | RInt64 _ -> pr "    int64_t r;\n"; "-1"
5088         | RConstString _ -> pr "    const char *r;\n"; "NULL"
5089         | RString _ -> pr "    char *r;\n"; "NULL"
5090         | RStringList _ | RHashtable _ ->
5091             pr "    char **r;\n";
5092             pr "    int i;\n";
5093             "NULL"
5094         | RStruct (_, typ) ->
5095             pr "    struct guestfs_%s *r;\n" typ; "NULL"
5096         | RStructList (_, typ) ->
5097             pr "    struct guestfs_%s_list *r;\n" typ; "NULL" in
5098
5099       pr "    suppress_error = %d;\n" (if expect_error then 1 else 0);
5100       pr "    r = guestfs_%s (g" name;
5101
5102       (* Generate the parameters. *)
5103       List.iter (
5104         function
5105         | OptString _, "NULL" -> pr ", NULL"
5106         | String n, _
5107         | OptString n, _ ->
5108             pr ", %s" n
5109         | FileIn _, arg | FileOut _, arg ->
5110             pr ", \"%s\"" (c_quote arg)
5111         | StringList n, _ ->
5112             pr ", %s" n
5113         | Int _, arg ->
5114             let i =
5115               try int_of_string arg
5116               with Failure "int_of_string" ->
5117                 failwithf "%s: expecting an int, but got '%s'" test_name arg in
5118             pr ", %d" i
5119         | Bool _, arg ->
5120             let b = bool_of_string arg in pr ", %d" (if b then 1 else 0)
5121       ) (List.combine (snd style) args);
5122
5123       pr ");\n";
5124       if not expect_error then
5125         pr "    if (r == %s)\n" error_code
5126       else
5127         pr "    if (r != %s)\n" error_code;
5128       pr "      return -1;\n";
5129
5130       (* Insert the test code. *)
5131       (match test with
5132        | None -> ()
5133        | Some f -> f ()
5134       );
5135
5136       (match fst style with
5137        | RErr | RInt _ | RInt64 _ | RBool _ | RConstString _ -> ()
5138        | RString _ -> pr "    free (r);\n"
5139        | RStringList _ | RHashtable _ ->
5140            pr "    for (i = 0; r[i] != NULL; ++i)\n";
5141            pr "      free (r[i]);\n";
5142            pr "    free (r);\n"
5143        | RStruct (_, typ) ->
5144            pr "    guestfs_free_%s (r);\n" typ
5145        | RStructList (_, typ) ->
5146            pr "    guestfs_free_%s_list (r);\n" typ
5147       );
5148
5149       pr "  }\n"
5150
5151 and c_quote str =
5152   let str = replace_str str "\r" "\\r" in
5153   let str = replace_str str "\n" "\\n" in
5154   let str = replace_str str "\t" "\\t" in
5155   let str = replace_str str "\000" "\\0" in
5156   str
5157
5158 (* Generate a lot of different functions for guestfish. *)
5159 and generate_fish_cmds () =
5160   generate_header CStyle GPLv2;
5161
5162   let all_functions =
5163     List.filter (
5164       fun (_, _, _, flags, _, _, _) -> not (List.mem NotInFish flags)
5165     ) all_functions in
5166   let all_functions_sorted =
5167     List.filter (
5168       fun (_, _, _, flags, _, _, _) -> not (List.mem NotInFish flags)
5169     ) all_functions_sorted in
5170
5171   pr "#include <stdio.h>\n";
5172   pr "#include <stdlib.h>\n";
5173   pr "#include <string.h>\n";
5174   pr "#include <inttypes.h>\n";
5175   pr "#include <ctype.h>\n";
5176   pr "\n";
5177   pr "#include <guestfs.h>\n";
5178   pr "#include \"fish.h\"\n";
5179   pr "\n";
5180
5181   (* list_commands function, which implements guestfish -h *)
5182   pr "void list_commands (void)\n";
5183   pr "{\n";
5184   pr "  printf (\"    %%-16s     %%s\\n\", \"Command\", \"Description\");\n";
5185   pr "  list_builtin_commands ();\n";
5186   List.iter (
5187     fun (name, _, _, flags, _, shortdesc, _) ->
5188       let name = replace_char name '_' '-' in
5189       pr "  printf (\"%%-20s %%s\\n\", \"%s\", \"%s\");\n"
5190         name shortdesc
5191   ) all_functions_sorted;
5192   pr "  printf (\"    Use -h <cmd> / help <cmd> to show detailed help for a command.\\n\");\n";
5193   pr "}\n";
5194   pr "\n";
5195
5196   (* display_command function, which implements guestfish -h cmd *)
5197   pr "void display_command (const char *cmd)\n";
5198   pr "{\n";
5199   List.iter (
5200     fun (name, style, _, flags, _, shortdesc, longdesc) ->
5201       let name2 = replace_char name '_' '-' in
5202       let alias =
5203         try find_map (function FishAlias n -> Some n | _ -> None) flags
5204         with Not_found -> name in
5205       let longdesc = replace_str longdesc "C<guestfs_" "C<" in
5206       let synopsis =
5207         match snd style with
5208         | [] -> name2
5209         | args ->
5210             sprintf "%s <%s>"
5211               name2 (String.concat "> <" (List.map name_of_argt args)) in
5212
5213       let warnings =
5214         if List.mem ProtocolLimitWarning flags then
5215           ("\n\n" ^ protocol_limit_warning)
5216         else "" in
5217
5218       (* For DangerWillRobinson commands, we should probably have
5219        * guestfish prompt before allowing you to use them (especially
5220        * in interactive mode). XXX
5221        *)
5222       let warnings =
5223         warnings ^
5224           if List.mem DangerWillRobinson flags then
5225             ("\n\n" ^ danger_will_robinson)
5226           else "" in
5227
5228       let describe_alias =
5229         if name <> alias then
5230           sprintf "\n\nYou can use '%s' as an alias for this command." alias
5231         else "" in
5232
5233       pr "  if (";
5234       pr "strcasecmp (cmd, \"%s\") == 0" name;
5235       if name <> name2 then
5236         pr " || strcasecmp (cmd, \"%s\") == 0" name2;
5237       if name <> alias then
5238         pr " || strcasecmp (cmd, \"%s\") == 0" alias;
5239       pr ")\n";
5240       pr "    pod2text (\"%s - %s\", %S);\n"
5241         name2 shortdesc
5242         (" " ^ synopsis ^ "\n\n" ^ longdesc ^ warnings ^ describe_alias);
5243       pr "  else\n"
5244   ) all_functions;
5245   pr "    display_builtin_command (cmd);\n";
5246   pr "}\n";
5247   pr "\n";
5248
5249   (* print_* functions *)
5250   List.iter (
5251     fun (typ, cols) ->
5252       let needs_i =
5253         List.exists (function (_, (FUUID|FBuffer)) -> true | _ -> false) cols in
5254
5255       pr "static void print_%s (struct guestfs_%s *%s)\n" typ typ typ;
5256       pr "{\n";
5257       if needs_i then (
5258         pr "  int i;\n";
5259         pr "\n"
5260       );
5261       List.iter (
5262         function
5263         | name, FString ->
5264             pr "  printf (\"%s: %%s\\n\", %s->%s);\n" name typ name
5265         | name, FUUID ->
5266             pr "  printf (\"%s: \");\n" name;
5267             pr "  for (i = 0; i < 32; ++i)\n";
5268             pr "    printf (\"%%c\", %s->%s[i]);\n" typ name;
5269             pr "  printf (\"\\n\");\n"
5270         | name, FBuffer ->
5271             pr "  printf (\"%s: \");\n" name;
5272             pr "  for (i = 0; i < %s->%s_len; ++i)\n" typ name;
5273             pr "    if (isprint (%s->%s[i]))\n" typ name;
5274             pr "      printf (\"%%c\", %s->%s[i]);\n" typ name;
5275             pr "    else\n";
5276             pr "      printf (\"\\\\x%%02x\", %s->%s[i]);\n" typ name;
5277             pr "  printf (\"\\n\");\n"
5278         | name, (FUInt64|FBytes) ->
5279             pr "  printf (\"%s: %%\" PRIu64 \"\\n\", %s->%s);\n" name typ name
5280         | name, FInt64 ->
5281             pr "  printf (\"%s: %%\" PRIi64 \"\\n\", %s->%s);\n" name typ name
5282         | name, FUInt32 ->
5283             pr "  printf (\"%s: %%\" PRIu32 \"\\n\", %s->%s);\n" name typ name
5284         | name, FInt32 ->
5285             pr "  printf (\"%s: %%\" PRIi32 \"\\n\", %s->%s);\n" name typ name
5286         | name, FChar ->
5287             pr "  printf (\"%s: %%c\\n\", %s->%s);\n" name typ name
5288         | name, FOptPercent ->
5289             pr "  if (%s->%s >= 0) printf (\"%s: %%g %%%%\\n\", %s->%s);\n"
5290               typ name name typ name;
5291             pr "  else printf (\"%s: \\n\");\n" name
5292       ) cols;
5293       pr "}\n";
5294       pr "\n";
5295       pr "static void print_%s_list (struct guestfs_%s_list *%ss)\n"
5296         typ typ typ;
5297       pr "{\n";
5298       pr "  int i;\n";
5299       pr "\n";
5300       pr "  for (i = 0; i < %ss->len; ++i)\n" typ;
5301       pr "    print_%s (&%ss->val[i]);\n" typ typ;
5302       pr "}\n";
5303       pr "\n";
5304   ) structs;
5305
5306   (* run_<action> actions *)
5307   List.iter (
5308     fun (name, style, _, flags, _, _, _) ->
5309       pr "static int run_%s (const char *cmd, int argc, char *argv[])\n" name;
5310       pr "{\n";
5311       (match fst style with
5312        | RErr
5313        | RInt _
5314        | RBool _ -> pr "  int r;\n"
5315        | RInt64 _ -> pr "  int64_t r;\n"
5316        | RConstString _ -> pr "  const char *r;\n"
5317        | RString _ -> pr "  char *r;\n"
5318        | RStringList _ | RHashtable _ -> pr "  char **r;\n"
5319        | RStruct (_, typ) -> pr "  struct guestfs_%s *r;\n" typ
5320        | RStructList (_, typ) -> pr "  struct guestfs_%s_list *r;\n" typ
5321       );
5322       List.iter (
5323         function
5324         | String n
5325         | OptString n
5326         | FileIn n
5327         | FileOut n -> pr "  const char *%s;\n" n
5328         | StringList n -> pr "  char **%s;\n" n
5329         | Bool n -> pr "  int %s;\n" n
5330         | Int n -> pr "  int %s;\n" n
5331       ) (snd style);
5332
5333       (* Check and convert parameters. *)
5334       let argc_expected = List.length (snd style) in
5335       pr "  if (argc != %d) {\n" argc_expected;
5336       pr "    fprintf (stderr, \"%%s should have %d parameter(s)\\n\", cmd);\n"
5337         argc_expected;
5338       pr "    fprintf (stderr, \"type 'help %%s' for help on %%s\\n\", cmd, cmd);\n";
5339       pr "    return -1;\n";
5340       pr "  }\n";
5341       iteri (
5342         fun i ->
5343           function
5344           | String name -> pr "  %s = argv[%d];\n" name i
5345           | OptString name ->
5346               pr "  %s = strcmp (argv[%d], \"\") != 0 ? argv[%d] : NULL;\n"
5347                 name i i
5348           | FileIn name ->
5349               pr "  %s = strcmp (argv[%d], \"-\") != 0 ? argv[%d] : \"/dev/stdin\";\n"
5350                 name i i
5351           | FileOut name ->
5352               pr "  %s = strcmp (argv[%d], \"-\") != 0 ? argv[%d] : \"/dev/stdout\";\n"
5353                 name i i
5354           | StringList name ->
5355               pr "  %s = parse_string_list (argv[%d]);\n" name i
5356           | Bool name ->
5357               pr "  %s = is_true (argv[%d]) ? 1 : 0;\n" name i
5358           | Int name ->
5359               pr "  %s = atoi (argv[%d]);\n" name i
5360       ) (snd style);
5361
5362       (* Call C API function. *)
5363       let fn =
5364         try find_map (function FishAction n -> Some n | _ -> None) flags
5365         with Not_found -> sprintf "guestfs_%s" name in
5366       pr "  r = %s " fn;
5367       generate_call_args ~handle:"g" (snd style);
5368       pr ";\n";
5369
5370       (* Check return value for errors and display command results. *)
5371       (match fst style with
5372        | RErr -> pr "  return r;\n"
5373        | RInt _ ->
5374            pr "  if (r == -1) return -1;\n";
5375            pr "  printf (\"%%d\\n\", r);\n";
5376            pr "  return 0;\n"
5377        | RInt64 _ ->
5378            pr "  if (r == -1) return -1;\n";
5379            pr "  printf (\"%%\" PRIi64 \"\\n\", r);\n";
5380            pr "  return 0;\n"
5381        | RBool _ ->
5382            pr "  if (r == -1) return -1;\n";
5383            pr "  if (r) printf (\"true\\n\"); else printf (\"false\\n\");\n";
5384            pr "  return 0;\n"
5385        | RConstString _ ->
5386            pr "  if (r == NULL) return -1;\n";
5387            pr "  printf (\"%%s\\n\", r);\n";
5388            pr "  return 0;\n"
5389        | RString _ ->
5390            pr "  if (r == NULL) return -1;\n";
5391            pr "  printf (\"%%s\\n\", r);\n";
5392            pr "  free (r);\n";
5393            pr "  return 0;\n"
5394        | RStringList _ ->
5395            pr "  if (r == NULL) return -1;\n";
5396            pr "  print_strings (r);\n";
5397            pr "  free_strings (r);\n";
5398            pr "  return 0;\n"
5399        | RStruct (_, typ) ->
5400            pr "  if (r == NULL) return -1;\n";
5401            pr "  print_%s (r);\n" typ;
5402            pr "  guestfs_free_%s (r);\n" typ;
5403            pr "  return 0;\n"
5404        | RStructList (_, typ) ->
5405            pr "  if (r == NULL) return -1;\n";
5406            pr "  print_%s_list (r);\n" typ;
5407            pr "  guestfs_free_%s_list (r);\n" typ;
5408            pr "  return 0;\n"
5409        | RHashtable _ ->
5410            pr "  if (r == NULL) return -1;\n";
5411            pr "  print_table (r);\n";
5412            pr "  free_strings (r);\n";
5413            pr "  return 0;\n"
5414       );
5415       pr "}\n";
5416       pr "\n"
5417   ) all_functions;
5418
5419   (* run_action function *)
5420   pr "int run_action (const char *cmd, int argc, char *argv[])\n";
5421   pr "{\n";
5422   List.iter (
5423     fun (name, _, _, flags, _, _, _) ->
5424       let name2 = replace_char name '_' '-' in
5425       let alias =
5426         try find_map (function FishAlias n -> Some n | _ -> None) flags
5427         with Not_found -> name in
5428       pr "  if (";
5429       pr "strcasecmp (cmd, \"%s\") == 0" name;
5430       if name <> name2 then
5431         pr " || strcasecmp (cmd, \"%s\") == 0" name2;
5432       if name <> alias then
5433         pr " || strcasecmp (cmd, \"%s\") == 0" alias;
5434       pr ")\n";
5435       pr "    return run_%s (cmd, argc, argv);\n" name;
5436       pr "  else\n";
5437   ) all_functions;
5438   pr "    {\n";
5439   pr "      fprintf (stderr, \"%%s: unknown command\\n\", cmd);\n";
5440   pr "      return -1;\n";
5441   pr "    }\n";
5442   pr "  return 0;\n";
5443   pr "}\n";
5444   pr "\n"
5445
5446 (* Readline completion for guestfish. *)
5447 and generate_fish_completion () =
5448   generate_header CStyle GPLv2;
5449
5450   let all_functions =
5451     List.filter (
5452       fun (_, _, _, flags, _, _, _) -> not (List.mem NotInFish flags)
5453     ) all_functions in
5454
5455   pr "\
5456 #include <config.h>
5457
5458 #include <stdio.h>
5459 #include <stdlib.h>
5460 #include <string.h>
5461
5462 #ifdef HAVE_LIBREADLINE
5463 #include <readline/readline.h>
5464 #endif
5465
5466 #include \"fish.h\"
5467
5468 #ifdef HAVE_LIBREADLINE
5469
5470 static const char *const commands[] = {
5471   BUILTIN_COMMANDS_FOR_COMPLETION,
5472 ";
5473
5474   (* Get the commands, including the aliases.  They don't need to be
5475    * sorted - the generator() function just does a dumb linear search.
5476    *)
5477   let commands =
5478     List.map (
5479       fun (name, _, _, flags, _, _, _) ->
5480         let name2 = replace_char name '_' '-' in
5481         let alias =
5482           try find_map (function FishAlias n -> Some n | _ -> None) flags
5483           with Not_found -> name in
5484
5485         if name <> alias then [name2; alias] else [name2]
5486     ) all_functions in
5487   let commands = List.flatten commands in
5488
5489   List.iter (pr "  \"%s\",\n") commands;
5490
5491   pr "  NULL
5492 };
5493
5494 static char *
5495 generator (const char *text, int state)
5496 {
5497   static int index, len;
5498   const char *name;
5499
5500   if (!state) {
5501     index = 0;
5502     len = strlen (text);
5503   }
5504
5505   rl_attempted_completion_over = 1;
5506
5507   while ((name = commands[index]) != NULL) {
5508     index++;
5509     if (strncasecmp (name, text, len) == 0)
5510       return strdup (name);
5511   }
5512
5513   return NULL;
5514 }
5515
5516 #endif /* HAVE_LIBREADLINE */
5517
5518 char **do_completion (const char *text, int start, int end)
5519 {
5520   char **matches = NULL;
5521
5522 #ifdef HAVE_LIBREADLINE
5523   rl_completion_append_character = ' ';
5524
5525   if (start == 0)
5526     matches = rl_completion_matches (text, generator);
5527   else if (complete_dest_paths)
5528     matches = rl_completion_matches (text, complete_dest_paths_generator);
5529 #endif
5530
5531   return matches;
5532 }
5533 ";
5534
5535 (* Generate the POD documentation for guestfish. *)
5536 and generate_fish_actions_pod () =
5537   let all_functions_sorted =
5538     List.filter (
5539       fun (_, _, _, flags, _, _, _) ->
5540         not (List.mem NotInFish flags || List.mem NotInDocs flags)
5541     ) all_functions_sorted in
5542
5543   let rex = Str.regexp "C<guestfs_\\([^>]+\\)>" in
5544
5545   List.iter (
5546     fun (name, style, _, flags, _, _, longdesc) ->
5547       let longdesc =
5548         Str.global_substitute rex (
5549           fun s ->
5550             let sub =
5551               try Str.matched_group 1 s
5552               with Not_found ->
5553                 failwithf "error substituting C<guestfs_...> in longdesc of function %s" name in
5554             "C<" ^ replace_char sub '_' '-' ^ ">"
5555         ) longdesc in
5556       let name = replace_char name '_' '-' in
5557       let alias =
5558         try find_map (function FishAlias n -> Some n | _ -> None) flags
5559         with Not_found -> name in
5560
5561       pr "=head2 %s" name;
5562       if name <> alias then
5563         pr " | %s" alias;
5564       pr "\n";
5565       pr "\n";
5566       pr " %s" name;
5567       List.iter (
5568         function
5569         | String n -> pr " %s" n
5570         | OptString n -> pr " %s" n
5571         | StringList n -> pr " '%s ...'" n
5572         | Bool _ -> pr " true|false"
5573         | Int n -> pr " %s" n
5574         | FileIn n | FileOut n -> pr " (%s|-)" n
5575       ) (snd style);
5576       pr "\n";
5577       pr "\n";
5578       pr "%s\n\n" longdesc;
5579
5580       if List.exists (function FileIn _ | FileOut _ -> true
5581                       | _ -> false) (snd style) then
5582         pr "Use C<-> instead of a filename to read/write from stdin/stdout.\n\n";
5583
5584       if List.mem ProtocolLimitWarning flags then
5585         pr "%s\n\n" protocol_limit_warning;
5586
5587       if List.mem DangerWillRobinson flags then
5588         pr "%s\n\n" danger_will_robinson
5589   ) all_functions_sorted
5590
5591 (* Generate a C function prototype. *)
5592 and generate_prototype ?(extern = true) ?(static = false) ?(semicolon = true)
5593     ?(single_line = false) ?(newline = false) ?(in_daemon = false)
5594     ?(prefix = "")
5595     ?handle name style =
5596   if extern then pr "extern ";
5597   if static then pr "static ";
5598   (match fst style with
5599    | RErr -> pr "int "
5600    | RInt _ -> pr "int "
5601    | RInt64 _ -> pr "int64_t "
5602    | RBool _ -> pr "int "
5603    | RConstString _ -> pr "const char *"
5604    | RString _ -> pr "char *"
5605    | RStringList _ | RHashtable _ -> pr "char **"
5606    | RStruct (_, typ) ->
5607        if not in_daemon then pr "struct guestfs_%s *" typ
5608        else pr "guestfs_int_%s *" typ
5609    | RStructList (_, typ) ->
5610        if not in_daemon then pr "struct guestfs_%s_list *" typ
5611        else pr "guestfs_int_%s_list *" typ
5612   );
5613   pr "%s%s (" prefix name;
5614   if handle = None && List.length (snd style) = 0 then
5615     pr "void"
5616   else (
5617     let comma = ref false in
5618     (match handle with
5619      | None -> ()
5620      | Some handle -> pr "guestfs_h *%s" handle; comma := true
5621     );
5622     let next () =
5623       if !comma then (
5624         if single_line then pr ", " else pr ",\n\t\t"
5625       );
5626       comma := true
5627     in
5628     List.iter (
5629       function
5630       | String n
5631       | OptString n ->
5632           next ();
5633           if not in_daemon then pr "const char *%s" n
5634           else pr "char *%s" n
5635       | StringList n ->
5636           next ();
5637           if not in_daemon then pr "char * const* const %s" n
5638           else pr "char **%s" n
5639       | Bool n -> next (); pr "int %s" n
5640       | Int n -> next (); pr "int %s" n
5641       | FileIn n
5642       | FileOut n ->
5643           if not in_daemon then (next (); pr "const char *%s" n)
5644     ) (snd style);
5645   );
5646   pr ")";
5647   if semicolon then pr ";";
5648   if newline then pr "\n"
5649
5650 (* Generate C call arguments, eg "(handle, foo, bar)" *)
5651 and generate_call_args ?handle args =
5652   pr "(";
5653   let comma = ref false in
5654   (match handle with
5655    | None -> ()
5656    | Some handle -> pr "%s" handle; comma := true
5657   );
5658   List.iter (
5659     fun arg ->
5660       if !comma then pr ", ";
5661       comma := true;
5662       pr "%s" (name_of_argt arg)
5663   ) args;
5664   pr ")"
5665
5666 (* Generate the OCaml bindings interface. *)
5667 and generate_ocaml_mli () =
5668   generate_header OCamlStyle LGPLv2;
5669
5670   pr "\
5671 (** For API documentation you should refer to the C API
5672     in the guestfs(3) manual page.  The OCaml API uses almost
5673     exactly the same calls. *)
5674
5675 type t
5676 (** A [guestfs_h] handle. *)
5677
5678 exception Error of string
5679 (** This exception is raised when there is an error. *)
5680
5681 val create : unit -> t
5682
5683 val close : t -> unit
5684 (** Handles are closed by the garbage collector when they become
5685     unreferenced, but callers can also call this in order to
5686     provide predictable cleanup. *)
5687
5688 ";
5689   generate_ocaml_structure_decls ();
5690
5691   (* The actions. *)
5692   List.iter (
5693     fun (name, style, _, _, _, shortdesc, _) ->
5694       generate_ocaml_prototype name style;
5695       pr "(** %s *)\n" shortdesc;
5696       pr "\n"
5697   ) all_functions
5698
5699 (* Generate the OCaml bindings implementation. *)
5700 and generate_ocaml_ml () =
5701   generate_header OCamlStyle LGPLv2;
5702
5703   pr "\
5704 type t
5705 exception Error of string
5706 external create : unit -> t = \"ocaml_guestfs_create\"
5707 external close : t -> unit = \"ocaml_guestfs_close\"
5708
5709 let () =
5710   Callback.register_exception \"ocaml_guestfs_error\" (Error \"\")
5711
5712 ";
5713
5714   generate_ocaml_structure_decls ();
5715
5716   (* The actions. *)
5717   List.iter (
5718     fun (name, style, _, _, _, shortdesc, _) ->
5719       generate_ocaml_prototype ~is_external:true name style;
5720   ) all_functions
5721
5722 (* Generate the OCaml bindings C implementation. *)
5723 and generate_ocaml_c () =
5724   generate_header CStyle LGPLv2;
5725
5726   pr "\
5727 #include <stdio.h>
5728 #include <stdlib.h>
5729 #include <string.h>
5730
5731 #include <caml/config.h>
5732 #include <caml/alloc.h>
5733 #include <caml/callback.h>
5734 #include <caml/fail.h>
5735 #include <caml/memory.h>
5736 #include <caml/mlvalues.h>
5737 #include <caml/signals.h>
5738
5739 #include <guestfs.h>
5740
5741 #include \"guestfs_c.h\"
5742
5743 /* Copy a hashtable of string pairs into an assoc-list.  We return
5744  * the list in reverse order, but hashtables aren't supposed to be
5745  * ordered anyway.
5746  */
5747 static CAMLprim value
5748 copy_table (char * const * argv)
5749 {
5750   CAMLparam0 ();
5751   CAMLlocal5 (rv, pairv, kv, vv, cons);
5752   int i;
5753
5754   rv = Val_int (0);
5755   for (i = 0; argv[i] != NULL; i += 2) {
5756     kv = caml_copy_string (argv[i]);
5757     vv = caml_copy_string (argv[i+1]);
5758     pairv = caml_alloc (2, 0);
5759     Store_field (pairv, 0, kv);
5760     Store_field (pairv, 1, vv);
5761     cons = caml_alloc (2, 0);
5762     Store_field (cons, 1, rv);
5763     rv = cons;
5764     Store_field (cons, 0, pairv);
5765   }
5766
5767   CAMLreturn (rv);
5768 }
5769
5770 ";
5771
5772   (* Struct copy functions. *)
5773   List.iter (
5774     fun (typ, cols) ->
5775       let has_optpercent_col =
5776         List.exists (function (_, FOptPercent) -> true | _ -> false) cols in
5777
5778       pr "static CAMLprim value\n";
5779       pr "copy_%s (const struct guestfs_%s *%s)\n" typ typ typ;
5780       pr "{\n";
5781       pr "  CAMLparam0 ();\n";
5782       if has_optpercent_col then
5783         pr "  CAMLlocal3 (rv, v, v2);\n"
5784       else
5785         pr "  CAMLlocal2 (rv, v);\n";
5786       pr "\n";
5787       pr "  rv = caml_alloc (%d, 0);\n" (List.length cols);
5788       iteri (
5789         fun i col ->
5790           (match col with
5791            | name, FString ->
5792                pr "  v = caml_copy_string (%s->%s);\n" typ name
5793            | name, FBuffer ->
5794                pr "  v = caml_alloc_string (%s->%s_len);\n" typ name;
5795                pr "  memcpy (String_val (v), %s->%s, %s->%s_len);\n"
5796                  typ name typ name
5797            | name, FUUID ->
5798                pr "  v = caml_alloc_string (32);\n";
5799                pr "  memcpy (String_val (v), %s->%s, 32);\n" typ name
5800            | name, (FBytes|FInt64|FUInt64) ->
5801                pr "  v = caml_copy_int64 (%s->%s);\n" typ name
5802            | name, (FInt32|FUInt32) ->
5803                pr "  v = caml_copy_int32 (%s->%s);\n" typ name
5804            | name, FOptPercent ->
5805                pr "  if (%s->%s >= 0) { /* Some %s */\n" typ name name;
5806                pr "    v2 = caml_copy_double (%s->%s);\n" typ name;
5807                pr "    v = caml_alloc (1, 0);\n";
5808                pr "    Store_field (v, 0, v2);\n";
5809                pr "  } else /* None */\n";
5810                pr "    v = Val_int (0);\n";
5811            | name, FChar ->
5812                pr "  v = Val_int (%s->%s);\n" typ name
5813           );
5814           pr "  Store_field (rv, %d, v);\n" i
5815       ) cols;
5816       pr "  CAMLreturn (rv);\n";
5817       pr "}\n";
5818       pr "\n";
5819
5820       pr "static CAMLprim value\n";
5821       pr "copy_%s_list (const struct guestfs_%s_list *%ss)\n"
5822         typ typ typ;
5823       pr "{\n";
5824       pr "  CAMLparam0 ();\n";
5825       pr "  CAMLlocal2 (rv, v);\n";
5826       pr "  int i;\n";
5827       pr "\n";
5828       pr "  if (%ss->len == 0)\n" typ;
5829       pr "    CAMLreturn (Atom (0));\n";
5830       pr "  else {\n";
5831       pr "    rv = caml_alloc (%ss->len, 0);\n" typ;
5832       pr "    for (i = 0; i < %ss->len; ++i) {\n" typ;
5833       pr "      v = copy_%s (&%ss->val[i]);\n" typ typ;
5834       pr "      caml_modify (&Field (rv, i), v);\n";
5835       pr "    }\n";
5836       pr "    CAMLreturn (rv);\n";
5837       pr "  }\n";
5838       pr "}\n";
5839       pr "\n";
5840   ) structs;
5841
5842   (* The wrappers. *)
5843   List.iter (
5844     fun (name, style, _, _, _, _, _) ->
5845       let params =
5846         "gv" :: List.map (fun arg -> name_of_argt arg ^ "v") (snd style) in
5847
5848       pr "CAMLprim value\n";
5849       pr "ocaml_guestfs_%s (value %s" name (List.hd params);
5850       List.iter (pr ", value %s") (List.tl params);
5851       pr ")\n";
5852       pr "{\n";
5853
5854       (match params with
5855        | [p1; p2; p3; p4; p5] ->
5856            pr "  CAMLparam5 (%s);\n" (String.concat ", " params)
5857        | p1 :: p2 :: p3 :: p4 :: p5 :: rest ->
5858            pr "  CAMLparam5 (%s);\n" (String.concat ", " [p1; p2; p3; p4; p5]);
5859            pr "  CAMLxparam%d (%s);\n"
5860              (List.length rest) (String.concat ", " rest)
5861        | ps ->
5862            pr "  CAMLparam%d (%s);\n" (List.length ps) (String.concat ", " ps)
5863       );
5864       pr "  CAMLlocal1 (rv);\n";
5865       pr "\n";
5866
5867       pr "  guestfs_h *g = Guestfs_val (gv);\n";
5868       pr "  if (g == NULL)\n";
5869       pr "    caml_failwith (\"%s: used handle after closing it\");\n" name;
5870       pr "\n";
5871
5872       List.iter (
5873         function
5874         | String n
5875         | FileIn n
5876         | FileOut n ->
5877             pr "  const char *%s = String_val (%sv);\n" n n
5878         | OptString n ->
5879             pr "  const char *%s =\n" n;
5880             pr "    %sv != Val_int (0) ? String_val (Field (%sv, 0)) : NULL;\n"
5881               n n
5882         | StringList n ->
5883             pr "  char **%s = ocaml_guestfs_strings_val (g, %sv);\n" n n
5884         | Bool n ->
5885             pr "  int %s = Bool_val (%sv);\n" n n
5886         | Int n ->
5887             pr "  int %s = Int_val (%sv);\n" n n
5888       ) (snd style);
5889       let error_code =
5890         match fst style with
5891         | RErr -> pr "  int r;\n"; "-1"
5892         | RInt _ -> pr "  int r;\n"; "-1"
5893         | RInt64 _ -> pr "  int64_t r;\n"; "-1"
5894         | RBool _ -> pr "  int r;\n"; "-1"
5895         | RConstString _ -> pr "  const char *r;\n"; "NULL"
5896         | RString _ -> pr "  char *r;\n"; "NULL"
5897         | RStringList _ ->
5898             pr "  int i;\n";
5899             pr "  char **r;\n";
5900             "NULL"
5901         | RStruct (_, typ) ->
5902             pr "  struct guestfs_%s *r;\n" typ; "NULL"
5903         | RStructList (_, typ) ->
5904             pr "  struct guestfs_%s_list *r;\n" typ; "NULL"
5905         | RHashtable _ ->
5906             pr "  int i;\n";
5907             pr "  char **r;\n";
5908             "NULL" in
5909       pr "\n";
5910
5911       pr "  caml_enter_blocking_section ();\n";
5912       pr "  r = guestfs_%s " name;
5913       generate_call_args ~handle:"g" (snd style);
5914       pr ";\n";
5915       pr "  caml_leave_blocking_section ();\n";
5916
5917       List.iter (
5918         function
5919         | StringList n ->
5920             pr "  ocaml_guestfs_free_strings (%s);\n" n;
5921         | String _ | OptString _ | Bool _ | Int _ | FileIn _ | FileOut _ -> ()
5922       ) (snd style);
5923
5924       pr "  if (r == %s)\n" error_code;
5925       pr "    ocaml_guestfs_raise_error (g, \"%s\");\n" name;
5926       pr "\n";
5927
5928       (match fst style with
5929        | RErr -> pr "  rv = Val_unit;\n"
5930        | RInt _ -> pr "  rv = Val_int (r);\n"
5931        | RInt64 _ ->
5932            pr "  rv = caml_copy_int64 (r);\n"
5933        | RBool _ -> pr "  rv = Val_bool (r);\n"
5934        | RConstString _ -> pr "  rv = caml_copy_string (r);\n"
5935        | RString _ ->
5936            pr "  rv = caml_copy_string (r);\n";
5937            pr "  free (r);\n"
5938        | RStringList _ ->
5939            pr "  rv = caml_copy_string_array ((const char **) r);\n";
5940            pr "  for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
5941            pr "  free (r);\n"
5942        | RStruct (_, typ) ->
5943            pr "  rv = copy_%s (r);\n" typ;
5944            pr "  guestfs_free_%s (r);\n" typ;
5945        | RStructList (_, typ) ->
5946            pr "  rv = copy_%s_list (r);\n" typ;
5947            pr "  guestfs_free_%s_list (r);\n" typ;
5948        | RHashtable _ ->
5949            pr "  rv = copy_table (r);\n";
5950            pr "  for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
5951            pr "  free (r);\n";
5952       );
5953
5954       pr "  CAMLreturn (rv);\n";
5955       pr "}\n";
5956       pr "\n";
5957
5958       if List.length params > 5 then (
5959         pr "CAMLprim value\n";
5960         pr "ocaml_guestfs_%s_byte (value *argv, int argn)\n" name;
5961         pr "{\n";
5962         pr "  return ocaml_guestfs_%s (argv[0]" name;
5963         iteri (fun i _ -> pr ", argv[%d]" i) (List.tl params);
5964         pr ");\n";
5965         pr "}\n";
5966         pr "\n"
5967       )
5968   ) all_functions
5969
5970 and generate_ocaml_structure_decls () =
5971   List.iter (
5972     fun (typ, cols) ->
5973       pr "type %s = {\n" typ;
5974       List.iter (
5975         function
5976         | name, FString -> pr "  %s : string;\n" name
5977         | name, FBuffer -> pr "  %s : string;\n" name
5978         | name, FUUID -> pr "  %s : string;\n" name
5979         | name, (FBytes|FInt64|FUInt64) -> pr "  %s : int64;\n" name
5980         | name, (FInt32|FUInt32) -> pr "  %s : int32;\n" name
5981         | name, FChar -> pr "  %s : char;\n" name
5982         | name, FOptPercent -> pr "  %s : float option;\n" name
5983       ) cols;
5984       pr "}\n";
5985       pr "\n"
5986   ) structs
5987
5988 and generate_ocaml_prototype ?(is_external = false) name style =
5989   if is_external then pr "external " else pr "val ";
5990   pr "%s : t -> " name;
5991   List.iter (
5992     function
5993     | String _ | FileIn _ | FileOut _ -> pr "string -> "
5994     | OptString _ -> pr "string option -> "
5995     | StringList _ -> pr "string array -> "
5996     | Bool _ -> pr "bool -> "
5997     | Int _ -> pr "int -> "
5998   ) (snd style);
5999   (match fst style with
6000    | RErr -> pr "unit" (* all errors are turned into exceptions *)
6001    | RInt _ -> pr "int"
6002    | RInt64 _ -> pr "int64"
6003    | RBool _ -> pr "bool"
6004    | RConstString _ -> pr "string"
6005    | RString _ -> pr "string"
6006    | RStringList _ -> pr "string array"
6007    | RStruct (_, typ) -> pr "%s" typ
6008    | RStructList (_, typ) -> pr "%s array" typ
6009    | RHashtable _ -> pr "(string * string) list"
6010   );
6011   if is_external then (
6012     pr " = ";
6013     if List.length (snd style) + 1 > 5 then
6014       pr "\"ocaml_guestfs_%s_byte\" " name;
6015     pr "\"ocaml_guestfs_%s\"" name
6016   );
6017   pr "\n"
6018
6019 (* Generate Perl xs code, a sort of crazy variation of C with macros. *)
6020 and generate_perl_xs () =
6021   generate_header CStyle LGPLv2;
6022
6023   pr "\
6024 #include \"EXTERN.h\"
6025 #include \"perl.h\"
6026 #include \"XSUB.h\"
6027
6028 #include <guestfs.h>
6029
6030 #ifndef PRId64
6031 #define PRId64 \"lld\"
6032 #endif
6033
6034 static SV *
6035 my_newSVll(long long val) {
6036 #ifdef USE_64_BIT_ALL
6037   return newSViv(val);
6038 #else
6039   char buf[100];
6040   int len;
6041   len = snprintf(buf, 100, \"%%\" PRId64, val);
6042   return newSVpv(buf, len);
6043 #endif
6044 }
6045
6046 #ifndef PRIu64
6047 #define PRIu64 \"llu\"
6048 #endif
6049
6050 static SV *
6051 my_newSVull(unsigned long long val) {
6052 #ifdef USE_64_BIT_ALL
6053   return newSVuv(val);
6054 #else
6055   char buf[100];
6056   int len;
6057   len = snprintf(buf, 100, \"%%\" PRIu64, val);
6058   return newSVpv(buf, len);
6059 #endif
6060 }
6061
6062 /* http://www.perlmonks.org/?node_id=680842 */
6063 static char **
6064 XS_unpack_charPtrPtr (SV *arg) {
6065   char **ret;
6066   AV *av;
6067   I32 i;
6068
6069   if (!arg || !SvOK (arg) || !SvROK (arg) || SvTYPE (SvRV (arg)) != SVt_PVAV)
6070     croak (\"array reference expected\");
6071
6072   av = (AV *)SvRV (arg);
6073   ret = malloc ((av_len (av) + 1 + 1) * sizeof (char *));
6074   if (!ret)
6075     croak (\"malloc failed\");
6076
6077   for (i = 0; i <= av_len (av); i++) {
6078     SV **elem = av_fetch (av, i, 0);
6079
6080     if (!elem || !*elem)
6081       croak (\"missing element in list\");
6082
6083     ret[i] = SvPV_nolen (*elem);
6084   }
6085
6086   ret[i] = NULL;
6087
6088   return ret;
6089 }
6090
6091 MODULE = Sys::Guestfs  PACKAGE = Sys::Guestfs
6092
6093 PROTOTYPES: ENABLE
6094
6095 guestfs_h *
6096 _create ()
6097    CODE:
6098       RETVAL = guestfs_create ();
6099       if (!RETVAL)
6100         croak (\"could not create guestfs handle\");
6101       guestfs_set_error_handler (RETVAL, NULL, NULL);
6102  OUTPUT:
6103       RETVAL
6104
6105 void
6106 DESTROY (g)
6107       guestfs_h *g;
6108  PPCODE:
6109       guestfs_close (g);
6110
6111 ";
6112
6113   List.iter (
6114     fun (name, style, _, _, _, _, _) ->
6115       (match fst style with
6116        | RErr -> pr "void\n"
6117        | RInt _ -> pr "SV *\n"
6118        | RInt64 _ -> pr "SV *\n"
6119        | RBool _ -> pr "SV *\n"
6120        | RConstString _ -> pr "SV *\n"
6121        | RString _ -> pr "SV *\n"
6122        | RStringList _
6123        | RStruct _ | RStructList _
6124        | RHashtable _ ->
6125            pr "void\n" (* all lists returned implictly on the stack *)
6126       );
6127       (* Call and arguments. *)
6128       pr "%s " name;
6129       generate_call_args ~handle:"g" (snd style);
6130       pr "\n";
6131       pr "      guestfs_h *g;\n";
6132       iteri (
6133         fun i ->
6134           function
6135           | String n | FileIn n | FileOut n -> pr "      char *%s;\n" n
6136           | OptString n ->
6137               (* http://www.perlmonks.org/?node_id=554277
6138                * Note that the implicit handle argument means we have
6139                * to add 1 to the ST(x) operator.
6140                *)
6141               pr "      char *%s = SvOK(ST(%d)) ? SvPV_nolen(ST(%d)) : NULL;\n" n (i+1) (i+1)
6142           | StringList n -> pr "      char **%s;\n" n
6143           | Bool n -> pr "      int %s;\n" n
6144           | Int n -> pr "      int %s;\n" n
6145       ) (snd style);
6146
6147       let do_cleanups () =
6148         List.iter (
6149           function
6150           | String _ | OptString _ | Bool _ | Int _
6151           | FileIn _ | FileOut _ -> ()
6152           | StringList n -> pr "      free (%s);\n" n
6153         ) (snd style)
6154       in
6155
6156       (* Code. *)
6157       (match fst style with
6158        | RErr ->
6159            pr "PREINIT:\n";
6160            pr "      int r;\n";
6161            pr " PPCODE:\n";
6162            pr "      r = guestfs_%s " name;
6163            generate_call_args ~handle:"g" (snd style);
6164            pr ";\n";
6165            do_cleanups ();
6166            pr "      if (r == -1)\n";
6167            pr "        croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
6168        | RInt n
6169        | RBool n ->
6170            pr "PREINIT:\n";
6171            pr "      int %s;\n" n;
6172            pr "   CODE:\n";
6173            pr "      %s = guestfs_%s " n name;
6174            generate_call_args ~handle:"g" (snd style);
6175            pr ";\n";
6176            do_cleanups ();
6177            pr "      if (%s == -1)\n" n;
6178            pr "        croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
6179            pr "      RETVAL = newSViv (%s);\n" n;
6180            pr " OUTPUT:\n";
6181            pr "      RETVAL\n"
6182        | RInt64 n ->
6183            pr "PREINIT:\n";
6184            pr "      int64_t %s;\n" n;
6185            pr "   CODE:\n";
6186            pr "      %s = guestfs_%s " n name;
6187            generate_call_args ~handle:"g" (snd style);
6188            pr ";\n";
6189            do_cleanups ();
6190            pr "      if (%s == -1)\n" n;
6191            pr "        croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
6192            pr "      RETVAL = my_newSVll (%s);\n" n;
6193            pr " OUTPUT:\n";
6194            pr "      RETVAL\n"
6195        | RConstString n ->
6196            pr "PREINIT:\n";
6197            pr "      const char *%s;\n" n;
6198            pr "   CODE:\n";
6199            pr "      %s = guestfs_%s " n name;
6200            generate_call_args ~handle:"g" (snd style);
6201            pr ";\n";
6202            do_cleanups ();
6203            pr "      if (%s == NULL)\n" n;
6204            pr "        croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
6205            pr "      RETVAL = newSVpv (%s, 0);\n" n;
6206            pr " OUTPUT:\n";
6207            pr "      RETVAL\n"
6208        | RString n ->
6209            pr "PREINIT:\n";
6210            pr "      char *%s;\n" n;
6211            pr "   CODE:\n";
6212            pr "      %s = guestfs_%s " n name;
6213            generate_call_args ~handle:"g" (snd style);
6214            pr ";\n";
6215            do_cleanups ();
6216            pr "      if (%s == NULL)\n" n;
6217            pr "        croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
6218            pr "      RETVAL = newSVpv (%s, 0);\n" n;
6219            pr "      free (%s);\n" n;
6220            pr " OUTPUT:\n";
6221            pr "      RETVAL\n"
6222        | RStringList n | RHashtable n ->
6223            pr "PREINIT:\n";
6224            pr "      char **%s;\n" n;
6225            pr "      int i, n;\n";
6226            pr " PPCODE:\n";
6227            pr "      %s = guestfs_%s " n name;
6228            generate_call_args ~handle:"g" (snd style);
6229            pr ";\n";
6230            do_cleanups ();
6231            pr "      if (%s == NULL)\n" n;
6232            pr "        croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
6233            pr "      for (n = 0; %s[n] != NULL; ++n) /**/;\n" n;
6234            pr "      EXTEND (SP, n);\n";
6235            pr "      for (i = 0; i < n; ++i) {\n";
6236            pr "        PUSHs (sv_2mortal (newSVpv (%s[i], 0)));\n" n;
6237            pr "        free (%s[i]);\n" n;
6238            pr "      }\n";
6239            pr "      free (%s);\n" n;
6240        | RStruct (n, typ) ->
6241            let cols = cols_of_struct typ in
6242            generate_perl_struct_code typ cols name style n do_cleanups
6243        | RStructList (n, typ) ->
6244            let cols = cols_of_struct typ in
6245            generate_perl_struct_list_code typ cols name style n do_cleanups
6246       );
6247
6248       pr "\n"
6249   ) all_functions
6250
6251 and generate_perl_struct_list_code typ cols name style n do_cleanups =
6252   pr "PREINIT:\n";
6253   pr "      struct guestfs_%s_list *%s;\n" typ n;
6254   pr "      int i;\n";
6255   pr "      HV *hv;\n";
6256   pr " PPCODE:\n";
6257   pr "      %s = guestfs_%s " n name;
6258   generate_call_args ~handle:"g" (snd style);
6259   pr ";\n";
6260   do_cleanups ();
6261   pr "      if (%s == NULL)\n" n;
6262   pr "        croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
6263   pr "      EXTEND (SP, %s->len);\n" n;
6264   pr "      for (i = 0; i < %s->len; ++i) {\n" n;
6265   pr "        hv = newHV ();\n";
6266   List.iter (
6267     function
6268     | name, FString ->
6269         pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (%s->val[i].%s, 0), 0);\n"
6270           name (String.length name) n name
6271     | name, FUUID ->
6272         pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (%s->val[i].%s, 32), 0);\n"
6273           name (String.length name) n name
6274     | name, FBuffer ->
6275         pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (%s->val[i].%s, %s->val[i].%s_len), 0);\n"
6276           name (String.length name) n name n name
6277     | name, (FBytes|FUInt64) ->
6278         pr "        (void) hv_store (hv, \"%s\", %d, my_newSVull (%s->val[i].%s), 0);\n"
6279           name (String.length name) n name
6280     | name, FInt64 ->
6281         pr "        (void) hv_store (hv, \"%s\", %d, my_newSVll (%s->val[i].%s), 0);\n"
6282           name (String.length name) n name
6283     | name, (FInt32|FUInt32) ->
6284         pr "        (void) hv_store (hv, \"%s\", %d, newSVnv (%s->val[i].%s), 0);\n"
6285           name (String.length name) n name
6286     | name, FChar ->
6287         pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (&%s->val[i].%s, 1), 0);\n"
6288           name (String.length name) n name
6289     | name, FOptPercent ->
6290         pr "        (void) hv_store (hv, \"%s\", %d, newSVnv (%s->val[i].%s), 0);\n"
6291           name (String.length name) n name
6292   ) cols;
6293   pr "        PUSHs (sv_2mortal (newRV ((SV *) hv)));\n";
6294   pr "      }\n";
6295   pr "      guestfs_free_%s_list (%s);\n" typ n
6296
6297 and generate_perl_struct_code typ cols name style n do_cleanups =
6298   pr "PREINIT:\n";
6299   pr "      struct guestfs_%s *%s;\n" typ n;
6300   pr " PPCODE:\n";
6301   pr "      %s = guestfs_%s " n name;
6302   generate_call_args ~handle:"g" (snd style);
6303   pr ";\n";
6304   do_cleanups ();
6305   pr "      if (%s == NULL)\n" n;
6306   pr "        croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
6307   pr "      EXTEND (SP, 2 * %d);\n" (List.length cols);
6308   List.iter (
6309     fun ((name, _) as col) ->
6310       pr "      PUSHs (sv_2mortal (newSVpv (\"%s\", 0)));\n" name;
6311
6312       match col with
6313       | name, FString ->
6314           pr "      PUSHs (sv_2mortal (newSVpv (%s->%s, 0)));\n"
6315             n name
6316       | name, FBuffer ->
6317           pr "      PUSHs (sv_2mortal (newSVpv (%s->%s, %s->%s_len)));\n"
6318             n name n name
6319       | name, FUUID ->
6320           pr "      PUSHs (sv_2mortal (newSVpv (%s->%s, 32)));\n"
6321             n name
6322       | name, (FBytes|FUInt64) ->
6323           pr "      PUSHs (sv_2mortal (my_newSVull (%s->%s)));\n"
6324             n name
6325       | name, FInt64 ->
6326           pr "      PUSHs (sv_2mortal (my_newSVll (%s->%s)));\n"
6327             n name
6328       | name, (FInt32|FUInt32) ->
6329           pr "      PUSHs (sv_2mortal (newSVnv (%s->%s)));\n"
6330             n name
6331       | name, FChar ->
6332           pr "      PUSHs (sv_2mortal (newSVpv (&%s->%s, 1)));\n"
6333             n name
6334       | name, FOptPercent ->
6335           pr "      PUSHs (sv_2mortal (newSVnv (%s->%s)));\n"
6336             n name
6337   ) cols;
6338   pr "      free (%s);\n" n
6339
6340 (* Generate Sys/Guestfs.pm. *)
6341 and generate_perl_pm () =
6342   generate_header HashStyle LGPLv2;
6343
6344   pr "\
6345 =pod
6346
6347 =head1 NAME
6348
6349 Sys::Guestfs - Perl bindings for libguestfs
6350
6351 =head1 SYNOPSIS
6352
6353  use Sys::Guestfs;
6354
6355  my $h = Sys::Guestfs->new ();
6356  $h->add_drive ('guest.img');
6357  $h->launch ();
6358  $h->wait_ready ();
6359  $h->mount ('/dev/sda1', '/');
6360  $h->touch ('/hello');
6361  $h->sync ();
6362
6363 =head1 DESCRIPTION
6364
6365 The C<Sys::Guestfs> module provides a Perl XS binding to the
6366 libguestfs API for examining and modifying virtual machine
6367 disk images.
6368
6369 Amongst the things this is good for: making batch configuration
6370 changes to guests, getting disk used/free statistics (see also:
6371 virt-df), migrating between virtualization systems (see also:
6372 virt-p2v), performing partial backups, performing partial guest
6373 clones, cloning guests and changing registry/UUID/hostname info, and
6374 much else besides.
6375
6376 Libguestfs uses Linux kernel and qemu code, and can access any type of
6377 guest filesystem that Linux and qemu can, including but not limited
6378 to: ext2/3/4, btrfs, FAT and NTFS, LVM, many different disk partition
6379 schemes, qcow, qcow2, vmdk.
6380
6381 Libguestfs provides ways to enumerate guest storage (eg. partitions,
6382 LVs, what filesystem is in each LV, etc.).  It can also run commands
6383 in the context of the guest.  Also you can access filesystems over FTP.
6384
6385 See also L<Sys::Guestfs::Lib(3)> for a set of useful library
6386 functions for using libguestfs from Perl, including integration
6387 with libvirt.
6388
6389 =head1 ERRORS
6390
6391 All errors turn into calls to C<croak> (see L<Carp(3)>).
6392
6393 =head1 METHODS
6394
6395 =over 4
6396
6397 =cut
6398
6399 package Sys::Guestfs;
6400
6401 use strict;
6402 use warnings;
6403
6404 require XSLoader;
6405 XSLoader::load ('Sys::Guestfs');
6406
6407 =item $h = Sys::Guestfs->new ();
6408
6409 Create a new guestfs handle.
6410
6411 =cut
6412
6413 sub new {
6414   my $proto = shift;
6415   my $class = ref ($proto) || $proto;
6416
6417   my $self = Sys::Guestfs::_create ();
6418   bless $self, $class;
6419   return $self;
6420 }
6421
6422 ";
6423
6424   (* Actions.  We only need to print documentation for these as
6425    * they are pulled in from the XS code automatically.
6426    *)
6427   List.iter (
6428     fun (name, style, _, flags, _, _, longdesc) ->
6429       if not (List.mem NotInDocs flags) then (
6430         let longdesc = replace_str longdesc "C<guestfs_" "C<$h-E<gt>" in
6431         pr "=item ";
6432         generate_perl_prototype name style;
6433         pr "\n\n";
6434         pr "%s\n\n" longdesc;
6435         if List.mem ProtocolLimitWarning flags then
6436           pr "%s\n\n" protocol_limit_warning;
6437         if List.mem DangerWillRobinson flags then
6438           pr "%s\n\n" danger_will_robinson
6439       )
6440   ) all_functions_sorted;
6441
6442   (* End of file. *)
6443   pr "\
6444 =cut
6445
6446 1;
6447
6448 =back
6449
6450 =head1 COPYRIGHT
6451
6452 Copyright (C) 2009 Red Hat Inc.
6453
6454 =head1 LICENSE
6455
6456 Please see the file COPYING.LIB for the full license.
6457
6458 =head1 SEE ALSO
6459
6460 L<guestfs(3)>,
6461 L<guestfish(1)>,
6462 L<http://libguestfs.org>,
6463 L<Sys::Guestfs::Lib(3)>.
6464
6465 =cut
6466 "
6467
6468 and generate_perl_prototype name style =
6469   (match fst style with
6470    | RErr -> ()
6471    | RBool n
6472    | RInt n
6473    | RInt64 n
6474    | RConstString n
6475    | RString n -> pr "$%s = " n
6476    | RStruct (n,_)
6477    | RHashtable n -> pr "%%%s = " n
6478    | RStringList n
6479    | RStructList (n,_) -> pr "@%s = " n
6480   );
6481   pr "$h->%s (" name;
6482   let comma = ref false in
6483   List.iter (
6484     fun arg ->
6485       if !comma then pr ", ";
6486       comma := true;
6487       match arg with
6488       | String n | OptString n | Bool n | Int n | FileIn n | FileOut n ->
6489           pr "$%s" n
6490       | StringList n ->
6491           pr "\\@%s" n
6492   ) (snd style);
6493   pr ");"
6494
6495 (* Generate Python C module. *)
6496 and generate_python_c () =
6497   generate_header CStyle LGPLv2;
6498
6499   pr "\
6500 #include <stdio.h>
6501 #include <stdlib.h>
6502 #include <assert.h>
6503
6504 #include <Python.h>
6505
6506 #include \"guestfs.h\"
6507
6508 typedef struct {
6509   PyObject_HEAD
6510   guestfs_h *g;
6511 } Pyguestfs_Object;
6512
6513 static guestfs_h *
6514 get_handle (PyObject *obj)
6515 {
6516   assert (obj);
6517   assert (obj != Py_None);
6518   return ((Pyguestfs_Object *) obj)->g;
6519 }
6520
6521 static PyObject *
6522 put_handle (guestfs_h *g)
6523 {
6524   assert (g);
6525   return
6526     PyCObject_FromVoidPtrAndDesc ((void *) g, (char *) \"guestfs_h\", NULL);
6527 }
6528
6529 /* This list should be freed (but not the strings) after use. */
6530 static const char **
6531 get_string_list (PyObject *obj)
6532 {
6533   int i, len;
6534   const char **r;
6535
6536   assert (obj);
6537
6538   if (!PyList_Check (obj)) {
6539     PyErr_SetString (PyExc_RuntimeError, \"expecting a list parameter\");
6540     return NULL;
6541   }
6542
6543   len = PyList_Size (obj);
6544   r = malloc (sizeof (char *) * (len+1));
6545   if (r == NULL) {
6546     PyErr_SetString (PyExc_RuntimeError, \"get_string_list: out of memory\");
6547     return NULL;
6548   }
6549
6550   for (i = 0; i < len; ++i)
6551     r[i] = PyString_AsString (PyList_GetItem (obj, i));
6552   r[len] = NULL;
6553
6554   return r;
6555 }
6556
6557 static PyObject *
6558 put_string_list (char * const * const argv)
6559 {
6560   PyObject *list;
6561   int argc, i;
6562
6563   for (argc = 0; argv[argc] != NULL; ++argc)
6564     ;
6565
6566   list = PyList_New (argc);
6567   for (i = 0; i < argc; ++i)
6568     PyList_SetItem (list, i, PyString_FromString (argv[i]));
6569
6570   return list;
6571 }
6572
6573 static PyObject *
6574 put_table (char * const * const argv)
6575 {
6576   PyObject *list, *item;
6577   int argc, i;
6578
6579   for (argc = 0; argv[argc] != NULL; ++argc)
6580     ;
6581
6582   list = PyList_New (argc >> 1);
6583   for (i = 0; i < argc; i += 2) {
6584     item = PyTuple_New (2);
6585     PyTuple_SetItem (item, 0, PyString_FromString (argv[i]));
6586     PyTuple_SetItem (item, 1, PyString_FromString (argv[i+1]));
6587     PyList_SetItem (list, i >> 1, item);
6588   }
6589
6590   return list;
6591 }
6592
6593 static void
6594 free_strings (char **argv)
6595 {
6596   int argc;
6597
6598   for (argc = 0; argv[argc] != NULL; ++argc)
6599     free (argv[argc]);
6600   free (argv);
6601 }
6602
6603 static PyObject *
6604 py_guestfs_create (PyObject *self, PyObject *args)
6605 {
6606   guestfs_h *g;
6607
6608   g = guestfs_create ();
6609   if (g == NULL) {
6610     PyErr_SetString (PyExc_RuntimeError,
6611                      \"guestfs.create: failed to allocate handle\");
6612     return NULL;
6613   }
6614   guestfs_set_error_handler (g, NULL, NULL);
6615   return put_handle (g);
6616 }
6617
6618 static PyObject *
6619 py_guestfs_close (PyObject *self, PyObject *args)
6620 {
6621   PyObject *py_g;
6622   guestfs_h *g;
6623
6624   if (!PyArg_ParseTuple (args, (char *) \"O:guestfs_close\", &py_g))
6625     return NULL;
6626   g = get_handle (py_g);
6627
6628   guestfs_close (g);
6629
6630   Py_INCREF (Py_None);
6631   return Py_None;
6632 }
6633
6634 ";
6635
6636   (* Structures, turned into Python dictionaries. *)
6637   List.iter (
6638     fun (typ, cols) ->
6639       pr "static PyObject *\n";
6640       pr "put_%s (struct guestfs_%s *%s)\n" typ typ typ;
6641       pr "{\n";
6642       pr "  PyObject *dict;\n";
6643       pr "\n";
6644       pr "  dict = PyDict_New ();\n";
6645       List.iter (
6646         function
6647         | name, FString ->
6648             pr "  PyDict_SetItemString (dict, \"%s\",\n" name;
6649             pr "                        PyString_FromString (%s->%s));\n"
6650               typ name
6651         | name, FBuffer ->
6652             pr "  PyDict_SetItemString (dict, \"%s\",\n" name;
6653             pr "                        PyString_FromStringAndSize (%s->%s, %s->%s_len));\n"
6654               typ name typ name
6655         | name, FUUID ->
6656             pr "  PyDict_SetItemString (dict, \"%s\",\n" name;
6657             pr "                        PyString_FromStringAndSize (%s->%s, 32));\n"
6658               typ name
6659         | name, (FBytes|FUInt64) ->
6660             pr "  PyDict_SetItemString (dict, \"%s\",\n" name;
6661             pr "                        PyLong_FromUnsignedLongLong (%s->%s));\n"
6662               typ name
6663         | name, FInt64 ->
6664             pr "  PyDict_SetItemString (dict, \"%s\",\n" name;
6665             pr "                        PyLong_FromLongLong (%s->%s));\n"
6666               typ name
6667         | name, FUInt32 ->
6668             pr "  PyDict_SetItemString (dict, \"%s\",\n" name;
6669             pr "                        PyLong_FromUnsignedLong (%s->%s));\n"
6670               typ name
6671         | name, FInt32 ->
6672             pr "  PyDict_SetItemString (dict, \"%s\",\n" name;
6673             pr "                        PyLong_FromLong (%s->%s));\n"
6674               typ name
6675         | name, FOptPercent ->
6676             pr "  if (%s->%s >= 0)\n" typ name;
6677             pr "    PyDict_SetItemString (dict, \"%s\",\n" name;
6678             pr "                          PyFloat_FromDouble ((double) %s->%s));\n"
6679               typ name;
6680             pr "  else {\n";
6681             pr "    Py_INCREF (Py_None);\n";
6682             pr "    PyDict_SetItemString (dict, \"%s\", Py_None);" name;
6683             pr "  }\n"
6684         | name, FChar ->
6685             pr "  PyDict_SetItemString (dict, \"%s\",\n" name;
6686             pr "                        PyString_FromStringAndSize (&dirent->%s, 1));\n" name
6687       ) cols;
6688       pr "  return dict;\n";
6689       pr "};\n";
6690       pr "\n";
6691
6692       pr "static PyObject *\n";
6693       pr "put_%s_list (struct guestfs_%s_list *%ss)\n" typ typ typ;
6694       pr "{\n";
6695       pr "  PyObject *list;\n";
6696       pr "  int i;\n";
6697       pr "\n";
6698       pr "  list = PyList_New (%ss->len);\n" typ;
6699       pr "  for (i = 0; i < %ss->len; ++i)\n" typ;
6700       pr "    PyList_SetItem (list, i, put_%s (&%ss->val[i]));\n" typ typ;
6701       pr "  return list;\n";
6702       pr "};\n";
6703       pr "\n"
6704   ) structs;
6705
6706   (* Python wrapper functions. *)
6707   List.iter (
6708     fun (name, style, _, _, _, _, _) ->
6709       pr "static PyObject *\n";
6710       pr "py_guestfs_%s (PyObject *self, PyObject *args)\n" name;
6711       pr "{\n";
6712
6713       pr "  PyObject *py_g;\n";
6714       pr "  guestfs_h *g;\n";
6715       pr "  PyObject *py_r;\n";
6716
6717       let error_code =
6718         match fst style with
6719         | RErr | RInt _ | RBool _ -> pr "  int r;\n"; "-1"
6720         | RInt64 _ -> pr "  int64_t r;\n"; "-1"
6721         | RConstString _ -> pr "  const char *r;\n"; "NULL"
6722         | RString _ -> pr "  char *r;\n"; "NULL"
6723         | RStringList _ | RHashtable _ -> pr "  char **r;\n"; "NULL"
6724         | RStruct (_, typ) -> pr "  struct guestfs_%s *r;\n" typ; "NULL"
6725         | RStructList (_, typ) ->
6726             pr "  struct guestfs_%s_list *r;\n" typ; "NULL" in
6727
6728       List.iter (
6729         function
6730         | String n | FileIn n | FileOut n -> pr "  const char *%s;\n" n
6731         | OptString n -> pr "  const char *%s;\n" n
6732         | StringList n ->
6733             pr "  PyObject *py_%s;\n" n;
6734             pr "  const char **%s;\n" n
6735         | Bool n -> pr "  int %s;\n" n
6736         | Int n -> pr "  int %s;\n" n
6737       ) (snd style);
6738
6739       pr "\n";
6740
6741       (* Convert the parameters. *)
6742       pr "  if (!PyArg_ParseTuple (args, (char *) \"O";
6743       List.iter (
6744         function
6745         | String _ | FileIn _ | FileOut _ -> pr "s"
6746         | OptString _ -> pr "z"
6747         | StringList _ -> pr "O"
6748         | Bool _ -> pr "i" (* XXX Python has booleans? *)
6749         | Int _ -> pr "i"
6750       ) (snd style);
6751       pr ":guestfs_%s\",\n" name;
6752       pr "                         &py_g";
6753       List.iter (
6754         function
6755         | String n | FileIn n | FileOut n -> pr ", &%s" n
6756         | OptString n -> pr ", &%s" n
6757         | StringList n -> pr ", &py_%s" n
6758         | Bool n -> pr ", &%s" n
6759         | Int n -> pr ", &%s" n
6760       ) (snd style);
6761
6762       pr "))\n";
6763       pr "    return NULL;\n";
6764
6765       pr "  g = get_handle (py_g);\n";
6766       List.iter (
6767         function
6768         | String _ | FileIn _ | FileOut _ | OptString _ | Bool _ | Int _ -> ()
6769         | StringList n ->
6770             pr "  %s = get_string_list (py_%s);\n" n n;
6771             pr "  if (!%s) return NULL;\n" n
6772       ) (snd style);
6773
6774       pr "\n";
6775
6776       pr "  r = guestfs_%s " name;
6777       generate_call_args ~handle:"g" (snd style);
6778       pr ";\n";
6779
6780       List.iter (
6781         function
6782         | String _ | FileIn _ | FileOut _ | OptString _ | Bool _ | Int _ -> ()
6783         | StringList n ->
6784             pr "  free (%s);\n" n
6785       ) (snd style);
6786
6787       pr "  if (r == %s) {\n" error_code;
6788       pr "    PyErr_SetString (PyExc_RuntimeError, guestfs_last_error (g));\n";
6789       pr "    return NULL;\n";
6790       pr "  }\n";
6791       pr "\n";
6792
6793       (match fst style with
6794        | RErr ->
6795            pr "  Py_INCREF (Py_None);\n";
6796            pr "  py_r = Py_None;\n"
6797        | RInt _
6798        | RBool _ -> pr "  py_r = PyInt_FromLong ((long) r);\n"
6799        | RInt64 _ -> pr "  py_r = PyLong_FromLongLong (r);\n"
6800        | RConstString _ -> pr "  py_r = PyString_FromString (r);\n"
6801        | RString _ ->
6802            pr "  py_r = PyString_FromString (r);\n";
6803            pr "  free (r);\n"
6804        | RStringList _ ->
6805            pr "  py_r = put_string_list (r);\n";
6806            pr "  free_strings (r);\n"
6807        | RStruct (_, typ) ->
6808            pr "  py_r = put_%s (r);\n" typ;
6809            pr "  guestfs_free_%s (r);\n" typ
6810        | RStructList (_, typ) ->
6811            pr "  py_r = put_%s_list (r);\n" typ;
6812            pr "  guestfs_free_%s_list (r);\n" typ
6813        | RHashtable n ->
6814            pr "  py_r = put_table (r);\n";
6815            pr "  free_strings (r);\n"
6816       );
6817
6818       pr "  return py_r;\n";
6819       pr "}\n";
6820       pr "\n"
6821   ) all_functions;
6822
6823   (* Table of functions. *)
6824   pr "static PyMethodDef methods[] = {\n";
6825   pr "  { (char *) \"create\", py_guestfs_create, METH_VARARGS, NULL },\n";
6826   pr "  { (char *) \"close\", py_guestfs_close, METH_VARARGS, NULL },\n";
6827   List.iter (
6828     fun (name, _, _, _, _, _, _) ->
6829       pr "  { (char *) \"%s\", py_guestfs_%s, METH_VARARGS, NULL },\n"
6830         name name
6831   ) all_functions;
6832   pr "  { NULL, NULL, 0, NULL }\n";
6833   pr "};\n";
6834   pr "\n";
6835
6836   (* Init function. *)
6837   pr "\
6838 void
6839 initlibguestfsmod (void)
6840 {
6841   static int initialized = 0;
6842
6843   if (initialized) return;
6844   Py_InitModule ((char *) \"libguestfsmod\", methods);
6845   initialized = 1;
6846 }
6847 "
6848
6849 (* Generate Python module. *)
6850 and generate_python_py () =
6851   generate_header HashStyle LGPLv2;
6852
6853   pr "\
6854 u\"\"\"Python bindings for libguestfs
6855
6856 import guestfs
6857 g = guestfs.GuestFS ()
6858 g.add_drive (\"guest.img\")
6859 g.launch ()
6860 g.wait_ready ()
6861 parts = g.list_partitions ()
6862
6863 The guestfs module provides a Python binding to the libguestfs API
6864 for examining and modifying virtual machine disk images.
6865
6866 Amongst the things this is good for: making batch configuration
6867 changes to guests, getting disk used/free statistics (see also:
6868 virt-df), migrating between virtualization systems (see also:
6869 virt-p2v), performing partial backups, performing partial guest
6870 clones, cloning guests and changing registry/UUID/hostname info, and
6871 much else besides.
6872
6873 Libguestfs uses Linux kernel and qemu code, and can access any type of
6874 guest filesystem that Linux and qemu can, including but not limited
6875 to: ext2/3/4, btrfs, FAT and NTFS, LVM, many different disk partition
6876 schemes, qcow, qcow2, vmdk.
6877
6878 Libguestfs provides ways to enumerate guest storage (eg. partitions,
6879 LVs, what filesystem is in each LV, etc.).  It can also run commands
6880 in the context of the guest.  Also you can access filesystems over FTP.
6881
6882 Errors which happen while using the API are turned into Python
6883 RuntimeError exceptions.
6884
6885 To create a guestfs handle you usually have to perform the following
6886 sequence of calls:
6887
6888 # Create the handle, call add_drive at least once, and possibly
6889 # several times if the guest has multiple block devices:
6890 g = guestfs.GuestFS ()
6891 g.add_drive (\"guest.img\")
6892
6893 # Launch the qemu subprocess and wait for it to become ready:
6894 g.launch ()
6895 g.wait_ready ()
6896
6897 # Now you can issue commands, for example:
6898 logvols = g.lvs ()
6899
6900 \"\"\"
6901
6902 import libguestfsmod
6903
6904 class GuestFS:
6905     \"\"\"Instances of this class are libguestfs API handles.\"\"\"
6906
6907     def __init__ (self):
6908         \"\"\"Create a new libguestfs handle.\"\"\"
6909         self._o = libguestfsmod.create ()
6910
6911     def __del__ (self):
6912         libguestfsmod.close (self._o)
6913
6914 ";
6915
6916   List.iter (
6917     fun (name, style, _, flags, _, _, longdesc) ->
6918       pr "    def %s " name;
6919       generate_call_args ~handle:"self" (snd style);
6920       pr ":\n";
6921
6922       if not (List.mem NotInDocs flags) then (
6923         let doc = replace_str longdesc "C<guestfs_" "C<g." in
6924         let doc =
6925           match fst style with
6926           | RErr | RInt _ | RInt64 _ | RBool _ | RConstString _
6927           | RString _ -> doc
6928           | RStringList _ ->
6929               doc ^ "\n\nThis function returns a list of strings."
6930           | RStruct (_, typ) ->
6931               doc ^ sprintf "\n\nThis function returns a dictionary, with keys matching the various fields in the guestfs_%s structure." typ
6932           | RStructList (_, typ) ->
6933               doc ^ sprintf "\n\nThis function returns a list of %ss.  Each %s is represented as a dictionary." typ typ
6934           | RHashtable _ ->
6935               doc ^ "\n\nThis function returns a dictionary." in
6936         let doc =
6937           if List.mem ProtocolLimitWarning flags then
6938             doc ^ "\n\n" ^ protocol_limit_warning
6939           else doc in
6940         let doc =
6941           if List.mem DangerWillRobinson flags then
6942             doc ^ "\n\n" ^ danger_will_robinson
6943           else doc in
6944         let doc = pod2text ~width:60 name doc in
6945         let doc = List.map (fun line -> replace_str line "\\" "\\\\") doc in
6946         let doc = String.concat "\n        " doc in
6947         pr "        u\"\"\"%s\"\"\"\n" doc;
6948       );
6949       pr "        return libguestfsmod.%s " name;
6950       generate_call_args ~handle:"self._o" (snd style);
6951       pr "\n";
6952       pr "\n";
6953   ) all_functions
6954
6955 (* Useful if you need the longdesc POD text as plain text.  Returns a
6956  * list of lines.
6957  *
6958  * Because this is very slow (the slowest part of autogeneration),
6959  * we memoize the results.
6960  *)
6961 and pod2text ~width name longdesc =
6962   let key = width, name, longdesc in
6963   try Hashtbl.find pod2text_memo key
6964   with Not_found ->
6965     let filename, chan = Filename.open_temp_file "gen" ".tmp" in
6966     fprintf chan "=head1 %s\n\n%s\n" name longdesc;
6967     close_out chan;
6968     let cmd = sprintf "pod2text -w %d %s" width (Filename.quote filename) in
6969     let chan = Unix.open_process_in cmd in
6970     let lines = ref [] in
6971     let rec loop i =
6972       let line = input_line chan in
6973       if i = 1 then             (* discard the first line of output *)
6974         loop (i+1)
6975       else (
6976         let line = triml line in
6977         lines := line :: !lines;
6978         loop (i+1)
6979       ) in
6980     let lines = try loop 1 with End_of_file -> List.rev !lines in
6981     Unix.unlink filename;
6982     (match Unix.close_process_in chan with
6983      | Unix.WEXITED 0 -> ()
6984      | Unix.WEXITED i ->
6985          failwithf "pod2text: process exited with non-zero status (%d)" i
6986      | Unix.WSIGNALED i | Unix.WSTOPPED i ->
6987          failwithf "pod2text: process signalled or stopped by signal %d" i
6988     );
6989     Hashtbl.add pod2text_memo key lines;
6990     let chan = open_out pod2text_memo_filename in
6991     output_value chan pod2text_memo;
6992     close_out chan;
6993     lines
6994
6995 (* Generate ruby bindings. *)
6996 and generate_ruby_c () =
6997   generate_header CStyle LGPLv2;
6998
6999   pr "\
7000 #include <stdio.h>
7001 #include <stdlib.h>
7002
7003 #include <ruby.h>
7004
7005 #include \"guestfs.h\"
7006
7007 #include \"extconf.h\"
7008
7009 /* For Ruby < 1.9 */
7010 #ifndef RARRAY_LEN
7011 #define RARRAY_LEN(r) (RARRAY((r))->len)
7012 #endif
7013
7014 static VALUE m_guestfs;                 /* guestfs module */
7015 static VALUE c_guestfs;                 /* guestfs_h handle */
7016 static VALUE e_Error;                   /* used for all errors */
7017
7018 static void ruby_guestfs_free (void *p)
7019 {
7020   if (!p) return;
7021   guestfs_close ((guestfs_h *) p);
7022 }
7023
7024 static VALUE ruby_guestfs_create (VALUE m)
7025 {
7026   guestfs_h *g;
7027
7028   g = guestfs_create ();
7029   if (!g)
7030     rb_raise (e_Error, \"failed to create guestfs handle\");
7031
7032   /* Don't print error messages to stderr by default. */
7033   guestfs_set_error_handler (g, NULL, NULL);
7034
7035   /* Wrap it, and make sure the close function is called when the
7036    * handle goes away.
7037    */
7038   return Data_Wrap_Struct (c_guestfs, NULL, ruby_guestfs_free, g);
7039 }
7040
7041 static VALUE ruby_guestfs_close (VALUE gv)
7042 {
7043   guestfs_h *g;
7044   Data_Get_Struct (gv, guestfs_h, g);
7045
7046   ruby_guestfs_free (g);
7047   DATA_PTR (gv) = NULL;
7048
7049   return Qnil;
7050 }
7051
7052 ";
7053
7054   List.iter (
7055     fun (name, style, _, _, _, _, _) ->
7056       pr "static VALUE ruby_guestfs_%s (VALUE gv" name;
7057       List.iter (fun arg -> pr ", VALUE %sv" (name_of_argt arg)) (snd style);
7058       pr ")\n";
7059       pr "{\n";
7060       pr "  guestfs_h *g;\n";
7061       pr "  Data_Get_Struct (gv, guestfs_h, g);\n";
7062       pr "  if (!g)\n";
7063       pr "    rb_raise (rb_eArgError, \"%%s: used handle after closing it\", \"%s\");\n"
7064         name;
7065       pr "\n";
7066
7067       List.iter (
7068         function
7069         | String n | FileIn n | FileOut n ->
7070             pr "  Check_Type (%sv, T_STRING);\n" n;
7071             pr "  const char *%s = StringValueCStr (%sv);\n" n n;
7072             pr "  if (!%s)\n" n;
7073             pr "    rb_raise (rb_eTypeError, \"expected string for parameter %%s of %%s\",\n";
7074             pr "              \"%s\", \"%s\");\n" n name
7075         | OptString n ->
7076             pr "  const char *%s = !NIL_P (%sv) ? StringValueCStr (%sv) : NULL;\n" n n n
7077         | StringList n ->
7078             pr "  char **%s;\n" n;
7079             pr "  Check_Type (%sv, T_ARRAY);\n" n;
7080             pr "  {\n";
7081             pr "    int i, len;\n";
7082             pr "    len = RARRAY_LEN (%sv);\n" n;
7083             pr "    %s = guestfs_safe_malloc (g, sizeof (char *) * (len+1));\n"
7084               n;
7085             pr "    for (i = 0; i < len; ++i) {\n";
7086             pr "      VALUE v = rb_ary_entry (%sv, i);\n" n;
7087             pr "      %s[i] = StringValueCStr (v);\n" n;
7088             pr "    }\n";
7089             pr "    %s[len] = NULL;\n" n;
7090             pr "  }\n";
7091         | Bool n ->
7092             pr "  int %s = RTEST (%sv);\n" n n
7093         | Int n ->
7094             pr "  int %s = NUM2INT (%sv);\n" n n
7095       ) (snd style);
7096       pr "\n";
7097
7098       let error_code =
7099         match fst style with
7100         | RErr | RInt _ | RBool _ -> pr "  int r;\n"; "-1"
7101         | RInt64 _ -> pr "  int64_t r;\n"; "-1"
7102         | RConstString _ -> pr "  const char *r;\n"; "NULL"
7103         | RString _ -> pr "  char *r;\n"; "NULL"
7104         | RStringList _ | RHashtable _ -> pr "  char **r;\n"; "NULL"
7105         | RStruct (_, typ) -> pr "  struct guestfs_%s *r;\n" typ; "NULL"
7106         | RStructList (_, typ) ->
7107             pr "  struct guestfs_%s_list *r;\n" typ; "NULL" in
7108       pr "\n";
7109
7110       pr "  r = guestfs_%s " name;
7111       generate_call_args ~handle:"g" (snd style);
7112       pr ";\n";
7113
7114       List.iter (
7115         function
7116         | String _ | FileIn _ | FileOut _ | OptString _ | Bool _ | Int _ -> ()
7117         | StringList n ->
7118             pr "  free (%s);\n" n
7119       ) (snd style);
7120
7121       pr "  if (r == %s)\n" error_code;
7122       pr "    rb_raise (e_Error, \"%%s\", guestfs_last_error (g));\n";
7123       pr "\n";
7124
7125       (match fst style with
7126        | RErr ->
7127            pr "  return Qnil;\n"
7128        | RInt _ | RBool _ ->
7129            pr "  return INT2NUM (r);\n"
7130        | RInt64 _ ->
7131            pr "  return ULL2NUM (r);\n"
7132        | RConstString _ ->
7133            pr "  return rb_str_new2 (r);\n";
7134        | RString _ ->
7135            pr "  VALUE rv = rb_str_new2 (r);\n";
7136            pr "  free (r);\n";
7137            pr "  return rv;\n";
7138        | RStringList _ ->
7139            pr "  int i, len = 0;\n";
7140            pr "  for (i = 0; r[i] != NULL; ++i) len++;\n";
7141            pr "  VALUE rv = rb_ary_new2 (len);\n";
7142            pr "  for (i = 0; r[i] != NULL; ++i) {\n";
7143            pr "    rb_ary_push (rv, rb_str_new2 (r[i]));\n";
7144            pr "    free (r[i]);\n";
7145            pr "  }\n";
7146            pr "  free (r);\n";
7147            pr "  return rv;\n"
7148        | RStruct (_, typ) ->
7149            let cols = cols_of_struct typ in
7150            generate_ruby_struct_code typ cols
7151        | RStructList (_, typ) ->
7152            let cols = cols_of_struct typ in
7153            generate_ruby_struct_list_code typ cols
7154        | RHashtable _ ->
7155            pr "  VALUE rv = rb_hash_new ();\n";
7156            pr "  int i;\n";
7157            pr "  for (i = 0; r[i] != NULL; i+=2) {\n";
7158            pr "    rb_hash_aset (rv, rb_str_new2 (r[i]), rb_str_new2 (r[i+1]));\n";
7159            pr "    free (r[i]);\n";
7160            pr "    free (r[i+1]);\n";
7161            pr "  }\n";
7162            pr "  free (r);\n";
7163            pr "  return rv;\n"
7164       );
7165
7166       pr "}\n";
7167       pr "\n"
7168   ) all_functions;
7169
7170   pr "\
7171 /* Initialize the module. */
7172 void Init__guestfs ()
7173 {
7174   m_guestfs = rb_define_module (\"Guestfs\");
7175   c_guestfs = rb_define_class_under (m_guestfs, \"Guestfs\", rb_cObject);
7176   e_Error = rb_define_class_under (m_guestfs, \"Error\", rb_eStandardError);
7177
7178   rb_define_module_function (m_guestfs, \"create\", ruby_guestfs_create, 0);
7179   rb_define_method (c_guestfs, \"close\", ruby_guestfs_close, 0);
7180
7181 ";
7182   (* Define the rest of the methods. *)
7183   List.iter (
7184     fun (name, style, _, _, _, _, _) ->
7185       pr "  rb_define_method (c_guestfs, \"%s\",\n" name;
7186       pr "        ruby_guestfs_%s, %d);\n" name (List.length (snd style))
7187   ) all_functions;
7188
7189   pr "}\n"
7190
7191 (* Ruby code to return a struct. *)
7192 and generate_ruby_struct_code typ cols =
7193   pr "  VALUE rv = rb_hash_new ();\n";
7194   List.iter (
7195     function
7196     | name, FString ->
7197         pr "  rb_hash_aset (rv, rb_str_new2 (\"%s\"), rb_str_new2 (r->%s));\n" name name
7198     | name, FBuffer ->
7199         pr "  rb_hash_aset (rv, rb_str_new2 (\"%s\"), rb_str_new (r->%s, r->%s_len));\n" name name name
7200     | name, FUUID ->
7201         pr "  rb_hash_aset (rv, rb_str_new2 (\"%s\"), rb_str_new (r->%s, 32));\n" name name
7202     | name, (FBytes|FUInt64) ->
7203         pr "  rb_hash_aset (rv, rb_str_new2 (\"%s\"), ULL2NUM (r->%s));\n" name name
7204     | name, FInt64 ->
7205         pr "  rb_hash_aset (rv, rb_str_new2 (\"%s\"), LL2NUM (r->%s));\n" name name
7206     | name, FUInt32 ->
7207         pr "  rb_hash_aset (rv, rb_str_new2 (\"%s\"), UINT2NUM (r->%s));\n" name name
7208     | name, FInt32 ->
7209         pr "  rb_hash_aset (rv, rb_str_new2 (\"%s\"), INT2NUM (r->%s));\n" name name
7210     | name, FOptPercent ->
7211         pr "  rb_hash_aset (rv, rb_str_new2 (\"%s\"), rb_dbl2big (r->%s));\n" name name
7212     | name, FChar -> (* XXX wrong? *)
7213         pr "  rb_hash_aset (rv, rb_str_new2 (\"%s\"), ULL2NUM (r->%s));\n" name name
7214   ) cols;
7215   pr "  guestfs_free_%s (r);\n" typ;
7216   pr "  return rv;\n"
7217
7218 (* Ruby code to return a struct list. *)
7219 and generate_ruby_struct_list_code typ cols =
7220   pr "  VALUE rv = rb_ary_new2 (r->len);\n";
7221   pr "  int i;\n";
7222   pr "  for (i = 0; i < r->len; ++i) {\n";
7223   pr "    VALUE hv = rb_hash_new ();\n";
7224   List.iter (
7225     function
7226     | name, FString ->
7227         pr "    rb_hash_aset (hv, rb_str_new2 (\"%s\"), rb_str_new2 (r->val[i].%s));\n" name name
7228     | name, FBuffer ->
7229         pr "    rb_hash_aset (hv, rb_str_new2 (\"%s\"), rb_str_new (r->val[i].%s, r->val[i].%s_len));\n" name name name
7230     | name, FUUID ->
7231         pr "    rb_hash_aset (hv, rb_str_new2 (\"%s\"), rb_str_new (r->val[i].%s, 32));\n" name name
7232     | name, (FBytes|FUInt64) ->
7233         pr "    rb_hash_aset (hv, rb_str_new2 (\"%s\"), ULL2NUM (r->val[i].%s));\n" name name
7234     | name, FInt64 ->
7235         pr "    rb_hash_aset (hv, rb_str_new2 (\"%s\"), LL2NUM (r->val[i].%s));\n" name name
7236     | name, FUInt32 ->
7237         pr "    rb_hash_aset (hv, rb_str_new2 (\"%s\"), UINT2NUM (r->val[i].%s));\n" name name
7238     | name, FInt32 ->
7239         pr "    rb_hash_aset (hv, rb_str_new2 (\"%s\"), INT2NUM (r->val[i].%s));\n" name name
7240     | name, FOptPercent ->
7241         pr "    rb_hash_aset (hv, rb_str_new2 (\"%s\"), rb_dbl2big (r->val[i].%s));\n" name name
7242     | name, FChar -> (* XXX wrong? *)
7243         pr "    rb_hash_aset (hv, rb_str_new2 (\"%s\"), ULL2NUM (r->val[i].%s));\n" name name
7244   ) cols;
7245   pr "    rb_ary_push (rv, hv);\n";
7246   pr "  }\n";
7247   pr "  guestfs_free_%s_list (r);\n" typ;
7248   pr "  return rv;\n"
7249
7250 (* Generate Java bindings GuestFS.java file. *)
7251 and generate_java_java () =
7252   generate_header CStyle LGPLv2;
7253
7254   pr "\
7255 package com.redhat.et.libguestfs;
7256
7257 import java.util.HashMap;
7258 import com.redhat.et.libguestfs.LibGuestFSException;
7259 import com.redhat.et.libguestfs.PV;
7260 import com.redhat.et.libguestfs.VG;
7261 import com.redhat.et.libguestfs.LV;
7262 import com.redhat.et.libguestfs.Stat;
7263 import com.redhat.et.libguestfs.StatVFS;
7264 import com.redhat.et.libguestfs.IntBool;
7265 import com.redhat.et.libguestfs.Dirent;
7266
7267 /**
7268  * The GuestFS object is a libguestfs handle.
7269  *
7270  * @author rjones
7271  */
7272 public class GuestFS {
7273   // Load the native code.
7274   static {
7275     System.loadLibrary (\"guestfs_jni\");
7276   }
7277
7278   /**
7279    * The native guestfs_h pointer.
7280    */
7281   long g;
7282
7283   /**
7284    * Create a libguestfs handle.
7285    *
7286    * @throws LibGuestFSException
7287    */
7288   public GuestFS () throws LibGuestFSException
7289   {
7290     g = _create ();
7291   }
7292   private native long _create () throws LibGuestFSException;
7293
7294   /**
7295    * Close a libguestfs handle.
7296    *
7297    * You can also leave handles to be collected by the garbage
7298    * collector, but this method ensures that the resources used
7299    * by the handle are freed up immediately.  If you call any
7300    * other methods after closing the handle, you will get an
7301    * exception.
7302    *
7303    * @throws LibGuestFSException
7304    */
7305   public void close () throws LibGuestFSException
7306   {
7307     if (g != 0)
7308       _close (g);
7309     g = 0;
7310   }
7311   private native void _close (long g) throws LibGuestFSException;
7312
7313   public void finalize () throws LibGuestFSException
7314   {
7315     close ();
7316   }
7317
7318 ";
7319
7320   List.iter (
7321     fun (name, style, _, flags, _, shortdesc, longdesc) ->
7322       if not (List.mem NotInDocs flags); then (
7323         let doc = replace_str longdesc "C<guestfs_" "C<g." in
7324         let doc =
7325           if List.mem ProtocolLimitWarning flags then
7326             doc ^ "\n\n" ^ protocol_limit_warning
7327           else doc in
7328         let doc =
7329           if List.mem DangerWillRobinson flags then
7330             doc ^ "\n\n" ^ danger_will_robinson
7331           else doc in
7332         let doc = pod2text ~width:60 name doc in
7333         let doc = List.map (            (* RHBZ#501883 *)
7334           function
7335           | "" -> "<p>"
7336           | nonempty -> nonempty
7337         ) doc in
7338         let doc = String.concat "\n   * " doc in
7339
7340         pr "  /**\n";
7341         pr "   * %s\n" shortdesc;
7342         pr "   * <p>\n";
7343         pr "   * %s\n" doc;
7344         pr "   * @throws LibGuestFSException\n";
7345         pr "   */\n";
7346         pr "  ";
7347       );
7348       generate_java_prototype ~public:true ~semicolon:false name style;
7349       pr "\n";
7350       pr "  {\n";
7351       pr "    if (g == 0)\n";
7352       pr "      throw new LibGuestFSException (\"%s: handle is closed\");\n"
7353         name;
7354       pr "    ";
7355       if fst style <> RErr then pr "return ";
7356       pr "_%s " name;
7357       generate_call_args ~handle:"g" (snd style);
7358       pr ";\n";
7359       pr "  }\n";
7360       pr "  ";
7361       generate_java_prototype ~privat:true ~native:true name style;
7362       pr "\n";
7363       pr "\n";
7364   ) all_functions;
7365
7366   pr "}\n"
7367
7368 and generate_java_prototype ?(public=false) ?(privat=false) ?(native=false)
7369     ?(semicolon=true) name style =
7370   if privat then pr "private ";
7371   if public then pr "public ";
7372   if native then pr "native ";
7373
7374   (* return type *)
7375   (match fst style with
7376    | RErr -> pr "void ";
7377    | RInt _ -> pr "int ";
7378    | RInt64 _ -> pr "long ";
7379    | RBool _ -> pr "boolean ";
7380    | RConstString _ | RString _ -> pr "String ";
7381    | RStringList _ -> pr "String[] ";
7382    | RStruct (_, typ) ->
7383        let name = java_name_of_struct typ in
7384        pr "%s " name;
7385    | RStructList (_, typ) ->
7386        let name = java_name_of_struct typ in
7387        pr "%s[] " name;
7388    | RHashtable _ -> pr "HashMap<String,String> ";
7389   );
7390
7391   if native then pr "_%s " name else pr "%s " name;
7392   pr "(";
7393   let needs_comma = ref false in
7394   if native then (
7395     pr "long g";
7396     needs_comma := true
7397   );
7398
7399   (* args *)
7400   List.iter (
7401     fun arg ->
7402       if !needs_comma then pr ", ";
7403       needs_comma := true;
7404
7405       match arg with
7406       | String n
7407       | OptString n
7408       | FileIn n
7409       | FileOut n ->
7410           pr "String %s" n
7411       | StringList n ->
7412           pr "String[] %s" n
7413       | Bool n ->
7414           pr "boolean %s" n
7415       | Int n ->
7416           pr "int %s" n
7417   ) (snd style);
7418
7419   pr ")\n";
7420   pr "    throws LibGuestFSException";
7421   if semicolon then pr ";"
7422
7423 and generate_java_struct jtyp cols =
7424   generate_header CStyle LGPLv2;
7425
7426   pr "\
7427 package com.redhat.et.libguestfs;
7428
7429 /**
7430  * Libguestfs %s structure.
7431  *
7432  * @author rjones
7433  * @see GuestFS
7434  */
7435 public class %s {
7436 " jtyp jtyp;
7437
7438   List.iter (
7439     function
7440     | name, FString
7441     | name, FUUID
7442     | name, FBuffer -> pr "  public String %s;\n" name
7443     | name, (FBytes|FUInt64|FInt64) -> pr "  public long %s;\n" name
7444     | name, (FUInt32|FInt32) -> pr "  public int %s;\n" name
7445     | name, FChar -> pr "  public char %s;\n" name
7446     | name, FOptPercent ->
7447         pr "  /* The next field is [0..100] or -1 meaning 'not present': */\n";
7448         pr "  public float %s;\n" name
7449   ) cols;
7450
7451   pr "}\n"
7452
7453 and generate_java_c () =
7454   generate_header CStyle LGPLv2;
7455
7456   pr "\
7457 #include <stdio.h>
7458 #include <stdlib.h>
7459 #include <string.h>
7460
7461 #include \"com_redhat_et_libguestfs_GuestFS.h\"
7462 #include \"guestfs.h\"
7463
7464 /* Note that this function returns.  The exception is not thrown
7465  * until after the wrapper function returns.
7466  */
7467 static void
7468 throw_exception (JNIEnv *env, const char *msg)
7469 {
7470   jclass cl;
7471   cl = (*env)->FindClass (env,
7472                           \"com/redhat/et/libguestfs/LibGuestFSException\");
7473   (*env)->ThrowNew (env, cl, msg);
7474 }
7475
7476 JNIEXPORT jlong JNICALL
7477 Java_com_redhat_et_libguestfs_GuestFS__1create
7478   (JNIEnv *env, jobject obj)
7479 {
7480   guestfs_h *g;
7481
7482   g = guestfs_create ();
7483   if (g == NULL) {
7484     throw_exception (env, \"GuestFS.create: failed to allocate handle\");
7485     return 0;
7486   }
7487   guestfs_set_error_handler (g, NULL, NULL);
7488   return (jlong) (long) g;
7489 }
7490
7491 JNIEXPORT void JNICALL
7492 Java_com_redhat_et_libguestfs_GuestFS__1close
7493   (JNIEnv *env, jobject obj, jlong jg)
7494 {
7495   guestfs_h *g = (guestfs_h *) (long) jg;
7496   guestfs_close (g);
7497 }
7498
7499 ";
7500
7501   List.iter (
7502     fun (name, style, _, _, _, _, _) ->
7503       pr "JNIEXPORT ";
7504       (match fst style with
7505        | RErr -> pr "void ";
7506        | RInt _ -> pr "jint ";
7507        | RInt64 _ -> pr "jlong ";
7508        | RBool _ -> pr "jboolean ";
7509        | RConstString _ | RString _ -> pr "jstring ";
7510        | RStruct _ | RHashtable _ ->
7511            pr "jobject ";
7512        | RStringList _ | RStructList _ ->
7513            pr "jobjectArray ";
7514       );
7515       pr "JNICALL\n";
7516       pr "Java_com_redhat_et_libguestfs_GuestFS_";
7517       pr "%s" (replace_str ("_" ^ name) "_" "_1");
7518       pr "\n";
7519       pr "  (JNIEnv *env, jobject obj, jlong jg";
7520       List.iter (
7521         function
7522         | String n
7523         | OptString n
7524         | FileIn n
7525         | FileOut n ->
7526             pr ", jstring j%s" n
7527         | StringList n ->
7528             pr ", jobjectArray j%s" n
7529         | Bool n ->
7530             pr ", jboolean j%s" n
7531         | Int n ->
7532             pr ", jint j%s" n
7533       ) (snd style);
7534       pr ")\n";
7535       pr "{\n";
7536       pr "  guestfs_h *g = (guestfs_h *) (long) jg;\n";
7537       let error_code, no_ret =
7538         match fst style with
7539         | RErr -> pr "  int r;\n"; "-1", ""
7540         | RBool _
7541         | RInt _ -> pr "  int r;\n"; "-1", "0"
7542         | RInt64 _ -> pr "  int64_t r;\n"; "-1", "0"
7543         | RConstString _ -> pr "  const char *r;\n"; "NULL", "NULL"
7544         | RString _ ->
7545             pr "  jstring jr;\n";
7546             pr "  char *r;\n"; "NULL", "NULL"
7547         | RStringList _ ->
7548             pr "  jobjectArray jr;\n";
7549             pr "  int r_len;\n";
7550             pr "  jclass cl;\n";
7551             pr "  jstring jstr;\n";
7552             pr "  char **r;\n"; "NULL", "NULL"
7553         | RStruct (_, typ) ->
7554             pr "  jobject jr;\n";
7555             pr "  jclass cl;\n";
7556             pr "  jfieldID fl;\n";
7557             pr "  struct guestfs_%s *r;\n" typ; "NULL", "NULL"
7558         | RStructList (_, typ) ->
7559             pr "  jobjectArray jr;\n";
7560             pr "  jclass cl;\n";
7561             pr "  jfieldID fl;\n";
7562             pr "  jobject jfl;\n";
7563             pr "  struct guestfs_%s_list *r;\n" typ; "NULL", "NULL"
7564         | RHashtable _ -> pr "  char **r;\n"; "NULL", "NULL" in
7565       List.iter (
7566         function
7567         | String n
7568         | OptString n
7569         | FileIn n
7570         | FileOut n ->
7571             pr "  const char *%s;\n" n
7572         | StringList n ->
7573             pr "  int %s_len;\n" n;
7574             pr "  const char **%s;\n" n
7575         | Bool n
7576         | Int n ->
7577             pr "  int %s;\n" n
7578       ) (snd style);
7579
7580       let needs_i =
7581         (match fst style with
7582          | RStringList _ | RStructList _ -> true
7583          | RErr | RBool _ | RInt _ | RInt64 _ | RConstString _
7584          | RString _ | RStruct _ | RHashtable _ -> false) ||
7585           List.exists (function StringList _ -> true | _ -> false) (snd style) in
7586       if needs_i then
7587         pr "  int i;\n";
7588
7589       pr "\n";
7590
7591       (* Get the parameters. *)
7592       List.iter (
7593         function
7594         | String n
7595         | FileIn n
7596         | FileOut n ->
7597             pr "  %s = (*env)->GetStringUTFChars (env, j%s, NULL);\n" n n
7598         | OptString n ->
7599             (* This is completely undocumented, but Java null becomes
7600              * a NULL parameter.
7601              *)
7602             pr "  %s = j%s ? (*env)->GetStringUTFChars (env, j%s, NULL) : NULL;\n" n n n
7603         | StringList n ->
7604             pr "  %s_len = (*env)->GetArrayLength (env, j%s);\n" n n;
7605             pr "  %s = guestfs_safe_malloc (g, sizeof (char *) * (%s_len+1));\n" n n;
7606             pr "  for (i = 0; i < %s_len; ++i) {\n" n;
7607             pr "    jobject o = (*env)->GetObjectArrayElement (env, j%s, i);\n"
7608               n;
7609             pr "    %s[i] = (*env)->GetStringUTFChars (env, o, NULL);\n" n;
7610             pr "  }\n";
7611             pr "  %s[%s_len] = NULL;\n" n n;
7612         | Bool n
7613         | Int n ->
7614             pr "  %s = j%s;\n" n n
7615       ) (snd style);
7616
7617       (* Make the call. *)
7618       pr "  r = guestfs_%s " name;
7619       generate_call_args ~handle:"g" (snd style);
7620       pr ";\n";
7621
7622       (* Release the parameters. *)
7623       List.iter (
7624         function
7625         | String n
7626         | FileIn n
7627         | FileOut n ->
7628             pr "  (*env)->ReleaseStringUTFChars (env, j%s, %s);\n" n n
7629         | OptString n ->
7630             pr "  if (j%s)\n" n;
7631             pr "    (*env)->ReleaseStringUTFChars (env, j%s, %s);\n" n n
7632         | StringList n ->
7633             pr "  for (i = 0; i < %s_len; ++i) {\n" n;
7634             pr "    jobject o = (*env)->GetObjectArrayElement (env, j%s, i);\n"
7635               n;
7636             pr "    (*env)->ReleaseStringUTFChars (env, o, %s[i]);\n" n;
7637             pr "  }\n";
7638             pr "  free (%s);\n" n
7639         | Bool n
7640         | Int n -> ()
7641       ) (snd style);
7642
7643       (* Check for errors. *)
7644       pr "  if (r == %s) {\n" error_code;
7645       pr "    throw_exception (env, guestfs_last_error (g));\n";
7646       pr "    return %s;\n" no_ret;
7647       pr "  }\n";
7648
7649       (* Return value. *)
7650       (match fst style with
7651        | RErr -> ()
7652        | RInt _ -> pr "  return (jint) r;\n"
7653        | RBool _ -> pr "  return (jboolean) r;\n"
7654        | RInt64 _ -> pr "  return (jlong) r;\n"
7655        | RConstString _ -> pr "  return (*env)->NewStringUTF (env, r);\n"
7656        | RString _ ->
7657            pr "  jr = (*env)->NewStringUTF (env, r);\n";
7658            pr "  free (r);\n";
7659            pr "  return jr;\n"
7660        | RStringList _ ->
7661            pr "  for (r_len = 0; r[r_len] != NULL; ++r_len) ;\n";
7662            pr "  cl = (*env)->FindClass (env, \"java/lang/String\");\n";
7663            pr "  jstr = (*env)->NewStringUTF (env, \"\");\n";
7664            pr "  jr = (*env)->NewObjectArray (env, r_len, cl, jstr);\n";
7665            pr "  for (i = 0; i < r_len; ++i) {\n";
7666            pr "    jstr = (*env)->NewStringUTF (env, r[i]);\n";
7667            pr "    (*env)->SetObjectArrayElement (env, jr, i, jstr);\n";
7668            pr "    free (r[i]);\n";
7669            pr "  }\n";
7670            pr "  free (r);\n";
7671            pr "  return jr;\n"
7672        | RStruct (_, typ) ->
7673            let jtyp = java_name_of_struct typ in
7674            let cols = cols_of_struct typ in
7675            generate_java_struct_return typ jtyp cols
7676        | RStructList (_, typ) ->
7677            let jtyp = java_name_of_struct typ in
7678            let cols = cols_of_struct typ in
7679            generate_java_struct_list_return typ jtyp cols
7680        | RHashtable _ ->
7681            (* XXX *)
7682            pr "  throw_exception (env, \"%s: internal error: please let us know how to make a Java HashMap from JNI bindings!\");\n" name;
7683            pr "  return NULL;\n"
7684       );
7685
7686       pr "}\n";
7687       pr "\n"
7688   ) all_functions
7689
7690 and generate_java_struct_return typ jtyp cols =
7691   pr "  cl = (*env)->FindClass (env, \"com/redhat/et/libguestfs/%s\");\n" jtyp;
7692   pr "  jr = (*env)->AllocObject (env, cl);\n";
7693   List.iter (
7694     function
7695     | name, FString ->
7696         pr "  fl = (*env)->GetFieldID (env, cl, \"%s\", \"Ljava/lang/String;\");\n" name;
7697         pr "  (*env)->SetObjectField (env, jr, fl, (*env)->NewStringUTF (env, r->%s));\n" name;
7698     | name, FUUID ->
7699         pr "  {\n";
7700         pr "    char s[33];\n";
7701         pr "    memcpy (s, r->%s, 32);\n" name;
7702         pr "    s[32] = 0;\n";
7703         pr "    fl = (*env)->GetFieldID (env, cl, \"%s\", \"Ljava/lang/String;\");\n" name;
7704         pr "    (*env)->SetObjectField (env, jr, fl, (*env)->NewStringUTF (env, s));\n";
7705         pr "  }\n";
7706     | name, FBuffer ->
7707         pr "  {\n";
7708         pr "    int len = r->%s_len;\n" name;
7709         pr "    char s[len+1];\n";
7710         pr "    memcpy (s, r->%s, len);\n" name;
7711         pr "    s[len] = 0;\n";
7712         pr "    fl = (*env)->GetFieldID (env, cl, \"%s\", \"Ljava/lang/String;\");\n" name;
7713         pr "    (*env)->SetObjectField (env, jr, fl, (*env)->NewStringUTF (env, s));\n";
7714         pr "  }\n";
7715     | name, (FBytes|FUInt64|FInt64) ->
7716         pr "  fl = (*env)->GetFieldID (env, cl, \"%s\", \"J\");\n" name;
7717         pr "  (*env)->SetLongField (env, jr, fl, r->%s);\n" name;
7718     | name, (FUInt32|FInt32) ->
7719         pr "  fl = (*env)->GetFieldID (env, cl, \"%s\", \"I\");\n" name;
7720         pr "  (*env)->SetLongField (env, jr, fl, r->%s);\n" name;
7721     | name, FOptPercent ->
7722         pr "  fl = (*env)->GetFieldID (env, cl, \"%s\", \"F\");\n" name;
7723         pr "  (*env)->SetFloatField (env, jr, fl, r->%s);\n" name;
7724     | name, FChar ->
7725         pr "  fl = (*env)->GetFieldID (env, cl, \"%s\", \"C\");\n" name;
7726         pr "  (*env)->SetLongField (env, jr, fl, r->%s);\n" name;
7727   ) cols;
7728   pr "  free (r);\n";
7729   pr "  return jr;\n"
7730
7731 and generate_java_struct_list_return typ jtyp cols =
7732   pr "  cl = (*env)->FindClass (env, \"com/redhat/et/libguestfs/%s\");\n" jtyp;
7733   pr "  jr = (*env)->NewObjectArray (env, r->len, cl, NULL);\n";
7734   pr "  for (i = 0; i < r->len; ++i) {\n";
7735   pr "    jfl = (*env)->AllocObject (env, cl);\n";
7736   List.iter (
7737     function
7738     | name, FString ->
7739         pr "    fl = (*env)->GetFieldID (env, cl, \"%s\", \"Ljava/lang/String;\");\n" name;
7740         pr "    (*env)->SetObjectField (env, jfl, fl, (*env)->NewStringUTF (env, r->val[i].%s));\n" name;
7741     | name, FUUID ->
7742         pr "    {\n";
7743         pr "      char s[33];\n";
7744         pr "      memcpy (s, r->val[i].%s, 32);\n" name;
7745         pr "      s[32] = 0;\n";
7746         pr "      fl = (*env)->GetFieldID (env, cl, \"%s\", \"Ljava/lang/String;\");\n" name;
7747         pr "      (*env)->SetObjectField (env, jfl, fl, (*env)->NewStringUTF (env, s));\n";
7748         pr "    }\n";
7749     | name, FBuffer ->
7750         pr "    {\n";
7751         pr "      int len = r->val[i].%s_len;\n" name;
7752         pr "      char s[len+1];\n";
7753         pr "      memcpy (s, r->val[i].%s, len);\n" name;
7754         pr "      s[len] = 0;\n";
7755         pr "      fl = (*env)->GetFieldID (env, cl, \"%s\", \"Ljava/lang/String;\");\n" name;
7756         pr "      (*env)->SetObjectField (env, jfl, fl, (*env)->NewStringUTF (env, s));\n";
7757         pr "    }\n";
7758     | name, (FBytes|FUInt64|FInt64) ->
7759         pr "    fl = (*env)->GetFieldID (env, cl, \"%s\", \"J\");\n" name;
7760         pr "    (*env)->SetLongField (env, jfl, fl, r->val[i].%s);\n" name;
7761     | name, (FUInt32|FInt32) ->
7762         pr "    fl = (*env)->GetFieldID (env, cl, \"%s\", \"I\");\n" name;
7763         pr "    (*env)->SetLongField (env, jfl, fl, r->val[i].%s);\n" name;
7764     | name, FOptPercent ->
7765         pr "    fl = (*env)->GetFieldID (env, cl, \"%s\", \"F\");\n" name;
7766         pr "    (*env)->SetFloatField (env, jfl, fl, r->val[i].%s);\n" name;
7767     | name, FChar ->
7768         pr "    fl = (*env)->GetFieldID (env, cl, \"%s\", \"C\");\n" name;
7769         pr "    (*env)->SetLongField (env, jfl, fl, r->val[i].%s);\n" name;
7770   ) cols;
7771   pr "    (*env)->SetObjectArrayElement (env, jfl, i, jfl);\n";
7772   pr "  }\n";
7773   pr "  guestfs_free_%s_list (r);\n" typ;
7774   pr "  return jr;\n"
7775
7776 and generate_haskell_hs () =
7777   generate_header HaskellStyle LGPLv2;
7778
7779   (* XXX We only know how to generate partial FFI for Haskell
7780    * at the moment.  Please help out!
7781    *)
7782   let can_generate style =
7783     match style with
7784     | RErr, _
7785     | RInt _, _
7786     | RInt64 _, _ -> true
7787     | RBool _, _
7788     | RConstString _, _
7789     | RString _, _
7790     | RStringList _, _
7791     | RStruct _, _
7792     | RStructList _, _
7793     | RHashtable _, _ -> false in
7794
7795   pr "\
7796 {-# INCLUDE <guestfs.h> #-}
7797 {-# LANGUAGE ForeignFunctionInterface #-}
7798
7799 module Guestfs (
7800   create";
7801
7802   (* List out the names of the actions we want to export. *)
7803   List.iter (
7804     fun (name, style, _, _, _, _, _) ->
7805       if can_generate style then pr ",\n  %s" name
7806   ) all_functions;
7807
7808   pr "
7809   ) where
7810 import Foreign
7811 import Foreign.C
7812 import Foreign.C.Types
7813 import IO
7814 import Control.Exception
7815 import Data.Typeable
7816
7817 data GuestfsS = GuestfsS            -- represents the opaque C struct
7818 type GuestfsP = Ptr GuestfsS        -- guestfs_h *
7819 type GuestfsH = ForeignPtr GuestfsS -- guestfs_h * with attached finalizer
7820
7821 -- XXX define properly later XXX
7822 data PV = PV
7823 data VG = VG
7824 data LV = LV
7825 data IntBool = IntBool
7826 data Stat = Stat
7827 data StatVFS = StatVFS
7828 data Hashtable = Hashtable
7829
7830 foreign import ccall unsafe \"guestfs_create\" c_create
7831   :: IO GuestfsP
7832 foreign import ccall unsafe \"&guestfs_close\" c_close
7833   :: FunPtr (GuestfsP -> IO ())
7834 foreign import ccall unsafe \"guestfs_set_error_handler\" c_set_error_handler
7835   :: GuestfsP -> Ptr CInt -> Ptr CInt -> IO ()
7836
7837 create :: IO GuestfsH
7838 create = do
7839   p <- c_create
7840   c_set_error_handler p nullPtr nullPtr
7841   h <- newForeignPtr c_close p
7842   return h
7843
7844 foreign import ccall unsafe \"guestfs_last_error\" c_last_error
7845   :: GuestfsP -> IO CString
7846
7847 -- last_error :: GuestfsH -> IO (Maybe String)
7848 -- last_error h = do
7849 --   str <- withForeignPtr h (\\p -> c_last_error p)
7850 --   maybePeek peekCString str
7851
7852 last_error :: GuestfsH -> IO (String)
7853 last_error h = do
7854   str <- withForeignPtr h (\\p -> c_last_error p)
7855   if (str == nullPtr)
7856     then return \"no error\"
7857     else peekCString str
7858
7859 ";
7860
7861   (* Generate wrappers for each foreign function. *)
7862   List.iter (
7863     fun (name, style, _, _, _, _, _) ->
7864       if can_generate style then (
7865         pr "foreign import ccall unsafe \"guestfs_%s\" c_%s\n" name name;
7866         pr "  :: ";
7867         generate_haskell_prototype ~handle:"GuestfsP" style;
7868         pr "\n";
7869         pr "\n";
7870         pr "%s :: " name;
7871         generate_haskell_prototype ~handle:"GuestfsH" ~hs:true style;
7872         pr "\n";
7873         pr "%s %s = do\n" name
7874           (String.concat " " ("h" :: List.map name_of_argt (snd style)));
7875         pr "  r <- ";
7876         (* Convert pointer arguments using with* functions. *)
7877         List.iter (
7878           function
7879           | FileIn n
7880           | FileOut n
7881           | String n -> pr "withCString %s $ \\%s -> " n n
7882           | OptString n -> pr "maybeWith withCString %s $ \\%s -> " n n
7883           | StringList n -> pr "withMany withCString %s $ \\%s -> withArray0 nullPtr %s $ \\%s -> " n n n n
7884           | Bool _ | Int _ -> ()
7885         ) (snd style);
7886         (* Convert integer arguments. *)
7887         let args =
7888           List.map (
7889             function
7890             | Bool n -> sprintf "(fromBool %s)" n
7891             | Int n -> sprintf "(fromIntegral %s)" n
7892             | FileIn n | FileOut n | String n | OptString n | StringList n -> n
7893           ) (snd style) in
7894         pr "withForeignPtr h (\\p -> c_%s %s)\n" name
7895           (String.concat " " ("p" :: args));
7896         (match fst style with
7897          | RErr | RInt _ | RInt64 _ | RBool _ ->
7898              pr "  if (r == -1)\n";
7899              pr "    then do\n";
7900              pr "      err <- last_error h\n";
7901              pr "      fail err\n";
7902          | RConstString _ | RString _ | RStringList _ | RStruct _
7903          | RStructList _ | RHashtable _ ->
7904              pr "  if (r == nullPtr)\n";
7905              pr "    then do\n";
7906              pr "      err <- last_error h\n";
7907              pr "      fail err\n";
7908         );
7909         (match fst style with
7910          | RErr ->
7911              pr "    else return ()\n"
7912          | RInt _ ->
7913              pr "    else return (fromIntegral r)\n"
7914          | RInt64 _ ->
7915              pr "    else return (fromIntegral r)\n"
7916          | RBool _ ->
7917              pr "    else return (toBool r)\n"
7918          | RConstString _
7919          | RString _
7920          | RStringList _
7921          | RStruct _
7922          | RStructList _
7923          | RHashtable _ ->
7924              pr "    else return ()\n" (* XXXXXXXXXXXXXXXXXXXX *)
7925         );
7926         pr "\n";
7927       )
7928   ) all_functions
7929
7930 and generate_haskell_prototype ~handle ?(hs = false) style =
7931   pr "%s -> " handle;
7932   let string = if hs then "String" else "CString" in
7933   let int = if hs then "Int" else "CInt" in
7934   let bool = if hs then "Bool" else "CInt" in
7935   let int64 = if hs then "Integer" else "Int64" in
7936   List.iter (
7937     fun arg ->
7938       (match arg with
7939        | String _ -> pr "%s" string
7940        | OptString _ -> if hs then pr "Maybe String" else pr "CString"
7941        | StringList _ -> if hs then pr "[String]" else pr "Ptr CString"
7942        | Bool _ -> pr "%s" bool
7943        | Int _ -> pr "%s" int
7944        | FileIn _ -> pr "%s" string
7945        | FileOut _ -> pr "%s" string
7946       );
7947       pr " -> ";
7948   ) (snd style);
7949   pr "IO (";
7950   (match fst style with
7951    | RErr -> if not hs then pr "CInt"
7952    | RInt _ -> pr "%s" int
7953    | RInt64 _ -> pr "%s" int64
7954    | RBool _ -> pr "%s" bool
7955    | RConstString _ -> pr "%s" string
7956    | RString _ -> pr "%s" string
7957    | RStringList _ -> pr "[%s]" string
7958    | RStruct (_, typ) ->
7959        let name = java_name_of_struct typ in
7960        pr "%s" name
7961    | RStructList (_, typ) ->
7962        let name = java_name_of_struct typ in
7963        pr "[%s]" name
7964    | RHashtable _ -> pr "Hashtable"
7965   );
7966   pr ")"
7967
7968 and generate_bindtests () =
7969   generate_header CStyle LGPLv2;
7970
7971   pr "\
7972 #include <stdio.h>
7973 #include <stdlib.h>
7974 #include <inttypes.h>
7975 #include <string.h>
7976
7977 #include \"guestfs.h\"
7978 #include \"guestfs_protocol.h\"
7979
7980 #define error guestfs_error
7981 #define safe_calloc guestfs_safe_calloc
7982 #define safe_malloc guestfs_safe_malloc
7983
7984 static void
7985 print_strings (char * const* const argv)
7986 {
7987   int argc;
7988
7989   printf (\"[\");
7990   for (argc = 0; argv[argc] != NULL; ++argc) {
7991     if (argc > 0) printf (\", \");
7992     printf (\"\\\"%%s\\\"\", argv[argc]);
7993   }
7994   printf (\"]\\n\");
7995 }
7996
7997 /* The test0 function prints its parameters to stdout. */
7998 ";
7999
8000   let test0, tests =
8001     match test_functions with
8002     | [] -> assert false
8003     | test0 :: tests -> test0, tests in
8004
8005   let () =
8006     let (name, style, _, _, _, _, _) = test0 in
8007     generate_prototype ~extern:false ~semicolon:false ~newline:true
8008       ~handle:"g" ~prefix:"guestfs_" name style;
8009     pr "{\n";
8010     List.iter (
8011       function
8012       | String n
8013       | FileIn n
8014       | FileOut n -> pr "  printf (\"%%s\\n\", %s);\n" n
8015       | OptString n -> pr "  printf (\"%%s\\n\", %s ? %s : \"null\");\n" n n
8016       | StringList n -> pr "  print_strings (%s);\n" n
8017       | Bool n -> pr "  printf (\"%%s\\n\", %s ? \"true\" : \"false\");\n" n
8018       | Int n -> pr "  printf (\"%%d\\n\", %s);\n" n
8019     ) (snd style);
8020     pr "  /* Java changes stdout line buffering so we need this: */\n";
8021     pr "  fflush (stdout);\n";
8022     pr "  return 0;\n";
8023     pr "}\n";
8024     pr "\n" in
8025
8026   List.iter (
8027     fun (name, style, _, _, _, _, _) ->
8028       if String.sub name (String.length name - 3) 3 <> "err" then (
8029         pr "/* Test normal return. */\n";
8030         generate_prototype ~extern:false ~semicolon:false ~newline:true
8031           ~handle:"g" ~prefix:"guestfs_" name style;
8032         pr "{\n";
8033         (match fst style with
8034          | RErr ->
8035              pr "  return 0;\n"
8036          | RInt _ ->
8037              pr "  int r;\n";
8038              pr "  sscanf (val, \"%%d\", &r);\n";
8039              pr "  return r;\n"
8040          | RInt64 _ ->
8041              pr "  int64_t r;\n";
8042              pr "  sscanf (val, \"%%\" SCNi64, &r);\n";
8043              pr "  return r;\n"
8044          | RBool _ ->
8045              pr "  return strcmp (val, \"true\") == 0;\n"
8046          | RConstString _ ->
8047              (* Can't return the input string here.  Return a static
8048               * string so we ensure we get a segfault if the caller
8049               * tries to free it.
8050               *)
8051              pr "  return \"static string\";\n"
8052          | RString _ ->
8053              pr "  return strdup (val);\n"
8054          | RStringList _ ->
8055              pr "  char **strs;\n";
8056              pr "  int n, i;\n";
8057              pr "  sscanf (val, \"%%d\", &n);\n";
8058              pr "  strs = safe_malloc (g, (n+1) * sizeof (char *));\n";
8059              pr "  for (i = 0; i < n; ++i) {\n";
8060              pr "    strs[i] = safe_malloc (g, 16);\n";
8061              pr "    snprintf (strs[i], 16, \"%%d\", i);\n";
8062              pr "  }\n";
8063              pr "  strs[n] = NULL;\n";
8064              pr "  return strs;\n"
8065          | RStruct (_, typ) ->
8066              pr "  struct guestfs_%s *r;\n" typ;
8067              pr "  r = safe_calloc (g, sizeof *r, 1);\n";
8068              pr "  return r;\n"
8069          | RStructList (_, typ) ->
8070              pr "  struct guestfs_%s_list *r;\n" typ;
8071              pr "  r = safe_calloc (g, sizeof *r, 1);\n";
8072              pr "  sscanf (val, \"%%d\", &r->len);\n";
8073              pr "  r->val = safe_calloc (g, r->len, sizeof *r->val);\n";
8074              pr "  return r;\n"
8075          | RHashtable _ ->
8076              pr "  char **strs;\n";
8077              pr "  int n, i;\n";
8078              pr "  sscanf (val, \"%%d\", &n);\n";
8079              pr "  strs = safe_malloc (g, (n*2+1) * sizeof (*strs));\n";
8080              pr "  for (i = 0; i < n; ++i) {\n";
8081              pr "    strs[i*2] = safe_malloc (g, 16);\n";
8082              pr "    strs[i*2+1] = safe_malloc (g, 16);\n";
8083              pr "    snprintf (strs[i*2], 16, \"%%d\", i);\n";
8084              pr "    snprintf (strs[i*2+1], 16, \"%%d\", i);\n";
8085              pr "  }\n";
8086              pr "  strs[n*2] = NULL;\n";
8087              pr "  return strs;\n"
8088         );
8089         pr "}\n";
8090         pr "\n"
8091       ) else (
8092         pr "/* Test error return. */\n";
8093         generate_prototype ~extern:false ~semicolon:false ~newline:true
8094           ~handle:"g" ~prefix:"guestfs_" name style;
8095         pr "{\n";
8096         pr "  error (g, \"error\");\n";
8097         (match fst style with
8098          | RErr | RInt _ | RInt64 _ | RBool _ ->
8099              pr "  return -1;\n"
8100          | RConstString _
8101          | RString _ | RStringList _ | RStruct _
8102          | RStructList _
8103          | RHashtable _ ->
8104              pr "  return NULL;\n"
8105         );
8106         pr "}\n";
8107         pr "\n"
8108       )
8109   ) tests
8110
8111 and generate_ocaml_bindtests () =
8112   generate_header OCamlStyle GPLv2;
8113
8114   pr "\
8115 let () =
8116   let g = Guestfs.create () in
8117 ";
8118
8119   let mkargs args =
8120     String.concat " " (
8121       List.map (
8122         function
8123         | CallString s -> "\"" ^ s ^ "\""
8124         | CallOptString None -> "None"
8125         | CallOptString (Some s) -> sprintf "(Some \"%s\")" s
8126         | CallStringList xs ->
8127             "[|" ^ String.concat ";" (List.map (sprintf "\"%s\"") xs) ^ "|]"
8128         | CallInt i when i >= 0 -> string_of_int i
8129         | CallInt i (* when i < 0 *) -> "(" ^ string_of_int i ^ ")"
8130         | CallBool b -> string_of_bool b
8131       ) args
8132     )
8133   in
8134
8135   generate_lang_bindtests (
8136     fun f args -> pr "  Guestfs.%s g %s;\n" f (mkargs args)
8137   );
8138
8139   pr "print_endline \"EOF\"\n"
8140
8141 and generate_perl_bindtests () =
8142   pr "#!/usr/bin/perl -w\n";
8143   generate_header HashStyle GPLv2;
8144
8145   pr "\
8146 use strict;
8147
8148 use Sys::Guestfs;
8149
8150 my $g = Sys::Guestfs->new ();
8151 ";
8152
8153   let mkargs args =
8154     String.concat ", " (
8155       List.map (
8156         function
8157         | CallString s -> "\"" ^ s ^ "\""
8158         | CallOptString None -> "undef"
8159         | CallOptString (Some s) -> sprintf "\"%s\"" s
8160         | CallStringList xs ->
8161             "[" ^ String.concat "," (List.map (sprintf "\"%s\"") xs) ^ "]"
8162         | CallInt i -> string_of_int i
8163         | CallBool b -> if b then "1" else "0"
8164       ) args
8165     )
8166   in
8167
8168   generate_lang_bindtests (
8169     fun f args -> pr "$g->%s (%s);\n" f (mkargs args)
8170   );
8171
8172   pr "print \"EOF\\n\"\n"
8173
8174 and generate_python_bindtests () =
8175   generate_header HashStyle GPLv2;
8176
8177   pr "\
8178 import guestfs
8179
8180 g = guestfs.GuestFS ()
8181 ";
8182
8183   let mkargs args =
8184     String.concat ", " (
8185       List.map (
8186         function
8187         | CallString s -> "\"" ^ s ^ "\""
8188         | CallOptString None -> "None"
8189         | CallOptString (Some s) -> sprintf "\"%s\"" s
8190         | CallStringList xs ->
8191             "[" ^ String.concat "," (List.map (sprintf "\"%s\"") xs) ^ "]"
8192         | CallInt i -> string_of_int i
8193         | CallBool b -> if b then "1" else "0"
8194       ) args
8195     )
8196   in
8197
8198   generate_lang_bindtests (
8199     fun f args -> pr "g.%s (%s)\n" f (mkargs args)
8200   );
8201
8202   pr "print \"EOF\"\n"
8203
8204 and generate_ruby_bindtests () =
8205   generate_header HashStyle GPLv2;
8206
8207   pr "\
8208 require 'guestfs'
8209
8210 g = Guestfs::create()
8211 ";
8212
8213   let mkargs args =
8214     String.concat ", " (
8215       List.map (
8216         function
8217         | CallString s -> "\"" ^ s ^ "\""
8218         | CallOptString None -> "nil"
8219         | CallOptString (Some s) -> sprintf "\"%s\"" s
8220         | CallStringList xs ->
8221             "[" ^ String.concat "," (List.map (sprintf "\"%s\"") xs) ^ "]"
8222         | CallInt i -> string_of_int i
8223         | CallBool b -> string_of_bool b
8224       ) args
8225     )
8226   in
8227
8228   generate_lang_bindtests (
8229     fun f args -> pr "g.%s(%s)\n" f (mkargs args)
8230   );
8231
8232   pr "print \"EOF\\n\"\n"
8233
8234 and generate_java_bindtests () =
8235   generate_header CStyle GPLv2;
8236
8237   pr "\
8238 import com.redhat.et.libguestfs.*;
8239
8240 public class Bindtests {
8241     public static void main (String[] argv)
8242     {
8243         try {
8244             GuestFS g = new GuestFS ();
8245 ";
8246
8247   let mkargs args =
8248     String.concat ", " (
8249       List.map (
8250         function
8251         | CallString s -> "\"" ^ s ^ "\""
8252         | CallOptString None -> "null"
8253         | CallOptString (Some s) -> sprintf "\"%s\"" s
8254         | CallStringList xs ->
8255             "new String[]{" ^
8256               String.concat "," (List.map (sprintf "\"%s\"") xs) ^ "}"
8257         | CallInt i -> string_of_int i
8258         | CallBool b -> string_of_bool b
8259       ) args
8260     )
8261   in
8262
8263   generate_lang_bindtests (
8264     fun f args -> pr "            g.%s (%s);\n" f (mkargs args)
8265   );
8266
8267   pr "
8268             System.out.println (\"EOF\");
8269         }
8270         catch (Exception exn) {
8271             System.err.println (exn);
8272             System.exit (1);
8273         }
8274     }
8275 }
8276 "
8277
8278 and generate_haskell_bindtests () =
8279   generate_header HaskellStyle GPLv2;
8280
8281   pr "\
8282 module Bindtests where
8283 import qualified Guestfs
8284
8285 main = do
8286   g <- Guestfs.create
8287 ";
8288
8289   let mkargs args =
8290     String.concat " " (
8291       List.map (
8292         function
8293         | CallString s -> "\"" ^ s ^ "\""
8294         | CallOptString None -> "Nothing"
8295         | CallOptString (Some s) -> sprintf "(Just \"%s\")" s
8296         | CallStringList xs ->
8297             "[" ^ String.concat "," (List.map (sprintf "\"%s\"") xs) ^ "]"
8298         | CallInt i when i < 0 -> "(" ^ string_of_int i ^ ")"
8299         | CallInt i -> string_of_int i
8300         | CallBool true -> "True"
8301         | CallBool false -> "False"
8302       ) args
8303     )
8304   in
8305
8306   generate_lang_bindtests (
8307     fun f args -> pr "  Guestfs.%s g %s\n" f (mkargs args)
8308   );
8309
8310   pr "  putStrLn \"EOF\"\n"
8311
8312 (* Language-independent bindings tests - we do it this way to
8313  * ensure there is parity in testing bindings across all languages.
8314  *)
8315 and generate_lang_bindtests call =
8316   call "test0" [CallString "abc"; CallOptString (Some "def");
8317                 CallStringList []; CallBool false;
8318                 CallInt 0; CallString "123"; CallString "456"];
8319   call "test0" [CallString "abc"; CallOptString None;
8320                 CallStringList []; CallBool false;
8321                 CallInt 0; CallString "123"; CallString "456"];
8322   call "test0" [CallString ""; CallOptString (Some "def");
8323                 CallStringList []; CallBool false;
8324                 CallInt 0; CallString "123"; CallString "456"];
8325   call "test0" [CallString ""; CallOptString (Some "");
8326                 CallStringList []; CallBool false;
8327                 CallInt 0; CallString "123"; CallString "456"];
8328   call "test0" [CallString "abc"; CallOptString (Some "def");
8329                 CallStringList ["1"]; CallBool false;
8330                 CallInt 0; CallString "123"; CallString "456"];
8331   call "test0" [CallString "abc"; CallOptString (Some "def");
8332                 CallStringList ["1"; "2"]; CallBool false;
8333                 CallInt 0; CallString "123"; CallString "456"];
8334   call "test0" [CallString "abc"; CallOptString (Some "def");
8335                 CallStringList ["1"]; CallBool true;
8336                 CallInt 0; CallString "123"; CallString "456"];
8337   call "test0" [CallString "abc"; CallOptString (Some "def");
8338                 CallStringList ["1"]; CallBool false;
8339                 CallInt (-1); CallString "123"; CallString "456"];
8340   call "test0" [CallString "abc"; CallOptString (Some "def");
8341                 CallStringList ["1"]; CallBool false;
8342                 CallInt (-2); CallString "123"; CallString "456"];
8343   call "test0" [CallString "abc"; CallOptString (Some "def");
8344                 CallStringList ["1"]; CallBool false;
8345                 CallInt 1; CallString "123"; CallString "456"];
8346   call "test0" [CallString "abc"; CallOptString (Some "def");
8347                 CallStringList ["1"]; CallBool false;
8348                 CallInt 2; CallString "123"; CallString "456"];
8349   call "test0" [CallString "abc"; CallOptString (Some "def");
8350                 CallStringList ["1"]; CallBool false;
8351                 CallInt 4095; CallString "123"; CallString "456"];
8352   call "test0" [CallString "abc"; CallOptString (Some "def");
8353                 CallStringList ["1"]; CallBool false;
8354                 CallInt 0; CallString ""; CallString ""]
8355
8356 (* XXX Add here tests of the return and error functions. *)
8357
8358 (* This is used to generate the src/MAX_PROC_NR file which
8359  * contains the maximum procedure number, a surrogate for the
8360  * ABI version number.  See src/Makefile.am for the details.
8361  *)
8362 and generate_max_proc_nr () =
8363   let proc_nrs = List.map (
8364     fun (_, _, proc_nr, _, _, _, _) -> proc_nr
8365   ) daemon_functions in
8366
8367   let max_proc_nr = List.fold_left max 0 proc_nrs in
8368
8369   pr "%d\n" max_proc_nr
8370
8371 let output_to filename =
8372   let filename_new = filename ^ ".new" in
8373   chan := open_out filename_new;
8374   let close () =
8375     close_out !chan;
8376     chan := stdout;
8377
8378     (* Is the new file different from the current file? *)
8379     if Sys.file_exists filename && files_equal filename filename_new then
8380       Unix.unlink filename_new          (* same, so skip it *)
8381     else (
8382       (* different, overwrite old one *)
8383       (try Unix.chmod filename 0o644 with Unix.Unix_error _ -> ());
8384       Unix.rename filename_new filename;
8385       Unix.chmod filename 0o444;
8386       printf "written %s\n%!" filename;
8387     )
8388   in
8389   close
8390
8391 (* Main program. *)
8392 let () =
8393   check_functions ();
8394
8395   if not (Sys.file_exists "HACKING") then (
8396     eprintf "\
8397 You are probably running this from the wrong directory.
8398 Run it from the top source directory using the command
8399   src/generator.ml
8400 ";
8401     exit 1
8402   );
8403
8404   let close = output_to "src/guestfs_protocol.x" in
8405   generate_xdr ();
8406   close ();
8407
8408   let close = output_to "src/guestfs-structs.h" in
8409   generate_structs_h ();
8410   close ();
8411
8412   let close = output_to "src/guestfs-actions.h" in
8413   generate_actions_h ();
8414   close ();
8415
8416   let close = output_to "src/guestfs-actions.c" in
8417   generate_client_actions ();
8418   close ();
8419
8420   let close = output_to "daemon/actions.h" in
8421   generate_daemon_actions_h ();
8422   close ();
8423
8424   let close = output_to "daemon/stubs.c" in
8425   generate_daemon_actions ();
8426   close ();
8427
8428   let close = output_to "daemon/names.c" in
8429   generate_daemon_names ();
8430   close ();
8431
8432   let close = output_to "capitests/tests.c" in
8433   generate_tests ();
8434   close ();
8435
8436   let close = output_to "src/guestfs-bindtests.c" in
8437   generate_bindtests ();
8438   close ();
8439
8440   let close = output_to "fish/cmds.c" in
8441   generate_fish_cmds ();
8442   close ();
8443
8444   let close = output_to "fish/completion.c" in
8445   generate_fish_completion ();
8446   close ();
8447
8448   let close = output_to "guestfs-structs.pod" in
8449   generate_structs_pod ();
8450   close ();
8451
8452   let close = output_to "guestfs-actions.pod" in
8453   generate_actions_pod ();
8454   close ();
8455
8456   let close = output_to "guestfish-actions.pod" in
8457   generate_fish_actions_pod ();
8458   close ();
8459
8460   let close = output_to "ocaml/guestfs.mli" in
8461   generate_ocaml_mli ();
8462   close ();
8463
8464   let close = output_to "ocaml/guestfs.ml" in
8465   generate_ocaml_ml ();
8466   close ();
8467
8468   let close = output_to "ocaml/guestfs_c_actions.c" in
8469   generate_ocaml_c ();
8470   close ();
8471
8472   let close = output_to "ocaml/bindtests.ml" in
8473   generate_ocaml_bindtests ();
8474   close ();
8475
8476   let close = output_to "perl/Guestfs.xs" in
8477   generate_perl_xs ();
8478   close ();
8479
8480   let close = output_to "perl/lib/Sys/Guestfs.pm" in
8481   generate_perl_pm ();
8482   close ();
8483
8484   let close = output_to "perl/bindtests.pl" in
8485   generate_perl_bindtests ();
8486   close ();
8487
8488   let close = output_to "python/guestfs-py.c" in
8489   generate_python_c ();
8490   close ();
8491
8492   let close = output_to "python/guestfs.py" in
8493   generate_python_py ();
8494   close ();
8495
8496   let close = output_to "python/bindtests.py" in
8497   generate_python_bindtests ();
8498   close ();
8499
8500   let close = output_to "ruby/ext/guestfs/_guestfs.c" in
8501   generate_ruby_c ();
8502   close ();
8503
8504   let close = output_to "ruby/bindtests.rb" in
8505   generate_ruby_bindtests ();
8506   close ();
8507
8508   let close = output_to "java/com/redhat/et/libguestfs/GuestFS.java" in
8509   generate_java_java ();
8510   close ();
8511
8512   List.iter (
8513     fun (typ, jtyp) ->
8514       let cols = cols_of_struct typ in
8515       let filename = sprintf "java/com/redhat/et/libguestfs/%s.java" jtyp in
8516       let close = output_to filename in
8517       generate_java_struct jtyp cols;
8518       close ();
8519   ) java_structs;
8520
8521   let close = output_to "java/Makefile.inc" in
8522   pr "java_built_sources =";
8523   List.iter (
8524     fun (typ, jtyp) ->
8525         pr " com/redhat/et/libguestfs/%s.java" jtyp;
8526   ) java_structs;
8527   pr " com/redhat/et/libguestfs/GuestFS.java\n";
8528   close ();
8529
8530   let close = output_to "java/com_redhat_et_libguestfs_GuestFS.c" in
8531   generate_java_c ();
8532   close ();
8533
8534   let close = output_to "java/Bindtests.java" in
8535   generate_java_bindtests ();
8536   close ();
8537
8538   let close = output_to "haskell/Guestfs.hs" in
8539   generate_haskell_hs ();
8540   close ();
8541
8542   let close = output_to "haskell/Bindtests.hs" in
8543   generate_haskell_bindtests ();
8544   close ();
8545
8546   let close = output_to "src/MAX_PROC_NR" in
8547   generate_max_proc_nr ();
8548   close ();
8549
8550   (* Always generate this file last, and unconditionally.  It's used
8551    * by the Makefile to know when we must re-run the generator.
8552    *)
8553   let chan = open_out "src/stamp-generator" in
8554   fprintf chan "1\n";
8555   close_out chan