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 Also this call returns basic file type information about each
2846 file.  The C<ftyp> field will contain one of the following characters:
2847
2848 =over 4
2849
2850 =item 'b'
2851
2852 Block special
2853
2854 =item 'c'
2855
2856 Char special
2857
2858 =item 'd'
2859
2860 Directory
2861
2862 =item 'f'
2863
2864 FIFO (named pipe)
2865
2866 =item 'l'
2867
2868 Symbolic link
2869
2870 =item 'r'
2871
2872 Regular file
2873
2874 =item 's'
2875
2876 Socket
2877
2878 =item 'u'
2879
2880 Unknown file type
2881
2882 =item '?'
2883
2884 The L<readdir(3)> returned a C<d_type> field with an
2885 unexpected value
2886
2887 =back
2888
2889 This function is primarily intended for use by programs.  To
2890 get a simple list of names, use C<guestfs_ls>.  To get a printable
2891 directory for human consumption, use C<guestfs_ll>.");
2892
2893   ("sfdiskM", (RErr, [String "device"; StringList "lines"]), 139, [DangerWillRobinson],
2894    [],
2895    "create partitions on a block device",
2896    "\
2897 This is a simplified interface to the C<guestfs_sfdisk>
2898 command, where partition sizes are specified in megabytes
2899 only (rounded to the nearest cylinder) and you don't need
2900 to specify the cyls, heads and sectors parameters which
2901 were rarely if ever used anyway.
2902
2903 See also C<guestfs_sfdisk> and the L<sfdisk(8)> manpage.");
2904
2905   ("zfile", (RString "description", [String "method"; String "path"]), 140, [],
2906    [],
2907    "determine file type inside a compressed file",
2908    "\
2909 This command runs C<file> after first decompressing C<path>
2910 using C<method>.
2911
2912 C<method> must be one of C<gzip>, C<compress> or C<bzip2>.
2913
2914 See also: C<guestfs_file>");
2915
2916   ("getxattrs", (RStructList ("xattrs", "xattr"), [String "path"]), 141, [],
2917    [],
2918    "list extended attributes of a file or directory",
2919    "\
2920 This call lists the extended attributes of the file or directory
2921 C<path>.
2922
2923 At the system call level, this is a combination of the
2924 L<listxattr(2)> and L<getxattr(2)> calls.
2925
2926 See also: C<guestfs_lgetxattrs>, L<attr(5)>.");
2927
2928   ("lgetxattrs", (RStructList ("xattrs", "xattr"), [String "path"]), 142, [],
2929    [],
2930    "list extended attributes of a file or directory",
2931    "\
2932 This is the same as C<guestfs_getxattrs>, but if C<path>
2933 is a symbolic link, then it returns the extended attributes
2934 of the link itself.");
2935
2936   ("setxattr", (RErr, [String "xattr";
2937                        String "val"; Int "vallen"; (* will be BufferIn *)
2938                        String "path"]), 143, [],
2939    [],
2940    "set extended attribute of a file or directory",
2941    "\
2942 This call sets the extended attribute named C<xattr>
2943 of the file C<path> to the value C<val> (of length C<vallen>).
2944 The value is arbitrary 8 bit data.
2945
2946 See also: C<guestfs_lsetxattr>, L<attr(5)>.");
2947
2948   ("lsetxattr", (RErr, [String "xattr";
2949                         String "val"; Int "vallen"; (* will be BufferIn *)
2950                         String "path"]), 144, [],
2951    [],
2952    "set extended attribute of a file or directory",
2953    "\
2954 This is the same as C<guestfs_setxattr>, but if C<path>
2955 is a symbolic link, then it sets an extended attribute
2956 of the link itself.");
2957
2958   ("removexattr", (RErr, [String "xattr"; String "path"]), 145, [],
2959    [],
2960    "remove extended attribute of a file or directory",
2961    "\
2962 This call removes the extended attribute named C<xattr>
2963 of the file C<path>.
2964
2965 See also: C<guestfs_lremovexattr>, L<attr(5)>.");
2966
2967   ("lremovexattr", (RErr, [String "xattr"; String "path"]), 146, [],
2968    [],
2969    "remove extended attribute of a file or directory",
2970    "\
2971 This is the same as C<guestfs_removexattr>, but if C<path>
2972 is a symbolic link, then it removes an extended attribute
2973 of the link itself.");
2974
2975   ("mountpoints", (RHashtable "mps", []), 147, [],
2976    [],
2977    "show mountpoints",
2978    "\
2979 This call is similar to C<guestfs_mounts>.  That call returns
2980 a list of devices.  This one returns a hash table (map) of
2981 device name to directory where the device is mounted.");
2982
2983   ("mkmountpoint", (RErr, [String "path"]), 148, [],
2984    [],
2985    "create a mountpoint",
2986    "\
2987 C<guestfs_mkmountpoint> and C<guestfs_rmmountpoint> are
2988 specialized calls that can be used to create extra mountpoints
2989 before mounting the first filesystem.
2990
2991 These calls are I<only> necessary in some very limited circumstances,
2992 mainly the case where you want to mount a mix of unrelated and/or
2993 read-only filesystems together.
2994
2995 For example, live CDs often contain a \"Russian doll\" nest of
2996 filesystems, an ISO outer layer, with a squashfs image inside, with
2997 an ext2/3 image inside that.  You can unpack this as follows
2998 in guestfish:
2999
3000  add-ro Fedora-11-i686-Live.iso
3001  run
3002  mkmountpoint /cd
3003  mkmountpoint /squash
3004  mkmountpoint /ext3
3005  mount /dev/sda /cd
3006  mount-loop /cd/LiveOS/squashfs.img /squash
3007  mount-loop /squash/LiveOS/ext3fs.img /ext3
3008
3009 The inner filesystem is now unpacked under the /ext3 mountpoint.");
3010
3011   ("rmmountpoint", (RErr, [String "path"]), 149, [],
3012    [],
3013    "remove a mountpoint",
3014    "\
3015 This calls removes a mountpoint that was previously created
3016 with C<guestfs_mkmountpoint>.  See C<guestfs_mkmountpoint>
3017 for full details.");
3018
3019 ]
3020
3021 let all_functions = non_daemon_functions @ daemon_functions
3022
3023 (* In some places we want the functions to be displayed sorted
3024  * alphabetically, so this is useful:
3025  *)
3026 let all_functions_sorted =
3027   List.sort (fun (n1,_,_,_,_,_,_) (n2,_,_,_,_,_,_) ->
3028                compare n1 n2) all_functions
3029
3030 (* Field types for structures. *)
3031 type field =
3032   | FChar                       (* C 'char' (really, a 7 bit byte). *)
3033   | FString                     (* nul-terminated ASCII string. *)
3034   | FBuffer                     (* opaque buffer of bytes, (char *, int) pair *)
3035   | FUInt32
3036   | FInt32
3037   | FUInt64
3038   | FInt64
3039   | FBytes                      (* Any int measure that counts bytes. *)
3040   | FUUID                       (* 32 bytes long, NOT nul-terminated. *)
3041   | FOptPercent                 (* [0..100], or -1 meaning "not present". *)
3042
3043 (* Because we generate extra parsing code for LVM command line tools,
3044  * we have to pull out the LVM columns separately here.
3045  *)
3046 let lvm_pv_cols = [
3047   "pv_name", FString;
3048   "pv_uuid", FUUID;
3049   "pv_fmt", FString;
3050   "pv_size", FBytes;
3051   "dev_size", FBytes;
3052   "pv_free", FBytes;
3053   "pv_used", FBytes;
3054   "pv_attr", FString (* XXX *);
3055   "pv_pe_count", FInt64;
3056   "pv_pe_alloc_count", FInt64;
3057   "pv_tags", FString;
3058   "pe_start", FBytes;
3059   "pv_mda_count", FInt64;
3060   "pv_mda_free", FBytes;
3061   (* Not in Fedora 10:
3062      "pv_mda_size", FBytes;
3063   *)
3064 ]
3065 let lvm_vg_cols = [
3066   "vg_name", FString;
3067   "vg_uuid", FUUID;
3068   "vg_fmt", FString;
3069   "vg_attr", FString (* XXX *);
3070   "vg_size", FBytes;
3071   "vg_free", FBytes;
3072   "vg_sysid", FString;
3073   "vg_extent_size", FBytes;
3074   "vg_extent_count", FInt64;
3075   "vg_free_count", FInt64;
3076   "max_lv", FInt64;
3077   "max_pv", FInt64;
3078   "pv_count", FInt64;
3079   "lv_count", FInt64;
3080   "snap_count", FInt64;
3081   "vg_seqno", FInt64;
3082   "vg_tags", FString;
3083   "vg_mda_count", FInt64;
3084   "vg_mda_free", FBytes;
3085   (* Not in Fedora 10:
3086      "vg_mda_size", FBytes;
3087   *)
3088 ]
3089 let lvm_lv_cols = [
3090   "lv_name", FString;
3091   "lv_uuid", FUUID;
3092   "lv_attr", FString (* XXX *);
3093   "lv_major", FInt64;
3094   "lv_minor", FInt64;
3095   "lv_kernel_major", FInt64;
3096   "lv_kernel_minor", FInt64;
3097   "lv_size", FBytes;
3098   "seg_count", FInt64;
3099   "origin", FString;
3100   "snap_percent", FOptPercent;
3101   "copy_percent", FOptPercent;
3102   "move_pv", FString;
3103   "lv_tags", FString;
3104   "mirror_log", FString;
3105   "modules", FString;
3106 ]
3107
3108 (* Names and fields in all structures (in RStruct and RStructList)
3109  * that we support.
3110  *)
3111 let structs = [
3112   (* The old RIntBool return type, only ever used for aug_defnode.  Do
3113    * not use this struct in any new code.
3114    *)
3115   "int_bool", [
3116     "i", FInt32;                (* for historical compatibility *)
3117     "b", FInt32;                (* for historical compatibility *)
3118   ];
3119
3120   (* LVM PVs, VGs, LVs. *)
3121   "lvm_pv", lvm_pv_cols;
3122   "lvm_vg", lvm_vg_cols;
3123   "lvm_lv", lvm_lv_cols;
3124
3125   (* Column names and types from stat structures.
3126    * NB. Can't use things like 'st_atime' because glibc header files
3127    * define some of these as macros.  Ugh.
3128    *)
3129   "stat", [
3130     "dev", FInt64;
3131     "ino", FInt64;
3132     "mode", FInt64;
3133     "nlink", FInt64;
3134     "uid", FInt64;
3135     "gid", FInt64;
3136     "rdev", FInt64;
3137     "size", FInt64;
3138     "blksize", FInt64;
3139     "blocks", FInt64;
3140     "atime", FInt64;
3141     "mtime", FInt64;
3142     "ctime", FInt64;
3143   ];
3144   "statvfs", [
3145     "bsize", FInt64;
3146     "frsize", FInt64;
3147     "blocks", FInt64;
3148     "bfree", FInt64;
3149     "bavail", FInt64;
3150     "files", FInt64;
3151     "ffree", FInt64;
3152     "favail", FInt64;
3153     "fsid", FInt64;
3154     "flag", FInt64;
3155     "namemax", FInt64;
3156   ];
3157
3158   (* Column names in dirent structure. *)
3159   "dirent", [
3160     "ino", FInt64;
3161     (* 'b' 'c' 'd' 'f' (FIFO) 'l' 'r' (regular file) 's' 'u' '?' *)
3162     "ftyp", FChar;
3163     "name", FString;
3164   ];
3165
3166   (* Version numbers. *)
3167   "version", [
3168     "major", FInt64;
3169     "minor", FInt64;
3170     "release", FInt64;
3171     "extra", FString;
3172   ];
3173
3174   (* Extended attribute. *)
3175   "xattr", [
3176     "attrname", FString;
3177     "attrval", FBuffer;
3178   ];
3179 ] (* end of structs *)
3180
3181 (* Ugh, Java has to be different ..
3182  * These names are also used by the Haskell bindings.
3183  *)
3184 let java_structs = [
3185   "int_bool", "IntBool";
3186   "lvm_pv", "PV";
3187   "lvm_vg", "VG";
3188   "lvm_lv", "LV";
3189   "stat", "Stat";
3190   "statvfs", "StatVFS";
3191   "dirent", "Dirent";
3192   "version", "Version";
3193   "xattr", "XAttr";
3194 ]
3195
3196 (* Used for testing language bindings. *)
3197 type callt =
3198   | CallString of string
3199   | CallOptString of string option
3200   | CallStringList of string list
3201   | CallInt of int
3202   | CallBool of bool
3203
3204 (* Used to memoize the result of pod2text. *)
3205 let pod2text_memo_filename = "src/.pod2text.data"
3206 let pod2text_memo : ((int * string * string), string list) Hashtbl.t =
3207   try
3208     let chan = open_in pod2text_memo_filename in
3209     let v = input_value chan in
3210     close_in chan;
3211     v
3212   with
3213     _ -> Hashtbl.create 13
3214
3215 (* Useful functions.
3216  * Note we don't want to use any external OCaml libraries which
3217  * makes this a bit harder than it should be.
3218  *)
3219 let failwithf fs = ksprintf failwith fs
3220
3221 let replace_char s c1 c2 =
3222   let s2 = String.copy s in
3223   let r = ref false in
3224   for i = 0 to String.length s2 - 1 do
3225     if String.unsafe_get s2 i = c1 then (
3226       String.unsafe_set s2 i c2;
3227       r := true
3228     )
3229   done;
3230   if not !r then s else s2
3231
3232 let isspace c =
3233   c = ' '
3234   (* || c = '\f' *) || c = '\n' || c = '\r' || c = '\t' (* || c = '\v' *)
3235
3236 let triml ?(test = isspace) str =
3237   let i = ref 0 in
3238   let n = ref (String.length str) in
3239   while !n > 0 && test str.[!i]; do
3240     decr n;
3241     incr i
3242   done;
3243   if !i = 0 then str
3244   else String.sub str !i !n
3245
3246 let trimr ?(test = isspace) str =
3247   let n = ref (String.length str) in
3248   while !n > 0 && test str.[!n-1]; do
3249     decr n
3250   done;
3251   if !n = String.length str then str
3252   else String.sub str 0 !n
3253
3254 let trim ?(test = isspace) str =
3255   trimr ~test (triml ~test str)
3256
3257 let rec find s sub =
3258   let len = String.length s in
3259   let sublen = String.length sub in
3260   let rec loop i =
3261     if i <= len-sublen then (
3262       let rec loop2 j =
3263         if j < sublen then (
3264           if s.[i+j] = sub.[j] then loop2 (j+1)
3265           else -1
3266         ) else
3267           i (* found *)
3268       in
3269       let r = loop2 0 in
3270       if r = -1 then loop (i+1) else r
3271     ) else
3272       -1 (* not found *)
3273   in
3274   loop 0
3275
3276 let rec replace_str s s1 s2 =
3277   let len = String.length s in
3278   let sublen = String.length s1 in
3279   let i = find s s1 in
3280   if i = -1 then s
3281   else (
3282     let s' = String.sub s 0 i in
3283     let s'' = String.sub s (i+sublen) (len-i-sublen) in
3284     s' ^ s2 ^ replace_str s'' s1 s2
3285   )
3286
3287 let rec string_split sep str =
3288   let len = String.length str in
3289   let seplen = String.length sep in
3290   let i = find str sep in
3291   if i = -1 then [str]
3292   else (
3293     let s' = String.sub str 0 i in
3294     let s'' = String.sub str (i+seplen) (len-i-seplen) in
3295     s' :: string_split sep s''
3296   )
3297
3298 let files_equal n1 n2 =
3299   let cmd = sprintf "cmp -s %s %s" (Filename.quote n1) (Filename.quote n2) in
3300   match Sys.command cmd with
3301   | 0 -> true
3302   | 1 -> false
3303   | i -> failwithf "%s: failed with error code %d" cmd i
3304
3305 let rec find_map f = function
3306   | [] -> raise Not_found
3307   | x :: xs ->
3308       match f x with
3309       | Some y -> y
3310       | None -> find_map f xs
3311
3312 let iteri f xs =
3313   let rec loop i = function
3314     | [] -> ()
3315     | x :: xs -> f i x; loop (i+1) xs
3316   in
3317   loop 0 xs
3318
3319 let mapi f xs =
3320   let rec loop i = function
3321     | [] -> []
3322     | x :: xs -> let r = f i x in r :: loop (i+1) xs
3323   in
3324   loop 0 xs
3325
3326 let name_of_argt = function
3327   | String n | OptString n | StringList n | Bool n | Int n
3328   | FileIn n | FileOut n -> n
3329
3330 let java_name_of_struct typ =
3331   try List.assoc typ java_structs
3332   with Not_found ->
3333     failwithf
3334       "java_name_of_struct: no java_structs entry corresponding to %s" typ
3335
3336 let cols_of_struct typ =
3337   try List.assoc typ structs
3338   with Not_found ->
3339     failwithf "cols_of_struct: unknown struct %s" typ
3340
3341 let seq_of_test = function
3342   | TestRun s | TestOutput (s, _) | TestOutputList (s, _)
3343   | TestOutputListOfDevices (s, _)
3344   | TestOutputInt (s, _) | TestOutputIntOp (s, _, _)
3345   | TestOutputTrue s | TestOutputFalse s
3346   | TestOutputLength (s, _) | TestOutputStruct (s, _)
3347   | TestLastFail s -> s
3348
3349 (* Check function names etc. for consistency. *)
3350 let check_functions () =
3351   let contains_uppercase str =
3352     let len = String.length str in
3353     let rec loop i =
3354       if i >= len then false
3355       else (
3356         let c = str.[i] in
3357         if c >= 'A' && c <= 'Z' then true
3358         else loop (i+1)
3359       )
3360     in
3361     loop 0
3362   in
3363
3364   (* Check function names. *)
3365   List.iter (
3366     fun (name, _, _, _, _, _, _) ->
3367       if String.length name >= 7 && String.sub name 0 7 = "guestfs" then
3368         failwithf "function name %s does not need 'guestfs' prefix" name;
3369       if name = "" then
3370         failwithf "function name is empty";
3371       if name.[0] < 'a' || name.[0] > 'z' then
3372         failwithf "function name %s must start with lowercase a-z" name;
3373       if String.contains name '-' then
3374         failwithf "function name %s should not contain '-', use '_' instead."
3375           name
3376   ) all_functions;
3377
3378   (* Check function parameter/return names. *)
3379   List.iter (
3380     fun (name, style, _, _, _, _, _) ->
3381       let check_arg_ret_name n =
3382         if contains_uppercase n then
3383           failwithf "%s param/ret %s should not contain uppercase chars"
3384             name n;
3385         if String.contains n '-' || String.contains n '_' then
3386           failwithf "%s param/ret %s should not contain '-' or '_'"
3387             name n;
3388         if n = "value" then
3389           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;
3390         if n = "int" || n = "char" || n = "short" || n = "long" then
3391           failwithf "%s has a param/ret which conflicts with a C type (eg. 'int', 'char' etc.)" name;
3392         if n = "i" || n = "n" then
3393           failwithf "%s has a param/ret called 'i' or 'n', which will cause some conflicts in the generated code" name;
3394         if n = "argv" || n = "args" then
3395           failwithf "%s has a param/ret called 'argv' or 'args', which will cause some conflicts in the generated code" name
3396       in
3397
3398       (match fst style with
3399        | RErr -> ()
3400        | RInt n | RInt64 n | RBool n | RConstString n | RString n
3401        | RStringList n | RStruct (n, _) | RStructList (n, _)
3402        | RHashtable n ->
3403            check_arg_ret_name n
3404       );
3405       List.iter (fun arg -> check_arg_ret_name (name_of_argt arg)) (snd style)
3406   ) all_functions;
3407
3408   (* Check short descriptions. *)
3409   List.iter (
3410     fun (name, _, _, _, _, shortdesc, _) ->
3411       if shortdesc.[0] <> Char.lowercase shortdesc.[0] then
3412         failwithf "short description of %s should begin with lowercase." name;
3413       let c = shortdesc.[String.length shortdesc-1] in
3414       if c = '\n' || c = '.' then
3415         failwithf "short description of %s should not end with . or \\n." name
3416   ) all_functions;
3417
3418   (* Check long dscriptions. *)
3419   List.iter (
3420     fun (name, _, _, _, _, _, longdesc) ->
3421       if longdesc.[String.length longdesc-1] = '\n' then
3422         failwithf "long description of %s should not end with \\n." name
3423   ) all_functions;
3424
3425   (* Check proc_nrs. *)
3426   List.iter (
3427     fun (name, _, proc_nr, _, _, _, _) ->
3428       if proc_nr <= 0 then
3429         failwithf "daemon function %s should have proc_nr > 0" name
3430   ) daemon_functions;
3431
3432   List.iter (
3433     fun (name, _, proc_nr, _, _, _, _) ->
3434       if proc_nr <> -1 then
3435         failwithf "non-daemon function %s should have proc_nr -1" name
3436   ) non_daemon_functions;
3437
3438   let proc_nrs =
3439     List.map (fun (name, _, proc_nr, _, _, _, _) -> name, proc_nr)
3440       daemon_functions in
3441   let proc_nrs =
3442     List.sort (fun (_,nr1) (_,nr2) -> compare nr1 nr2) proc_nrs in
3443   let rec loop = function
3444     | [] -> ()
3445     | [_] -> ()
3446     | (name1,nr1) :: ((name2,nr2) :: _ as rest) when nr1 < nr2 ->
3447         loop rest
3448     | (name1,nr1) :: (name2,nr2) :: _ ->
3449         failwithf "%s and %s have conflicting procedure numbers (%d, %d)"
3450           name1 name2 nr1 nr2
3451   in
3452   loop proc_nrs;
3453
3454   (* Check tests. *)
3455   List.iter (
3456     function
3457       (* Ignore functions that have no tests.  We generate a
3458        * warning when the user does 'make check' instead.
3459        *)
3460     | name, _, _, _, [], _, _ -> ()
3461     | name, _, _, _, tests, _, _ ->
3462         let funcs =
3463           List.map (
3464             fun (_, _, test) ->
3465               match seq_of_test test with
3466               | [] ->
3467                   failwithf "%s has a test containing an empty sequence" name
3468               | cmds -> List.map List.hd cmds
3469           ) tests in
3470         let funcs = List.flatten funcs in
3471
3472         let tested = List.mem name funcs in
3473
3474         if not tested then
3475           failwithf "function %s has tests but does not test itself" name
3476   ) all_functions
3477
3478 (* 'pr' prints to the current output file. *)
3479 let chan = ref stdout
3480 let pr fs = ksprintf (output_string !chan) fs
3481
3482 (* Generate a header block in a number of standard styles. *)
3483 type comment_style = CStyle | HashStyle | OCamlStyle | HaskellStyle
3484 type license = GPLv2 | LGPLv2
3485
3486 let generate_header comment license =
3487   let c = match comment with
3488     | CStyle ->     pr "/* "; " *"
3489     | HashStyle ->  pr "# ";  "#"
3490     | OCamlStyle -> pr "(* "; " *"
3491     | HaskellStyle -> pr "{- "; "  " in
3492   pr "libguestfs generated file\n";
3493   pr "%s WARNING: THIS FILE IS GENERATED BY 'src/generator.ml'.\n" c;
3494   pr "%s ANY CHANGES YOU MAKE TO THIS FILE WILL BE LOST.\n" c;
3495   pr "%s\n" c;
3496   pr "%s Copyright (C) 2009 Red Hat Inc.\n" c;
3497   pr "%s\n" c;
3498   (match license with
3499    | GPLv2 ->
3500        pr "%s This program is free software; you can redistribute it and/or modify\n" c;
3501        pr "%s it under the terms of the GNU General Public License as published by\n" c;
3502        pr "%s the Free Software Foundation; either version 2 of the License, or\n" c;
3503        pr "%s (at your option) any later version.\n" c;
3504        pr "%s\n" c;
3505        pr "%s This program is distributed in the hope that it will be useful,\n" c;
3506        pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
3507        pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the\n" c;
3508        pr "%s GNU General Public License for more details.\n" c;
3509        pr "%s\n" c;
3510        pr "%s You should have received a copy of the GNU General Public License along\n" c;
3511        pr "%s with this program; if not, write to the Free Software Foundation, Inc.,\n" c;
3512        pr "%s 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n" c;
3513
3514    | LGPLv2 ->
3515        pr "%s This library is free software; you can redistribute it and/or\n" c;
3516        pr "%s modify it under the terms of the GNU Lesser General Public\n" c;
3517        pr "%s License as published by the Free Software Foundation; either\n" c;
3518        pr "%s version 2 of the License, or (at your option) any later version.\n" c;
3519        pr "%s\n" c;
3520        pr "%s This library is distributed in the hope that it will be useful,\n" c;
3521        pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
3522        pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU\n" c;
3523        pr "%s Lesser General Public License for more details.\n" c;
3524        pr "%s\n" c;
3525        pr "%s You should have received a copy of the GNU Lesser General Public\n" c;
3526        pr "%s License along with this library; if not, write to the Free Software\n" c;
3527        pr "%s Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA\n" c;
3528   );
3529   (match comment with
3530    | CStyle -> pr " */\n"
3531    | HashStyle -> ()
3532    | OCamlStyle -> pr " *)\n"
3533    | HaskellStyle -> pr "-}\n"
3534   );
3535   pr "\n"
3536
3537 (* Start of main code generation functions below this line. *)
3538
3539 (* Generate the pod documentation for the C API. *)
3540 let rec generate_actions_pod () =
3541   List.iter (
3542     fun (shortname, style, _, flags, _, _, longdesc) ->
3543       if not (List.mem NotInDocs flags) then (
3544         let name = "guestfs_" ^ shortname in
3545         pr "=head2 %s\n\n" name;
3546         pr " ";
3547         generate_prototype ~extern:false ~handle:"handle" name style;
3548         pr "\n\n";
3549         pr "%s\n\n" longdesc;
3550         (match fst style with
3551          | RErr ->
3552              pr "This function returns 0 on success or -1 on error.\n\n"
3553          | RInt _ ->
3554              pr "On error this function returns -1.\n\n"
3555          | RInt64 _ ->
3556              pr "On error this function returns -1.\n\n"
3557          | RBool _ ->
3558              pr "This function returns a C truth value on success or -1 on error.\n\n"
3559          | RConstString _ ->
3560              pr "This function returns a string, or NULL on error.
3561 The string is owned by the guest handle and must I<not> be freed.\n\n"
3562          | RString _ ->
3563              pr "This function returns a string, or NULL on error.
3564 I<The caller must free the returned string after use>.\n\n"
3565          | RStringList _ ->
3566              pr "This function returns a NULL-terminated array of strings
3567 (like L<environ(3)>), or NULL if there was an error.
3568 I<The caller must free the strings and the array after use>.\n\n"
3569          | RStruct (_, typ) ->
3570              pr "This function returns a C<struct guestfs_%s *>,
3571 or NULL if there was an error.
3572 I<The caller must call C<guestfs_free_%s> after use>.\n\n" typ typ
3573          | RStructList (_, typ) ->
3574              pr "This function returns a C<struct guestfs_%s_list *>
3575 (see E<lt>guestfs-structs.hE<gt>),
3576 or NULL if there was an error.
3577 I<The caller must call C<guestfs_free_%s_list> after use>.\n\n" typ typ
3578          | RHashtable _ ->
3579              pr "This function returns a NULL-terminated array of
3580 strings, or NULL if there was an error.
3581 The array of strings will always have length C<2n+1>, where
3582 C<n> keys and values alternate, followed by the trailing NULL entry.
3583 I<The caller must free the strings and the array after use>.\n\n"
3584         );
3585         if List.mem ProtocolLimitWarning flags then
3586           pr "%s\n\n" protocol_limit_warning;
3587         if List.mem DangerWillRobinson flags then
3588           pr "%s\n\n" danger_will_robinson
3589       )
3590   ) all_functions_sorted
3591
3592 and generate_structs_pod () =
3593   (* Structs documentation. *)
3594   List.iter (
3595     fun (typ, cols) ->
3596       pr "=head2 guestfs_%s\n" typ;
3597       pr "\n";
3598       pr " struct guestfs_%s {\n" typ;
3599       List.iter (
3600         function
3601         | name, FChar -> pr "   char %s;\n" name
3602         | name, FUInt32 -> pr "   uint32_t %s;\n" name
3603         | name, FInt32 -> pr "   int32_t %s;\n" name
3604         | name, (FUInt64|FBytes) -> pr "   uint64_t %s;\n" name
3605         | name, FInt64 -> pr "   int64_t %s;\n" name
3606         | name, FString -> pr "   char *%s;\n" name
3607         | name, FBuffer ->
3608             pr "   /* The next two fields describe a byte array. */\n";
3609             pr "   uint32_t %s_len;\n" name;
3610             pr "   char *%s;\n" name
3611         | name, FUUID ->
3612             pr "   /* The next field is NOT nul-terminated, be careful when printing it: */\n";
3613             pr "   char %s[32];\n" name
3614         | name, FOptPercent ->
3615             pr "   /* The next field is [0..100] or -1 meaning 'not present': */\n";
3616             pr "   float %s;\n" name
3617       ) cols;
3618       pr " };\n";
3619       pr " \n";
3620       pr " struct guestfs_%s_list {\n" typ;
3621       pr "   uint32_t len; /* Number of elements in list. */\n";
3622       pr "   struct guestfs_%s *val; /* Elements. */\n" typ;
3623       pr " };\n";
3624       pr " \n";
3625       pr " void guestfs_free_%s (struct guestfs_free_%s *);\n" typ typ;
3626       pr " void guestfs_free_%s_list (struct guestfs_free_%s_list *);\n"
3627         typ typ;
3628       pr "\n"
3629   ) structs
3630
3631 (* Generate the protocol (XDR) file, 'guestfs_protocol.x' and
3632  * indirectly 'guestfs_protocol.h' and 'guestfs_protocol.c'.
3633  *
3634  * We have to use an underscore instead of a dash because otherwise
3635  * rpcgen generates incorrect code.
3636  *
3637  * This header is NOT exported to clients, but see also generate_structs_h.
3638  *)
3639 and generate_xdr () =
3640   generate_header CStyle LGPLv2;
3641
3642   (* This has to be defined to get around a limitation in Sun's rpcgen. *)
3643   pr "typedef string str<>;\n";
3644   pr "\n";
3645
3646   (* Internal structures. *)
3647   List.iter (
3648     function
3649     | typ, cols ->
3650         pr "struct guestfs_int_%s {\n" typ;
3651         List.iter (function
3652                    | name, FChar -> pr "  char %s;\n" name
3653                    | name, FString -> pr "  string %s<>;\n" name
3654                    | name, FBuffer -> pr "  opaque %s<>;\n" name
3655                    | name, FUUID -> pr "  opaque %s[32];\n" name
3656                    | name, (FInt32|FUInt32) -> pr "  int %s;\n" name
3657                    | name, (FInt64|FUInt64|FBytes) -> pr "  hyper %s;\n" name
3658                    | name, FOptPercent -> pr "  float %s;\n" name
3659                   ) cols;
3660         pr "};\n";
3661         pr "\n";
3662         pr "typedef struct guestfs_int_%s guestfs_int_%s_list<>;\n" typ typ;
3663         pr "\n";
3664   ) structs;
3665
3666   List.iter (
3667     fun (shortname, style, _, _, _, _, _) ->
3668       let name = "guestfs_" ^ shortname in
3669
3670       (match snd style with
3671        | [] -> ()
3672        | args ->
3673            pr "struct %s_args {\n" name;
3674            List.iter (
3675              function
3676              | String n -> pr "  string %s<>;\n" n
3677              | OptString n -> pr "  str *%s;\n" n
3678              | StringList n -> pr "  str %s<>;\n" n
3679              | Bool n -> pr "  bool %s;\n" n
3680              | Int n -> pr "  int %s;\n" n
3681              | FileIn _ | FileOut _ -> ()
3682            ) args;
3683            pr "};\n\n"
3684       );
3685       (match fst style with
3686        | RErr -> ()
3687        | RInt n ->
3688            pr "struct %s_ret {\n" name;
3689            pr "  int %s;\n" n;
3690            pr "};\n\n"
3691        | RInt64 n ->
3692            pr "struct %s_ret {\n" name;
3693            pr "  hyper %s;\n" n;
3694            pr "};\n\n"
3695        | RBool n ->
3696            pr "struct %s_ret {\n" name;
3697            pr "  bool %s;\n" n;
3698            pr "};\n\n"
3699        | RConstString _ ->
3700            failwithf "RConstString cannot be returned from a daemon function"
3701        | RString n ->
3702            pr "struct %s_ret {\n" name;
3703            pr "  string %s<>;\n" n;
3704            pr "};\n\n"
3705        | RStringList n ->
3706            pr "struct %s_ret {\n" name;
3707            pr "  str %s<>;\n" n;
3708            pr "};\n\n"
3709        | RStruct (n, typ) ->
3710            pr "struct %s_ret {\n" name;
3711            pr "  guestfs_int_%s %s;\n" typ n;
3712            pr "};\n\n"
3713        | RStructList (n, typ) ->
3714            pr "struct %s_ret {\n" name;
3715            pr "  guestfs_int_%s_list %s;\n" typ n;
3716            pr "};\n\n"
3717        | RHashtable n ->
3718            pr "struct %s_ret {\n" name;
3719            pr "  str %s<>;\n" n;
3720            pr "};\n\n"
3721       );
3722   ) daemon_functions;
3723
3724   (* Table of procedure numbers. *)
3725   pr "enum guestfs_procedure {\n";
3726   List.iter (
3727     fun (shortname, _, proc_nr, _, _, _, _) ->
3728       pr "  GUESTFS_PROC_%s = %d,\n" (String.uppercase shortname) proc_nr
3729   ) daemon_functions;
3730   pr "  GUESTFS_PROC_NR_PROCS\n";
3731   pr "};\n";
3732   pr "\n";
3733
3734   (* Having to choose a maximum message size is annoying for several
3735    * reasons (it limits what we can do in the API), but it (a) makes
3736    * the protocol a lot simpler, and (b) provides a bound on the size
3737    * of the daemon which operates in limited memory space.  For large
3738    * file transfers you should use FTP.
3739    *)
3740   pr "const GUESTFS_MESSAGE_MAX = %d;\n" (4 * 1024 * 1024);
3741   pr "\n";
3742
3743   (* Message header, etc. *)
3744   pr "\
3745 /* The communication protocol is now documented in the guestfs(3)
3746  * manpage.
3747  */
3748
3749 const GUESTFS_PROGRAM = 0x2000F5F5;
3750 const GUESTFS_PROTOCOL_VERSION = 1;
3751
3752 /* These constants must be larger than any possible message length. */
3753 const GUESTFS_LAUNCH_FLAG = 0xf5f55ff5;
3754 const GUESTFS_CANCEL_FLAG = 0xffffeeee;
3755
3756 enum guestfs_message_direction {
3757   GUESTFS_DIRECTION_CALL = 0,        /* client -> daemon */
3758   GUESTFS_DIRECTION_REPLY = 1        /* daemon -> client */
3759 };
3760
3761 enum guestfs_message_status {
3762   GUESTFS_STATUS_OK = 0,
3763   GUESTFS_STATUS_ERROR = 1
3764 };
3765
3766 const GUESTFS_ERROR_LEN = 256;
3767
3768 struct guestfs_message_error {
3769   string error_message<GUESTFS_ERROR_LEN>;
3770 };
3771
3772 struct guestfs_message_header {
3773   unsigned prog;                     /* GUESTFS_PROGRAM */
3774   unsigned vers;                     /* GUESTFS_PROTOCOL_VERSION */
3775   guestfs_procedure proc;            /* GUESTFS_PROC_x */
3776   guestfs_message_direction direction;
3777   unsigned serial;                   /* message serial number */
3778   guestfs_message_status status;
3779 };
3780
3781 const GUESTFS_MAX_CHUNK_SIZE = 8192;
3782
3783 struct guestfs_chunk {
3784   int cancel;                        /* if non-zero, transfer is cancelled */
3785   /* data size is 0 bytes if the transfer has finished successfully */
3786   opaque data<GUESTFS_MAX_CHUNK_SIZE>;
3787 };
3788 "
3789
3790 (* Generate the guestfs-structs.h file. *)
3791 and generate_structs_h () =
3792   generate_header CStyle LGPLv2;
3793
3794   (* This is a public exported header file containing various
3795    * structures.  The structures are carefully written to have
3796    * exactly the same in-memory format as the XDR structures that
3797    * we use on the wire to the daemon.  The reason for creating
3798    * copies of these structures here is just so we don't have to
3799    * export the whole of guestfs_protocol.h (which includes much
3800    * unrelated and XDR-dependent stuff that we don't want to be
3801    * public, or required by clients).
3802    *
3803    * To reiterate, we will pass these structures to and from the
3804    * client with a simple assignment or memcpy, so the format
3805    * must be identical to what rpcgen / the RFC defines.
3806    *)
3807
3808   (* Public structures. *)
3809   List.iter (
3810     fun (typ, cols) ->
3811       pr "struct guestfs_%s {\n" typ;
3812       List.iter (
3813         function
3814         | name, FChar -> pr "  char %s;\n" name
3815         | name, FString -> pr "  char *%s;\n" name
3816         | name, FBuffer ->
3817             pr "  uint32_t %s_len;\n" name;
3818             pr "  char *%s;\n" name
3819         | name, FUUID -> pr "  char %s[32]; /* this is NOT nul-terminated, be careful when printing */\n" name
3820         | name, FUInt32 -> pr "  uint32_t %s;\n" name
3821         | name, FInt32 -> pr "  int32_t %s;\n" name
3822         | name, (FUInt64|FBytes) -> pr "  uint64_t %s;\n" name
3823         | name, FInt64 -> pr "  int64_t %s;\n" name
3824         | name, FOptPercent -> pr "  float %s; /* [0..100] or -1 */\n" name
3825       ) cols;
3826       pr "};\n";
3827       pr "\n";
3828       pr "struct guestfs_%s_list {\n" typ;
3829       pr "  uint32_t len;\n";
3830       pr "  struct guestfs_%s *val;\n" typ;
3831       pr "};\n";
3832       pr "\n";
3833       pr "extern void guestfs_free_%s (struct guestfs_%s *);\n" typ typ;
3834       pr "extern void guestfs_free_%s_list (struct guestfs_%s_list *);\n" typ typ;
3835       pr "\n"
3836   ) structs
3837
3838 (* Generate the guestfs-actions.h file. *)
3839 and generate_actions_h () =
3840   generate_header CStyle LGPLv2;
3841   List.iter (
3842     fun (shortname, style, _, _, _, _, _) ->
3843       let name = "guestfs_" ^ shortname in
3844       generate_prototype ~single_line:true ~newline:true ~handle:"handle"
3845         name style
3846   ) all_functions
3847
3848 (* Generate the client-side dispatch stubs. *)
3849 and generate_client_actions () =
3850   generate_header CStyle LGPLv2;
3851
3852   pr "\
3853 #include <stdio.h>
3854 #include <stdlib.h>
3855
3856 #include \"guestfs.h\"
3857 #include \"guestfs_protocol.h\"
3858
3859 #define error guestfs_error
3860 #define perrorf guestfs_perrorf
3861 #define safe_malloc guestfs_safe_malloc
3862 #define safe_realloc guestfs_safe_realloc
3863 #define safe_strdup guestfs_safe_strdup
3864 #define safe_memdup guestfs_safe_memdup
3865
3866 /* Check the return message from a call for validity. */
3867 static int
3868 check_reply_header (guestfs_h *g,
3869                     const struct guestfs_message_header *hdr,
3870                     int proc_nr, int serial)
3871 {
3872   if (hdr->prog != GUESTFS_PROGRAM) {
3873     error (g, \"wrong program (%%d/%%d)\", hdr->prog, GUESTFS_PROGRAM);
3874     return -1;
3875   }
3876   if (hdr->vers != GUESTFS_PROTOCOL_VERSION) {
3877     error (g, \"wrong protocol version (%%d/%%d)\",
3878            hdr->vers, GUESTFS_PROTOCOL_VERSION);
3879     return -1;
3880   }
3881   if (hdr->direction != GUESTFS_DIRECTION_REPLY) {
3882     error (g, \"unexpected message direction (%%d/%%d)\",
3883            hdr->direction, GUESTFS_DIRECTION_REPLY);
3884     return -1;
3885   }
3886   if (hdr->proc != proc_nr) {
3887     error (g, \"unexpected procedure number (%%d/%%d)\", hdr->proc, proc_nr);
3888     return -1;
3889   }
3890   if (hdr->serial != serial) {
3891     error (g, \"unexpected serial (%%d/%%d)\", hdr->serial, serial);
3892     return -1;
3893   }
3894
3895   return 0;
3896 }
3897
3898 /* Check we are in the right state to run a high-level action. */
3899 static int
3900 check_state (guestfs_h *g, const char *caller)
3901 {
3902   if (!guestfs_is_ready (g)) {
3903     if (guestfs_is_config (g))
3904       error (g, \"%%s: call launch before using this function\\n(in guestfish, don't forget to use the 'run' command)\",
3905         caller);
3906     else if (guestfs_is_launching (g))
3907       error (g, \"%%s: call wait_ready() before using this function\",
3908         caller);
3909     else
3910       error (g, \"%%s called from the wrong state, %%d != READY\",
3911         caller, guestfs_get_state (g));
3912     return -1;
3913   }
3914   return 0;
3915 }
3916
3917 ";
3918
3919   (* Client-side stubs for each function. *)
3920   List.iter (
3921     fun (shortname, style, _, _, _, _, _) ->
3922       let name = "guestfs_" ^ shortname in
3923
3924       (* Generate the context struct which stores the high-level
3925        * state between callback functions.
3926        *)
3927       pr "struct %s_ctx {\n" shortname;
3928       pr "  /* This flag is set by the callbacks, so we know we've done\n";
3929       pr "   * the callbacks as expected, and in the right sequence.\n";
3930       pr "   * 0 = not called, 1 = reply_cb called.\n";
3931       pr "   */\n";
3932       pr "  int cb_sequence;\n";
3933       pr "  struct guestfs_message_header hdr;\n";
3934       pr "  struct guestfs_message_error err;\n";
3935       (match fst style with
3936        | RErr -> ()
3937        | RConstString _ ->
3938            failwithf "RConstString cannot be returned from a daemon function"
3939        | RInt _ | RInt64 _
3940        | RBool _ | RString _ | RStringList _
3941        | RStruct _ | RStructList _
3942        | RHashtable _ ->
3943            pr "  struct %s_ret ret;\n" name
3944       );
3945       pr "};\n";
3946       pr "\n";
3947
3948       (* Generate the reply callback function. *)
3949       pr "static void %s_reply_cb (guestfs_h *g, void *data, XDR *xdr)\n" shortname;
3950       pr "{\n";
3951       pr "  guestfs_main_loop *ml = guestfs_get_main_loop (g);\n";
3952       pr "  struct %s_ctx *ctx = (struct %s_ctx *) data;\n" shortname shortname;
3953       pr "\n";
3954       pr "  /* This should definitely not happen. */\n";
3955       pr "  if (ctx->cb_sequence != 0) {\n";
3956       pr "    ctx->cb_sequence = 9999;\n";
3957       pr "    error (g, \"%%s: internal error: reply callback called twice\", \"%s\");\n" name;
3958       pr "    return;\n";
3959       pr "  }\n";
3960       pr "\n";
3961       pr "  ml->main_loop_quit (ml, g);\n";
3962       pr "\n";
3963       pr "  if (!xdr_guestfs_message_header (xdr, &ctx->hdr)) {\n";
3964       pr "    error (g, \"%%s: failed to parse reply header\", \"%s\");\n" name;
3965       pr "    return;\n";
3966       pr "  }\n";
3967       pr "  if (ctx->hdr.status == GUESTFS_STATUS_ERROR) {\n";
3968       pr "    if (!xdr_guestfs_message_error (xdr, &ctx->err)) {\n";
3969       pr "      error (g, \"%%s: failed to parse reply error\", \"%s\");\n"
3970         name;
3971       pr "      return;\n";
3972       pr "    }\n";
3973       pr "    goto done;\n";
3974       pr "  }\n";
3975
3976       (match fst style with
3977        | RErr -> ()
3978        | RConstString _ ->
3979            failwithf "RConstString cannot be returned from a daemon function"
3980        | RInt _ | RInt64 _
3981        | RBool _ | RString _ | RStringList _
3982        | RStruct _ | RStructList _
3983        | RHashtable _ ->
3984            pr "  if (!xdr_%s_ret (xdr, &ctx->ret)) {\n" name;
3985            pr "    error (g, \"%%s: failed to parse reply\", \"%s\");\n" name;
3986            pr "    return;\n";
3987            pr "  }\n";
3988       );
3989
3990       pr " done:\n";
3991       pr "  ctx->cb_sequence = 1;\n";
3992       pr "}\n\n";
3993
3994       (* Generate the action stub. *)
3995       generate_prototype ~extern:false ~semicolon:false ~newline:true
3996         ~handle:"g" name style;
3997
3998       let error_code =
3999         match fst style with
4000         | RErr | RInt _ | RInt64 _ | RBool _ -> "-1"
4001         | RConstString _ ->
4002             failwithf "RConstString cannot be returned from a daemon function"
4003         | RString _ | RStringList _
4004         | RStruct _ | RStructList _
4005         | RHashtable _ ->
4006             "NULL" in
4007
4008       pr "{\n";
4009
4010       (match snd style with
4011        | [] -> ()
4012        | _ -> pr "  struct %s_args args;\n" name
4013       );
4014
4015       pr "  struct %s_ctx ctx;\n" shortname;
4016       pr "  guestfs_main_loop *ml = guestfs_get_main_loop (g);\n";
4017       pr "  int serial;\n";
4018       pr "\n";
4019       pr "  if (check_state (g, \"%s\") == -1) return %s;\n" name error_code;
4020       pr "  guestfs_set_busy (g);\n";
4021       pr "\n";
4022       pr "  memset (&ctx, 0, sizeof ctx);\n";
4023       pr "\n";
4024
4025       (* Send the main header and arguments. *)
4026       (match snd style with
4027        | [] ->
4028            pr "  serial = guestfs__send_sync (g, GUESTFS_PROC_%s, NULL, NULL);\n"
4029              (String.uppercase shortname)
4030        | args ->
4031            List.iter (
4032              function
4033              | String n ->
4034                  pr "  args.%s = (char *) %s;\n" n n
4035              | OptString n ->
4036                  pr "  args.%s = %s ? (char **) &%s : NULL;\n" n n n
4037              | StringList n ->
4038                  pr "  args.%s.%s_val = (char **) %s;\n" n n n;
4039                  pr "  for (args.%s.%s_len = 0; %s[args.%s.%s_len]; args.%s.%s_len++) ;\n" n n n n n n n;
4040              | Bool n ->
4041                  pr "  args.%s = %s;\n" n n
4042              | Int n ->
4043                  pr "  args.%s = %s;\n" n n
4044              | FileIn _ | FileOut _ -> ()
4045            ) args;
4046            pr "  serial = guestfs__send_sync (g, GUESTFS_PROC_%s,\n"
4047              (String.uppercase shortname);
4048            pr "        (xdrproc_t) xdr_%s_args, (char *) &args);\n"
4049              name;
4050       );
4051       pr "  if (serial == -1) {\n";
4052       pr "    guestfs_end_busy (g);\n";
4053       pr "    return %s;\n" error_code;
4054       pr "  }\n";
4055       pr "\n";
4056
4057       (* Send any additional files (FileIn) requested. *)
4058       let need_read_reply_label = ref false in
4059       List.iter (
4060         function
4061         | FileIn n ->
4062             pr "  {\n";
4063             pr "    int r;\n";
4064             pr "\n";
4065             pr "    r = guestfs__send_file_sync (g, %s);\n" n;
4066             pr "    if (r == -1) {\n";
4067             pr "      guestfs_end_busy (g);\n";
4068             pr "      return %s;\n" error_code;
4069             pr "    }\n";
4070             pr "    if (r == -2) /* daemon cancelled */\n";
4071             pr "      goto read_reply;\n";
4072             need_read_reply_label := true;
4073             pr "  }\n";
4074             pr "\n";
4075         | _ -> ()
4076       ) (snd style);
4077
4078       (* Wait for the reply from the remote end. *)
4079       if !need_read_reply_label then pr " read_reply:\n";
4080       pr "  guestfs__switch_to_receiving (g);\n";
4081       pr "  ctx.cb_sequence = 0;\n";
4082       pr "  guestfs_set_reply_callback (g, %s_reply_cb, &ctx);\n" shortname;
4083       pr "  (void) ml->main_loop_run (ml, g);\n";
4084       pr "  guestfs_set_reply_callback (g, NULL, NULL);\n";
4085       pr "  if (ctx.cb_sequence != 1) {\n";
4086       pr "    error (g, \"%%s reply failed, see earlier error messages\", \"%s\");\n" name;
4087       pr "    guestfs_end_busy (g);\n";
4088       pr "    return %s;\n" error_code;
4089       pr "  }\n";
4090       pr "\n";
4091
4092       pr "  if (check_reply_header (g, &ctx.hdr, GUESTFS_PROC_%s, serial) == -1) {\n"
4093         (String.uppercase shortname);
4094       pr "    guestfs_end_busy (g);\n";
4095       pr "    return %s;\n" error_code;
4096       pr "  }\n";
4097       pr "\n";
4098
4099       pr "  if (ctx.hdr.status == GUESTFS_STATUS_ERROR) {\n";
4100       pr "    error (g, \"%%s\", ctx.err.error_message);\n";
4101       pr "    free (ctx.err.error_message);\n";
4102       pr "    guestfs_end_busy (g);\n";
4103       pr "    return %s;\n" error_code;
4104       pr "  }\n";
4105       pr "\n";
4106
4107       (* Expecting to receive further files (FileOut)? *)
4108       List.iter (
4109         function
4110         | FileOut n ->
4111             pr "  if (guestfs__receive_file_sync (g, %s) == -1) {\n" n;
4112             pr "    guestfs_end_busy (g);\n";
4113             pr "    return %s;\n" error_code;
4114             pr "  }\n";
4115             pr "\n";
4116         | _ -> ()
4117       ) (snd style);
4118
4119       pr "  guestfs_end_busy (g);\n";
4120
4121       (match fst style with
4122        | RErr -> pr "  return 0;\n"
4123        | RInt n | RInt64 n | RBool n ->
4124            pr "  return ctx.ret.%s;\n" n
4125        | RConstString _ ->
4126            failwithf "RConstString cannot be returned from a daemon function"
4127        | RString n ->
4128            pr "  return ctx.ret.%s; /* caller will free */\n" n
4129        | RStringList n | RHashtable n ->
4130            pr "  /* caller will free this, but we need to add a NULL entry */\n";
4131            pr "  ctx.ret.%s.%s_val =\n" n n;
4132            pr "    safe_realloc (g, ctx.ret.%s.%s_val,\n" n n;
4133            pr "                  sizeof (char *) * (ctx.ret.%s.%s_len + 1));\n"
4134              n n;
4135            pr "  ctx.ret.%s.%s_val[ctx.ret.%s.%s_len] = NULL;\n" n n n n;
4136            pr "  return ctx.ret.%s.%s_val;\n" n n
4137        | RStruct (n, _) ->
4138            pr "  /* caller will free this */\n";
4139            pr "  return safe_memdup (g, &ctx.ret.%s, sizeof (ctx.ret.%s));\n" n n
4140        | RStructList (n, _) ->
4141            pr "  /* caller will free this */\n";
4142            pr "  return safe_memdup (g, &ctx.ret.%s, sizeof (ctx.ret.%s));\n" n n
4143       );
4144
4145       pr "}\n\n"
4146   ) daemon_functions;
4147
4148   (* Functions to free structures. *)
4149   pr "/* Structure-freeing functions.  These rely on the fact that the\n";
4150   pr " * structure format is identical to the XDR format.  See note in\n";
4151   pr " * generator.ml.\n";
4152   pr " */\n";
4153   pr "\n";
4154
4155   List.iter (
4156     fun (typ, _) ->
4157       pr "void\n";
4158       pr "guestfs_free_%s (struct guestfs_%s *x)\n" typ typ;
4159       pr "{\n";
4160       pr "  xdr_free ((xdrproc_t) xdr_guestfs_int_%s, (char *) x);\n" typ;
4161       pr "  free (x);\n";
4162       pr "}\n";
4163       pr "\n";
4164
4165       pr "void\n";
4166       pr "guestfs_free_%s_list (struct guestfs_%s_list *x)\n" typ typ;
4167       pr "{\n";
4168       pr "  xdr_free ((xdrproc_t) xdr_guestfs_int_%s_list, (char *) x);\n" typ;
4169       pr "  free (x);\n";
4170       pr "}\n";
4171       pr "\n";
4172
4173   ) structs;
4174
4175 (* Generate daemon/actions.h. *)
4176 and generate_daemon_actions_h () =
4177   generate_header CStyle GPLv2;
4178
4179   pr "#include \"../src/guestfs_protocol.h\"\n";
4180   pr "\n";
4181
4182   List.iter (
4183     fun (name, style, _, _, _, _, _) ->
4184       generate_prototype
4185         ~single_line:true ~newline:true ~in_daemon:true ~prefix:"do_"
4186         name style;
4187   ) daemon_functions
4188
4189 (* Generate the server-side stubs. *)
4190 and generate_daemon_actions () =
4191   generate_header CStyle GPLv2;
4192
4193   pr "#include <config.h>\n";
4194   pr "\n";
4195   pr "#include <stdio.h>\n";
4196   pr "#include <stdlib.h>\n";
4197   pr "#include <string.h>\n";
4198   pr "#include <inttypes.h>\n";
4199   pr "#include <ctype.h>\n";
4200   pr "#include <rpc/types.h>\n";
4201   pr "#include <rpc/xdr.h>\n";
4202   pr "\n";
4203   pr "#include \"daemon.h\"\n";
4204   pr "#include \"../src/guestfs_protocol.h\"\n";
4205   pr "#include \"actions.h\"\n";
4206   pr "\n";
4207
4208   List.iter (
4209     fun (name, style, _, _, _, _, _) ->
4210       (* Generate server-side stubs. *)
4211       pr "static void %s_stub (XDR *xdr_in)\n" name;
4212       pr "{\n";
4213       let error_code =
4214         match fst style with
4215         | RErr | RInt _ -> pr "  int r;\n"; "-1"
4216         | RInt64 _ -> pr "  int64_t r;\n"; "-1"
4217         | RBool _ -> pr "  int r;\n"; "-1"
4218         | RConstString _ ->
4219             failwithf "RConstString cannot be returned from a daemon function"
4220         | RString _ -> pr "  char *r;\n"; "NULL"
4221         | RStringList _ | RHashtable _ -> pr "  char **r;\n"; "NULL"
4222         | RStruct (_, typ) -> pr "  guestfs_int_%s *r;\n" typ; "NULL"
4223         | RStructList (_, typ) -> pr "  guestfs_int_%s_list *r;\n" typ; "NULL" in
4224
4225       (match snd style with
4226        | [] -> ()
4227        | args ->
4228            pr "  struct guestfs_%s_args args;\n" name;
4229            List.iter (
4230              function
4231                (* Note we allow the string to be writable, in order to
4232                 * allow device name translation.  This is safe because
4233                 * we can modify the string (passed from RPC).
4234                 *)
4235              | String n
4236              | OptString n -> pr "  char *%s;\n" n
4237              | StringList n -> pr "  char **%s;\n" n
4238              | Bool n -> pr "  int %s;\n" n
4239              | Int n -> pr "  int %s;\n" n
4240              | FileIn _ | FileOut _ -> ()
4241            ) args
4242       );
4243       pr "\n";
4244
4245       (match snd style with
4246        | [] -> ()
4247        | args ->
4248            pr "  memset (&args, 0, sizeof args);\n";
4249            pr "\n";
4250            pr "  if (!xdr_guestfs_%s_args (xdr_in, &args)) {\n" name;
4251            pr "    reply_with_error (\"%%s: daemon failed to decode procedure arguments\", \"%s\");\n" name;
4252            pr "    return;\n";
4253            pr "  }\n";
4254            List.iter (
4255              function
4256              | String n -> pr "  %s = args.%s;\n" n n
4257              | OptString n -> pr "  %s = args.%s ? *args.%s : NULL;\n" n n n
4258              | StringList n ->
4259                  pr "  %s = realloc (args.%s.%s_val,\n" n n n;
4260                  pr "                sizeof (char *) * (args.%s.%s_len+1));\n" n n;
4261                  pr "  if (%s == NULL) {\n" n;
4262                  pr "    reply_with_perror (\"realloc\");\n";
4263                  pr "    goto done;\n";
4264                  pr "  }\n";
4265                  pr "  %s[args.%s.%s_len] = NULL;\n" n n n;
4266                  pr "  args.%s.%s_val = %s;\n" n n n;
4267              | Bool n -> pr "  %s = args.%s;\n" n n
4268              | Int n -> pr "  %s = args.%s;\n" n n
4269              | FileIn _ | FileOut _ -> ()
4270            ) args;
4271            pr "\n"
4272       );
4273
4274       (* Don't want to call the impl with any FileIn or FileOut
4275        * parameters, since these go "outside" the RPC protocol.
4276        *)
4277       let argsnofile =
4278         List.filter (function FileIn _ | FileOut _ -> false | _ -> true)
4279           (snd style) in
4280       pr "  r = do_%s " name;
4281       generate_call_args argsnofile;
4282       pr ";\n";
4283
4284       pr "  if (r == %s)\n" error_code;
4285       pr "    /* do_%s has already called reply_with_error */\n" name;
4286       pr "    goto done;\n";
4287       pr "\n";
4288
4289       (* If there are any FileOut parameters, then the impl must
4290        * send its own reply.
4291        *)
4292       let no_reply =
4293         List.exists (function FileOut _ -> true | _ -> false) (snd style) in
4294       if no_reply then
4295         pr "  /* do_%s has already sent a reply */\n" name
4296       else (
4297         match fst style with
4298         | RErr -> pr "  reply (NULL, NULL);\n"
4299         | RInt n | RInt64 n | RBool n ->
4300             pr "  struct guestfs_%s_ret ret;\n" name;
4301             pr "  ret.%s = r;\n" n;
4302             pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n"
4303               name
4304         | RConstString _ ->
4305             failwithf "RConstString cannot be returned from a daemon function"
4306         | RString n ->
4307             pr "  struct guestfs_%s_ret ret;\n" name;
4308             pr "  ret.%s = r;\n" n;
4309             pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n"
4310               name;
4311             pr "  free (r);\n"
4312         | RStringList n | RHashtable n ->
4313             pr "  struct guestfs_%s_ret ret;\n" name;
4314             pr "  ret.%s.%s_len = count_strings (r);\n" n n;
4315             pr "  ret.%s.%s_val = r;\n" n n;
4316             pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n"
4317               name;
4318             pr "  free_strings (r);\n"
4319         | RStruct (n, _) ->
4320             pr "  struct guestfs_%s_ret ret;\n" name;
4321             pr "  ret.%s = *r;\n" n;
4322             pr "  reply ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n"
4323               name;
4324             pr "  xdr_free ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n"
4325               name
4326         | RStructList (n, _) ->
4327             pr "  struct guestfs_%s_ret ret;\n" name;
4328             pr "  ret.%s = *r;\n" n;
4329             pr "  reply ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n"
4330               name;
4331             pr "  xdr_free ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n"
4332               name
4333       );
4334
4335       (* Free the args. *)
4336       (match snd style with
4337        | [] ->
4338            pr "done: ;\n";
4339        | _ ->
4340            pr "done:\n";
4341            pr "  xdr_free ((xdrproc_t) xdr_guestfs_%s_args, (char *) &args);\n"
4342              name
4343       );
4344
4345       pr "}\n\n";
4346   ) daemon_functions;
4347
4348   (* Dispatch function. *)
4349   pr "void dispatch_incoming_message (XDR *xdr_in)\n";
4350   pr "{\n";
4351   pr "  switch (proc_nr) {\n";
4352
4353   List.iter (
4354     fun (name, style, _, _, _, _, _) ->
4355       pr "    case GUESTFS_PROC_%s:\n" (String.uppercase name);
4356       pr "      %s_stub (xdr_in);\n" name;
4357       pr "      break;\n"
4358   ) daemon_functions;
4359
4360   pr "    default:\n";
4361   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";
4362   pr "  }\n";
4363   pr "}\n";
4364   pr "\n";
4365
4366   (* LVM columns and tokenization functions. *)
4367   (* XXX This generates crap code.  We should rethink how we
4368    * do this parsing.
4369    *)
4370   List.iter (
4371     function
4372     | typ, cols ->
4373         pr "static const char *lvm_%s_cols = \"%s\";\n"
4374           typ (String.concat "," (List.map fst cols));
4375         pr "\n";
4376
4377         pr "static int lvm_tokenize_%s (char *str, guestfs_int_lvm_%s *r)\n" typ typ;
4378         pr "{\n";
4379         pr "  char *tok, *p, *next;\n";
4380         pr "  int i, j;\n";
4381         pr "\n";
4382         (*
4383           pr "  fprintf (stderr, \"%%s: <<%%s>>\\n\", __func__, str);\n";
4384           pr "\n";
4385         *)
4386         pr "  if (!str) {\n";
4387         pr "    fprintf (stderr, \"%%s: failed: passed a NULL string\\n\", __func__);\n";
4388         pr "    return -1;\n";
4389         pr "  }\n";
4390         pr "  if (!*str || isspace (*str)) {\n";
4391         pr "    fprintf (stderr, \"%%s: failed: passed a empty string or one beginning with whitespace\\n\", __func__);\n";
4392         pr "    return -1;\n";
4393         pr "  }\n";
4394         pr "  tok = str;\n";
4395         List.iter (
4396           fun (name, coltype) ->
4397             pr "  if (!tok) {\n";
4398             pr "    fprintf (stderr, \"%%s: failed: string finished early, around token %%s\\n\", __func__, \"%s\");\n" name;
4399             pr "    return -1;\n";
4400             pr "  }\n";
4401             pr "  p = strchrnul (tok, ',');\n";
4402             pr "  if (*p) next = p+1; else next = NULL;\n";
4403             pr "  *p = '\\0';\n";
4404             (match coltype with
4405              | FString ->
4406                  pr "  r->%s = strdup (tok);\n" name;
4407                  pr "  if (r->%s == NULL) {\n" name;
4408                  pr "    perror (\"strdup\");\n";
4409                  pr "    return -1;\n";
4410                  pr "  }\n"
4411              | FUUID ->
4412                  pr "  for (i = j = 0; i < 32; ++j) {\n";
4413                  pr "    if (tok[j] == '\\0') {\n";
4414                  pr "      fprintf (stderr, \"%%s: failed to parse UUID from '%%s'\\n\", __func__, tok);\n";
4415                  pr "      return -1;\n";
4416                  pr "    } else if (tok[j] != '-')\n";
4417                  pr "      r->%s[i++] = tok[j];\n" name;
4418                  pr "  }\n";
4419              | FBytes ->
4420                  pr "  if (sscanf (tok, \"%%\"SCNu64, &r->%s) != 1) {\n" name;
4421                  pr "    fprintf (stderr, \"%%s: failed to parse size '%%s' from token %%s\\n\", __func__, tok, \"%s\");\n" name;
4422                  pr "    return -1;\n";
4423                  pr "  }\n";
4424              | FInt64 ->
4425                  pr "  if (sscanf (tok, \"%%\"SCNi64, &r->%s) != 1) {\n" name;
4426                  pr "    fprintf (stderr, \"%%s: failed to parse int '%%s' from token %%s\\n\", __func__, tok, \"%s\");\n" name;
4427                  pr "    return -1;\n";
4428                  pr "  }\n";
4429              | FOptPercent ->
4430                  pr "  if (tok[0] == '\\0')\n";
4431                  pr "    r->%s = -1;\n" name;
4432                  pr "  else if (sscanf (tok, \"%%f\", &r->%s) != 1) {\n" name;
4433                  pr "    fprintf (stderr, \"%%s: failed to parse float '%%s' from token %%s\\n\", __func__, tok, \"%s\");\n" name;
4434                  pr "    return -1;\n";
4435                  pr "  }\n";
4436              | FBuffer | FInt32 | FUInt32 | FUInt64 | FChar ->
4437                  assert false (* can never be an LVM column *)
4438             );
4439             pr "  tok = next;\n";
4440         ) cols;
4441
4442         pr "  if (tok != NULL) {\n";
4443         pr "    fprintf (stderr, \"%%s: failed: extra tokens at end of string\\n\", __func__);\n";
4444         pr "    return -1;\n";
4445         pr "  }\n";
4446         pr "  return 0;\n";
4447         pr "}\n";
4448         pr "\n";
4449
4450         pr "guestfs_int_lvm_%s_list *\n" typ;
4451         pr "parse_command_line_%ss (void)\n" typ;
4452         pr "{\n";
4453         pr "  char *out, *err;\n";
4454         pr "  char *p, *pend;\n";
4455         pr "  int r, i;\n";
4456         pr "  guestfs_int_lvm_%s_list *ret;\n" typ;
4457         pr "  void *newp;\n";
4458         pr "\n";
4459         pr "  ret = malloc (sizeof *ret);\n";
4460         pr "  if (!ret) {\n";
4461         pr "    reply_with_perror (\"malloc\");\n";
4462         pr "    return NULL;\n";
4463         pr "  }\n";
4464         pr "\n";
4465         pr "  ret->guestfs_int_lvm_%s_list_len = 0;\n" typ;
4466         pr "  ret->guestfs_int_lvm_%s_list_val = NULL;\n" typ;
4467         pr "\n";
4468         pr "  r = command (&out, &err,\n";
4469         pr "           \"/sbin/lvm\", \"%ss\",\n" typ;
4470         pr "           \"-o\", lvm_%s_cols, \"--unbuffered\", \"--noheadings\",\n" typ;
4471         pr "           \"--nosuffix\", \"--separator\", \",\", \"--units\", \"b\", NULL);\n";
4472         pr "  if (r == -1) {\n";
4473         pr "    reply_with_error (\"%%s\", err);\n";
4474         pr "    free (out);\n";
4475         pr "    free (err);\n";
4476         pr "    free (ret);\n";
4477         pr "    return NULL;\n";
4478         pr "  }\n";
4479         pr "\n";
4480         pr "  free (err);\n";
4481         pr "\n";
4482         pr "  /* Tokenize each line of the output. */\n";
4483         pr "  p = out;\n";
4484         pr "  i = 0;\n";
4485         pr "  while (p) {\n";
4486         pr "    pend = strchr (p, '\\n');       /* Get the next line of output. */\n";
4487         pr "    if (pend) {\n";
4488         pr "      *pend = '\\0';\n";
4489         pr "      pend++;\n";
4490         pr "    }\n";
4491         pr "\n";
4492         pr "    while (*p && isspace (*p))      /* Skip any leading whitespace. */\n";
4493         pr "      p++;\n";
4494         pr "\n";
4495         pr "    if (!*p) {                      /* Empty line?  Skip it. */\n";
4496         pr "      p = pend;\n";
4497         pr "      continue;\n";
4498         pr "    }\n";
4499         pr "\n";
4500         pr "    /* Allocate some space to store this next entry. */\n";
4501         pr "    newp = realloc (ret->guestfs_int_lvm_%s_list_val,\n" typ;
4502         pr "                sizeof (guestfs_int_lvm_%s) * (i+1));\n" typ;
4503         pr "    if (newp == NULL) {\n";
4504         pr "      reply_with_perror (\"realloc\");\n";
4505         pr "      free (ret->guestfs_int_lvm_%s_list_val);\n" typ;
4506         pr "      free (ret);\n";
4507         pr "      free (out);\n";
4508         pr "      return NULL;\n";
4509         pr "    }\n";
4510         pr "    ret->guestfs_int_lvm_%s_list_val = newp;\n" typ;
4511         pr "\n";
4512         pr "    /* Tokenize the next entry. */\n";
4513         pr "    r = lvm_tokenize_%s (p, &ret->guestfs_int_lvm_%s_list_val[i]);\n" typ typ;
4514         pr "    if (r == -1) {\n";
4515         pr "      reply_with_error (\"failed to parse output of '%ss' command\");\n" typ;
4516         pr "      free (ret->guestfs_int_lvm_%s_list_val);\n" typ;
4517         pr "      free (ret);\n";
4518         pr "      free (out);\n";
4519         pr "      return NULL;\n";
4520         pr "    }\n";
4521         pr "\n";
4522         pr "    ++i;\n";
4523         pr "    p = pend;\n";
4524         pr "  }\n";
4525         pr "\n";
4526         pr "  ret->guestfs_int_lvm_%s_list_len = i;\n" typ;
4527         pr "\n";
4528         pr "  free (out);\n";
4529         pr "  return ret;\n";
4530         pr "}\n"
4531
4532   ) ["pv", lvm_pv_cols; "vg", lvm_vg_cols; "lv", lvm_lv_cols]
4533
4534 (* Generate a list of function names, for debugging in the daemon.. *)
4535 and generate_daemon_names () =
4536   generate_header CStyle GPLv2;
4537
4538   pr "#include <config.h>\n";
4539   pr "\n";
4540   pr "#include \"daemon.h\"\n";
4541   pr "\n";
4542
4543   pr "/* This array is indexed by proc_nr.  See guestfs_protocol.x. */\n";
4544   pr "const char *function_names[] = {\n";
4545   List.iter (
4546     fun (name, _, proc_nr, _, _, _, _) -> pr "  [%d] = \"%s\",\n" proc_nr name
4547   ) daemon_functions;
4548   pr "};\n";
4549
4550 (* Generate the tests. *)
4551 and generate_tests () =
4552   generate_header CStyle GPLv2;
4553
4554   pr "\
4555 #include <stdio.h>
4556 #include <stdlib.h>
4557 #include <string.h>
4558 #include <unistd.h>
4559 #include <sys/types.h>
4560 #include <fcntl.h>
4561
4562 #include \"guestfs.h\"
4563
4564 static guestfs_h *g;
4565 static int suppress_error = 0;
4566
4567 static void print_error (guestfs_h *g, void *data, const char *msg)
4568 {
4569   if (!suppress_error)
4570     fprintf (stderr, \"%%s\\n\", msg);
4571 }
4572
4573 static void print_strings (char * const * const argv)
4574 {
4575   int argc;
4576
4577   for (argc = 0; argv[argc] != NULL; ++argc)
4578     printf (\"\\t%%s\\n\", argv[argc]);
4579 }
4580
4581 /*
4582 static void print_table (char * const * const argv)
4583 {
4584   int i;
4585
4586   for (i = 0; argv[i] != NULL; i += 2)
4587     printf (\"%%s: %%s\\n\", argv[i], argv[i+1]);
4588 }
4589 */
4590
4591 static void no_test_warnings (void)
4592 {
4593 ";
4594
4595   List.iter (
4596     function
4597     | name, _, _, _, [], _, _ ->
4598         pr "  fprintf (stderr, \"warning: \\\"guestfs_%s\\\" has no tests\\n\");\n" name
4599     | name, _, _, _, tests, _, _ -> ()
4600   ) all_functions;
4601
4602   pr "}\n";
4603   pr "\n";
4604
4605   (* Generate the actual tests.  Note that we generate the tests
4606    * in reverse order, deliberately, so that (in general) the
4607    * newest tests run first.  This makes it quicker and easier to
4608    * debug them.
4609    *)
4610   let test_names =
4611     List.map (
4612       fun (name, _, _, _, tests, _, _) ->
4613         mapi (generate_one_test name) tests
4614     ) (List.rev all_functions) in
4615   let test_names = List.concat test_names in
4616   let nr_tests = List.length test_names in
4617
4618   pr "\
4619 int main (int argc, char *argv[])
4620 {
4621   char c = 0;
4622   int failed = 0;
4623   const char *filename;
4624   int fd;
4625   int nr_tests, test_num = 0;
4626
4627   setbuf (stdout, NULL);
4628
4629   no_test_warnings ();
4630
4631   g = guestfs_create ();
4632   if (g == NULL) {
4633     printf (\"guestfs_create FAILED\\n\");
4634     exit (1);
4635   }
4636
4637   guestfs_set_error_handler (g, print_error, NULL);
4638
4639   guestfs_set_path (g, \"../appliance\");
4640
4641   filename = \"test1.img\";
4642   fd = open (filename, O_WRONLY|O_CREAT|O_NOCTTY|O_NONBLOCK|O_TRUNC, 0666);
4643   if (fd == -1) {
4644     perror (filename);
4645     exit (1);
4646   }
4647   if (lseek (fd, %d, SEEK_SET) == -1) {
4648     perror (\"lseek\");
4649     close (fd);
4650     unlink (filename);
4651     exit (1);
4652   }
4653   if (write (fd, &c, 1) == -1) {
4654     perror (\"write\");
4655     close (fd);
4656     unlink (filename);
4657     exit (1);
4658   }
4659   if (close (fd) == -1) {
4660     perror (filename);
4661     unlink (filename);
4662     exit (1);
4663   }
4664   if (guestfs_add_drive (g, filename) == -1) {
4665     printf (\"guestfs_add_drive %%s FAILED\\n\", filename);
4666     exit (1);
4667   }
4668
4669   filename = \"test2.img\";
4670   fd = open (filename, O_WRONLY|O_CREAT|O_NOCTTY|O_NONBLOCK|O_TRUNC, 0666);
4671   if (fd == -1) {
4672     perror (filename);
4673     exit (1);
4674   }
4675   if (lseek (fd, %d, SEEK_SET) == -1) {
4676     perror (\"lseek\");
4677     close (fd);
4678     unlink (filename);
4679     exit (1);
4680   }
4681   if (write (fd, &c, 1) == -1) {
4682     perror (\"write\");
4683     close (fd);
4684     unlink (filename);
4685     exit (1);
4686   }
4687   if (close (fd) == -1) {
4688     perror (filename);
4689     unlink (filename);
4690     exit (1);
4691   }
4692   if (guestfs_add_drive (g, filename) == -1) {
4693     printf (\"guestfs_add_drive %%s FAILED\\n\", filename);
4694     exit (1);
4695   }
4696
4697   filename = \"test3.img\";
4698   fd = open (filename, O_WRONLY|O_CREAT|O_NOCTTY|O_NONBLOCK|O_TRUNC, 0666);
4699   if (fd == -1) {
4700     perror (filename);
4701     exit (1);
4702   }
4703   if (lseek (fd, %d, SEEK_SET) == -1) {
4704     perror (\"lseek\");
4705     close (fd);
4706     unlink (filename);
4707     exit (1);
4708   }
4709   if (write (fd, &c, 1) == -1) {
4710     perror (\"write\");
4711     close (fd);
4712     unlink (filename);
4713     exit (1);
4714   }
4715   if (close (fd) == -1) {
4716     perror (filename);
4717     unlink (filename);
4718     exit (1);
4719   }
4720   if (guestfs_add_drive (g, filename) == -1) {
4721     printf (\"guestfs_add_drive %%s FAILED\\n\", filename);
4722     exit (1);
4723   }
4724
4725   if (guestfs_add_drive_ro (g, \"../images/test.sqsh\") == -1) {
4726     printf (\"guestfs_add_drive_ro ../images/test.sqsh FAILED\\n\");
4727     exit (1);
4728   }
4729
4730   if (guestfs_launch (g) == -1) {
4731     printf (\"guestfs_launch FAILED\\n\");
4732     exit (1);
4733   }
4734
4735   /* Set a timeout in case qemu hangs during launch (RHBZ#505329). */
4736   alarm (600);
4737
4738   if (guestfs_wait_ready (g) == -1) {
4739     printf (\"guestfs_wait_ready FAILED\\n\");
4740     exit (1);
4741   }
4742
4743   /* Cancel previous alarm. */
4744   alarm (0);
4745
4746   nr_tests = %d;
4747
4748 " (500 * 1024 * 1024) (50 * 1024 * 1024) (10 * 1024 * 1024) nr_tests;
4749
4750   iteri (
4751     fun i test_name ->
4752       pr "  test_num++;\n";
4753       pr "  printf (\"%%3d/%%3d %s\\n\", test_num, nr_tests);\n" test_name;
4754       pr "  if (%s () == -1) {\n" test_name;
4755       pr "    printf (\"%s FAILED\\n\");\n" test_name;
4756       pr "    failed++;\n";
4757       pr "  }\n";
4758   ) test_names;
4759   pr "\n";
4760
4761   pr "  guestfs_close (g);\n";
4762   pr "  unlink (\"test1.img\");\n";
4763   pr "  unlink (\"test2.img\");\n";
4764   pr "  unlink (\"test3.img\");\n";
4765   pr "\n";
4766
4767   pr "  if (failed > 0) {\n";
4768   pr "    printf (\"***** %%d / %%d tests FAILED *****\\n\", failed, nr_tests);\n";
4769   pr "    exit (1);\n";
4770   pr "  }\n";
4771   pr "\n";
4772
4773   pr "  exit (0);\n";
4774   pr "}\n"
4775
4776 and generate_one_test name i (init, prereq, test) =
4777   let test_name = sprintf "test_%s_%d" name i in
4778
4779   pr "\
4780 static int %s_skip (void)
4781 {
4782   const char *str;
4783
4784   str = getenv (\"TEST_ONLY\");
4785   if (str)
4786     return strstr (str, \"%s\") == NULL;
4787   str = getenv (\"SKIP_%s\");
4788   if (str && strcmp (str, \"1\") == 0) return 1;
4789   str = getenv (\"SKIP_TEST_%s\");
4790   if (str && strcmp (str, \"1\") == 0) return 1;
4791   return 0;
4792 }
4793
4794 " test_name name (String.uppercase test_name) (String.uppercase name);
4795
4796   (match prereq with
4797    | Disabled | Always -> ()
4798    | If code | Unless code ->
4799        pr "static int %s_prereq (void)\n" test_name;
4800        pr "{\n";
4801        pr "  %s\n" code;
4802        pr "}\n";
4803        pr "\n";
4804   );
4805
4806   pr "\
4807 static int %s (void)
4808 {
4809   if (%s_skip ()) {
4810     printf (\"        %%s skipped (reason: environment variable set)\\n\", \"%s\");
4811     return 0;
4812   }
4813
4814 " test_name test_name test_name;
4815
4816   (match prereq with
4817    | Disabled ->
4818        pr "  printf (\"        %%s skipped (reason: test disabled in generator)\\n\", \"%s\");\n" test_name
4819    | If _ ->
4820        pr "  if (! %s_prereq ()) {\n" test_name;
4821        pr "    printf (\"        %%s skipped (reason: test prerequisite)\\n\", \"%s\");\n" test_name;
4822        pr "    return 0;\n";
4823        pr "  }\n";
4824        pr "\n";
4825        generate_one_test_body name i test_name init test;
4826    | Unless _ ->
4827        pr "  if (%s_prereq ()) {\n" test_name;
4828        pr "    printf (\"        %%s skipped (reason: test prerequisite)\\n\", \"%s\");\n" test_name;
4829        pr "    return 0;\n";
4830        pr "  }\n";
4831        pr "\n";
4832        generate_one_test_body name i test_name init test;
4833    | Always ->
4834        generate_one_test_body name i test_name init test
4835   );
4836
4837   pr "  return 0;\n";
4838   pr "}\n";
4839   pr "\n";
4840   test_name
4841
4842 and generate_one_test_body name i test_name init test =
4843   (match init with
4844    | InitNone (* XXX at some point, InitNone and InitEmpty became
4845                * folded together as the same thing.  Really we should
4846                * make InitNone do nothing at all, but the tests may
4847                * need to be checked to make sure this is OK.
4848                *)
4849    | InitEmpty ->
4850        pr "  /* InitNone|InitEmpty for %s */\n" test_name;
4851        List.iter (generate_test_command_call test_name)
4852          [["blockdev_setrw"; "/dev/sda"];
4853           ["umount_all"];
4854           ["lvm_remove_all"]]
4855    | InitBasicFS ->
4856        pr "  /* InitBasicFS for %s: create ext2 on /dev/sda1 */\n" test_name;
4857        List.iter (generate_test_command_call test_name)
4858          [["blockdev_setrw"; "/dev/sda"];
4859           ["umount_all"];
4860           ["lvm_remove_all"];
4861           ["sfdiskM"; "/dev/sda"; ","];
4862           ["mkfs"; "ext2"; "/dev/sda1"];
4863           ["mount"; "/dev/sda1"; "/"]]
4864    | InitBasicFSonLVM ->
4865        pr "  /* InitBasicFSonLVM for %s: create ext2 on /dev/VG/LV */\n"
4866          test_name;
4867        List.iter (generate_test_command_call test_name)
4868          [["blockdev_setrw"; "/dev/sda"];
4869           ["umount_all"];
4870           ["lvm_remove_all"];
4871           ["sfdiskM"; "/dev/sda"; ","];
4872           ["pvcreate"; "/dev/sda1"];
4873           ["vgcreate"; "VG"; "/dev/sda1"];
4874           ["lvcreate"; "LV"; "VG"; "8"];
4875           ["mkfs"; "ext2"; "/dev/VG/LV"];
4876           ["mount"; "/dev/VG/LV"; "/"]]
4877   );
4878
4879   let get_seq_last = function
4880     | [] ->
4881         failwithf "%s: you cannot use [] (empty list) when expecting a command"
4882           test_name
4883     | seq ->
4884         let seq = List.rev seq in
4885         List.rev (List.tl seq), List.hd seq
4886   in
4887
4888   match test with
4889   | TestRun seq ->
4890       pr "  /* TestRun for %s (%d) */\n" name i;
4891       List.iter (generate_test_command_call test_name) seq
4892   | TestOutput (seq, expected) ->
4893       pr "  /* TestOutput for %s (%d) */\n" name i;
4894       pr "  const char *expected = \"%s\";\n" (c_quote expected);
4895       let seq, last = get_seq_last seq in
4896       let test () =
4897         pr "    if (strcmp (r, expected) != 0) {\n";
4898         pr "      fprintf (stderr, \"%s: expected \\\"%%s\\\" but got \\\"%%s\\\"\\n\", expected, r);\n" test_name;
4899         pr "      return -1;\n";
4900         pr "    }\n"
4901       in
4902       List.iter (generate_test_command_call test_name) seq;
4903       generate_test_command_call ~test test_name last
4904   | TestOutputList (seq, expected) ->
4905       pr "  /* TestOutputList for %s (%d) */\n" name i;
4906       let seq, last = get_seq_last seq in
4907       let test () =
4908         iteri (
4909           fun i str ->
4910             pr "    if (!r[%d]) {\n" i;
4911             pr "      fprintf (stderr, \"%s: short list returned from command\\n\");\n" test_name;
4912             pr "      print_strings (r);\n";
4913             pr "      return -1;\n";
4914             pr "    }\n";
4915             pr "    {\n";
4916             pr "      const char *expected = \"%s\";\n" (c_quote str);
4917             pr "      if (strcmp (r[%d], expected) != 0) {\n" i;
4918             pr "        fprintf (stderr, \"%s: expected \\\"%%s\\\" but got \\\"%%s\\\"\\n\", expected, r[%d]);\n" test_name i;
4919             pr "        return -1;\n";
4920             pr "      }\n";
4921             pr "    }\n"
4922         ) expected;
4923         pr "    if (r[%d] != NULL) {\n" (List.length expected);
4924         pr "      fprintf (stderr, \"%s: extra elements returned from command\\n\");\n"
4925           test_name;
4926         pr "      print_strings (r);\n";
4927         pr "      return -1;\n";
4928         pr "    }\n"
4929       in
4930       List.iter (generate_test_command_call test_name) seq;
4931       generate_test_command_call ~test test_name last
4932   | TestOutputListOfDevices (seq, expected) ->
4933       pr "  /* TestOutputListOfDevices for %s (%d) */\n" name i;
4934       let seq, last = get_seq_last seq in
4935       let test () =
4936         iteri (
4937           fun i str ->
4938             pr "    if (!r[%d]) {\n" i;
4939             pr "      fprintf (stderr, \"%s: short list returned from command\\n\");\n" test_name;
4940             pr "      print_strings (r);\n";
4941             pr "      return -1;\n";
4942             pr "    }\n";
4943             pr "    {\n";
4944             pr "      const char *expected = \"%s\";\n" (c_quote str);
4945             pr "      r[%d][5] = 's';\n" i;
4946             pr "      if (strcmp (r[%d], expected) != 0) {\n" i;
4947             pr "        fprintf (stderr, \"%s: expected \\\"%%s\\\" but got \\\"%%s\\\"\\n\", expected, r[%d]);\n" test_name i;
4948             pr "        return -1;\n";
4949             pr "      }\n";
4950             pr "    }\n"
4951         ) expected;
4952         pr "    if (r[%d] != NULL) {\n" (List.length expected);
4953         pr "      fprintf (stderr, \"%s: extra elements returned from command\\n\");\n"
4954           test_name;
4955         pr "      print_strings (r);\n";
4956         pr "      return -1;\n";
4957         pr "    }\n"
4958       in
4959       List.iter (generate_test_command_call test_name) seq;
4960       generate_test_command_call ~test test_name last
4961   | TestOutputInt (seq, expected) ->
4962       pr "  /* TestOutputInt for %s (%d) */\n" name i;
4963       let seq, last = get_seq_last seq in
4964       let test () =
4965         pr "    if (r != %d) {\n" expected;
4966         pr "      fprintf (stderr, \"%s: expected %d but got %%d\\n\","
4967           test_name expected;
4968         pr "               (int) r);\n";
4969         pr "      return -1;\n";
4970         pr "    }\n"
4971       in
4972       List.iter (generate_test_command_call test_name) seq;
4973       generate_test_command_call ~test test_name last
4974   | TestOutputIntOp (seq, op, expected) ->
4975       pr "  /* TestOutputIntOp for %s (%d) */\n" name i;
4976       let seq, last = get_seq_last seq in
4977       let test () =
4978         pr "    if (! (r %s %d)) {\n" op expected;
4979         pr "      fprintf (stderr, \"%s: expected %s %d but got %%d\\n\","
4980           test_name op expected;
4981         pr "               (int) r);\n";
4982         pr "      return -1;\n";
4983         pr "    }\n"
4984       in
4985       List.iter (generate_test_command_call test_name) seq;
4986       generate_test_command_call ~test test_name last
4987   | TestOutputTrue seq ->
4988       pr "  /* TestOutputTrue for %s (%d) */\n" name i;
4989       let seq, last = get_seq_last seq in
4990       let test () =
4991         pr "    if (!r) {\n";
4992         pr "      fprintf (stderr, \"%s: expected true, got false\\n\");\n"
4993           test_name;
4994         pr "      return -1;\n";
4995         pr "    }\n"
4996       in
4997       List.iter (generate_test_command_call test_name) seq;
4998       generate_test_command_call ~test test_name last
4999   | TestOutputFalse seq ->
5000       pr "  /* TestOutputFalse for %s (%d) */\n" name i;
5001       let seq, last = get_seq_last seq in
5002       let test () =
5003         pr "    if (r) {\n";
5004         pr "      fprintf (stderr, \"%s: expected false, got true\\n\");\n"
5005           test_name;
5006         pr "      return -1;\n";
5007         pr "    }\n"
5008       in
5009       List.iter (generate_test_command_call test_name) seq;
5010       generate_test_command_call ~test test_name last
5011   | TestOutputLength (seq, expected) ->
5012       pr "  /* TestOutputLength for %s (%d) */\n" name i;
5013       let seq, last = get_seq_last seq in
5014       let test () =
5015         pr "    int j;\n";
5016         pr "    for (j = 0; j < %d; ++j)\n" expected;
5017         pr "      if (r[j] == NULL) {\n";
5018         pr "        fprintf (stderr, \"%s: short list returned\\n\");\n"
5019           test_name;
5020         pr "        print_strings (r);\n";
5021         pr "        return -1;\n";
5022         pr "      }\n";
5023         pr "    if (r[j] != NULL) {\n";
5024         pr "      fprintf (stderr, \"%s: long list returned\\n\");\n"
5025           test_name;
5026         pr "      print_strings (r);\n";
5027         pr "      return -1;\n";
5028         pr "    }\n"
5029       in
5030       List.iter (generate_test_command_call test_name) seq;
5031       generate_test_command_call ~test test_name last
5032   | TestOutputStruct (seq, checks) ->
5033       pr "  /* TestOutputStruct for %s (%d) */\n" name i;
5034       let seq, last = get_seq_last seq in
5035       let test () =
5036         List.iter (
5037           function
5038           | CompareWithInt (field, expected) ->
5039               pr "    if (r->%s != %d) {\n" field expected;
5040               pr "      fprintf (stderr, \"%s: %s was %%d, expected %d\\n\",\n"
5041                 test_name field expected;
5042               pr "               (int) r->%s);\n" field;
5043               pr "      return -1;\n";
5044               pr "    }\n"
5045           | CompareWithIntOp (field, op, expected) ->
5046               pr "    if (!(r->%s %s %d)) {\n" field op expected;
5047               pr "      fprintf (stderr, \"%s: %s was %%d, expected %s %d\\n\",\n"
5048                 test_name field op expected;
5049               pr "               (int) r->%s);\n" field;
5050               pr "      return -1;\n";
5051               pr "    }\n"
5052           | CompareWithString (field, expected) ->
5053               pr "    if (strcmp (r->%s, \"%s\") != 0) {\n" field expected;
5054               pr "      fprintf (stderr, \"%s: %s was \"%%s\", expected \"%s\"\\n\",\n"
5055                 test_name field expected;
5056               pr "               r->%s);\n" field;
5057               pr "      return -1;\n";
5058               pr "    }\n"
5059           | CompareFieldsIntEq (field1, field2) ->
5060               pr "    if (r->%s != r->%s) {\n" field1 field2;
5061               pr "      fprintf (stderr, \"%s: %s (%%d) <> %s (%%d)\\n\",\n"
5062                 test_name field1 field2;
5063               pr "               (int) r->%s, (int) r->%s);\n" field1 field2;
5064               pr "      return -1;\n";
5065               pr "    }\n"
5066           | CompareFieldsStrEq (field1, field2) ->
5067               pr "    if (strcmp (r->%s, r->%s) != 0) {\n" field1 field2;
5068               pr "      fprintf (stderr, \"%s: %s (\"%%s\") <> %s (\"%%s\")\\n\",\n"
5069                 test_name field1 field2;
5070               pr "               r->%s, r->%s);\n" field1 field2;
5071               pr "      return -1;\n";
5072               pr "    }\n"
5073         ) checks
5074       in
5075       List.iter (generate_test_command_call test_name) seq;
5076       generate_test_command_call ~test test_name last
5077   | TestLastFail seq ->
5078       pr "  /* TestLastFail for %s (%d) */\n" name i;
5079       let seq, last = get_seq_last seq in
5080       List.iter (generate_test_command_call test_name) seq;
5081       generate_test_command_call test_name ~expect_error:true last
5082
5083 (* Generate the code to run a command, leaving the result in 'r'.
5084  * If you expect to get an error then you should set expect_error:true.
5085  *)
5086 and generate_test_command_call ?(expect_error = false) ?test test_name cmd =
5087   match cmd with
5088   | [] -> assert false
5089   | name :: args ->
5090       (* Look up the command to find out what args/ret it has. *)
5091       let style =
5092         try
5093           let _, style, _, _, _, _, _ =
5094             List.find (fun (n, _, _, _, _, _, _) -> n = name) all_functions in
5095           style
5096         with Not_found ->
5097           failwithf "%s: in test, command %s was not found" test_name name in
5098
5099       if List.length (snd style) <> List.length args then
5100         failwithf "%s: in test, wrong number of args given to %s"
5101           test_name name;
5102
5103       pr "  {\n";
5104
5105       List.iter (
5106         function
5107         | OptString n, "NULL" -> ()
5108         | String n, arg
5109         | OptString n, arg ->
5110             pr "    const char *%s = \"%s\";\n" n (c_quote arg);
5111         | Int _, _
5112         | Bool _, _
5113         | FileIn _, _ | FileOut _, _ -> ()
5114         | StringList n, arg ->
5115             let strs = string_split " " arg in
5116             iteri (
5117               fun i str ->
5118                 pr "    const char *%s_%d = \"%s\";\n" n i (c_quote str);
5119             ) strs;
5120             pr "    const char *%s[] = {\n" n;
5121             iteri (
5122               fun i _ -> pr "      %s_%d,\n" n i
5123             ) strs;
5124             pr "      NULL\n";
5125             pr "    };\n";
5126       ) (List.combine (snd style) args);
5127
5128       let error_code =
5129         match fst style with
5130         | RErr | RInt _ | RBool _ -> pr "    int r;\n"; "-1"
5131         | RInt64 _ -> pr "    int64_t r;\n"; "-1"
5132         | RConstString _ -> pr "    const char *r;\n"; "NULL"
5133         | RString _ -> pr "    char *r;\n"; "NULL"
5134         | RStringList _ | RHashtable _ ->
5135             pr "    char **r;\n";
5136             pr "    int i;\n";
5137             "NULL"
5138         | RStruct (_, typ) ->
5139             pr "    struct guestfs_%s *r;\n" typ; "NULL"
5140         | RStructList (_, typ) ->
5141             pr "    struct guestfs_%s_list *r;\n" typ; "NULL" in
5142
5143       pr "    suppress_error = %d;\n" (if expect_error then 1 else 0);
5144       pr "    r = guestfs_%s (g" name;
5145
5146       (* Generate the parameters. *)
5147       List.iter (
5148         function
5149         | OptString _, "NULL" -> pr ", NULL"
5150         | String n, _
5151         | OptString n, _ ->
5152             pr ", %s" n
5153         | FileIn _, arg | FileOut _, arg ->
5154             pr ", \"%s\"" (c_quote arg)
5155         | StringList n, _ ->
5156             pr ", %s" n
5157         | Int _, arg ->
5158             let i =
5159               try int_of_string arg
5160               with Failure "int_of_string" ->
5161                 failwithf "%s: expecting an int, but got '%s'" test_name arg in
5162             pr ", %d" i
5163         | Bool _, arg ->
5164             let b = bool_of_string arg in pr ", %d" (if b then 1 else 0)
5165       ) (List.combine (snd style) args);
5166
5167       pr ");\n";
5168       if not expect_error then
5169         pr "    if (r == %s)\n" error_code
5170       else
5171         pr "    if (r != %s)\n" error_code;
5172       pr "      return -1;\n";
5173
5174       (* Insert the test code. *)
5175       (match test with
5176        | None -> ()
5177        | Some f -> f ()
5178       );
5179
5180       (match fst style with
5181        | RErr | RInt _ | RInt64 _ | RBool _ | RConstString _ -> ()
5182        | RString _ -> pr "    free (r);\n"
5183        | RStringList _ | RHashtable _ ->
5184            pr "    for (i = 0; r[i] != NULL; ++i)\n";
5185            pr "      free (r[i]);\n";
5186            pr "    free (r);\n"
5187        | RStruct (_, typ) ->
5188            pr "    guestfs_free_%s (r);\n" typ
5189        | RStructList (_, typ) ->
5190            pr "    guestfs_free_%s_list (r);\n" typ
5191       );
5192
5193       pr "  }\n"
5194
5195 and c_quote str =
5196   let str = replace_str str "\r" "\\r" in
5197   let str = replace_str str "\n" "\\n" in
5198   let str = replace_str str "\t" "\\t" in
5199   let str = replace_str str "\000" "\\0" in
5200   str
5201
5202 (* Generate a lot of different functions for guestfish. *)
5203 and generate_fish_cmds () =
5204   generate_header CStyle GPLv2;
5205
5206   let all_functions =
5207     List.filter (
5208       fun (_, _, _, flags, _, _, _) -> not (List.mem NotInFish flags)
5209     ) all_functions in
5210   let all_functions_sorted =
5211     List.filter (
5212       fun (_, _, _, flags, _, _, _) -> not (List.mem NotInFish flags)
5213     ) all_functions_sorted in
5214
5215   pr "#include <stdio.h>\n";
5216   pr "#include <stdlib.h>\n";
5217   pr "#include <string.h>\n";
5218   pr "#include <inttypes.h>\n";
5219   pr "#include <ctype.h>\n";
5220   pr "\n";
5221   pr "#include <guestfs.h>\n";
5222   pr "#include \"fish.h\"\n";
5223   pr "\n";
5224
5225   (* list_commands function, which implements guestfish -h *)
5226   pr "void list_commands (void)\n";
5227   pr "{\n";
5228   pr "  printf (\"    %%-16s     %%s\\n\", \"Command\", \"Description\");\n";
5229   pr "  list_builtin_commands ();\n";
5230   List.iter (
5231     fun (name, _, _, flags, _, shortdesc, _) ->
5232       let name = replace_char name '_' '-' in
5233       pr "  printf (\"%%-20s %%s\\n\", \"%s\", \"%s\");\n"
5234         name shortdesc
5235   ) all_functions_sorted;
5236   pr "  printf (\"    Use -h <cmd> / help <cmd> to show detailed help for a command.\\n\");\n";
5237   pr "}\n";
5238   pr "\n";
5239
5240   (* display_command function, which implements guestfish -h cmd *)
5241   pr "void display_command (const char *cmd)\n";
5242   pr "{\n";
5243   List.iter (
5244     fun (name, style, _, flags, _, shortdesc, longdesc) ->
5245       let name2 = replace_char name '_' '-' in
5246       let alias =
5247         try find_map (function FishAlias n -> Some n | _ -> None) flags
5248         with Not_found -> name in
5249       let longdesc = replace_str longdesc "C<guestfs_" "C<" in
5250       let synopsis =
5251         match snd style with
5252         | [] -> name2
5253         | args ->
5254             sprintf "%s <%s>"
5255               name2 (String.concat "> <" (List.map name_of_argt args)) in
5256
5257       let warnings =
5258         if List.mem ProtocolLimitWarning flags then
5259           ("\n\n" ^ protocol_limit_warning)
5260         else "" in
5261
5262       (* For DangerWillRobinson commands, we should probably have
5263        * guestfish prompt before allowing you to use them (especially
5264        * in interactive mode). XXX
5265        *)
5266       let warnings =
5267         warnings ^
5268           if List.mem DangerWillRobinson flags then
5269             ("\n\n" ^ danger_will_robinson)
5270           else "" in
5271
5272       let describe_alias =
5273         if name <> alias then
5274           sprintf "\n\nYou can use '%s' as an alias for this command." alias
5275         else "" in
5276
5277       pr "  if (";
5278       pr "strcasecmp (cmd, \"%s\") == 0" name;
5279       if name <> name2 then
5280         pr " || strcasecmp (cmd, \"%s\") == 0" name2;
5281       if name <> alias then
5282         pr " || strcasecmp (cmd, \"%s\") == 0" alias;
5283       pr ")\n";
5284       pr "    pod2text (\"%s - %s\", %S);\n"
5285         name2 shortdesc
5286         (" " ^ synopsis ^ "\n\n" ^ longdesc ^ warnings ^ describe_alias);
5287       pr "  else\n"
5288   ) all_functions;
5289   pr "    display_builtin_command (cmd);\n";
5290   pr "}\n";
5291   pr "\n";
5292
5293   (* print_* functions *)
5294   List.iter (
5295     fun (typ, cols) ->
5296       let needs_i =
5297         List.exists (function (_, (FUUID|FBuffer)) -> true | _ -> false) cols in
5298
5299       pr "static void print_%s (struct guestfs_%s *%s)\n" typ typ typ;
5300       pr "{\n";
5301       if needs_i then (
5302         pr "  int i;\n";
5303         pr "\n"
5304       );
5305       List.iter (
5306         function
5307         | name, FString ->
5308             pr "  printf (\"%s: %%s\\n\", %s->%s);\n" name typ name
5309         | name, FUUID ->
5310             pr "  printf (\"%s: \");\n" name;
5311             pr "  for (i = 0; i < 32; ++i)\n";
5312             pr "    printf (\"%%c\", %s->%s[i]);\n" typ name;
5313             pr "  printf (\"\\n\");\n"
5314         | name, FBuffer ->
5315             pr "  printf (\"%s: \");\n" name;
5316             pr "  for (i = 0; i < %s->%s_len; ++i)\n" typ name;
5317             pr "    if (isprint (%s->%s[i]))\n" typ name;
5318             pr "      printf (\"%%c\", %s->%s[i]);\n" typ name;
5319             pr "    else\n";
5320             pr "      printf (\"\\\\x%%02x\", %s->%s[i]);\n" typ name;
5321             pr "  printf (\"\\n\");\n"
5322         | name, (FUInt64|FBytes) ->
5323             pr "  printf (\"%s: %%\" PRIu64 \"\\n\", %s->%s);\n" name typ name
5324         | name, FInt64 ->
5325             pr "  printf (\"%s: %%\" PRIi64 \"\\n\", %s->%s);\n" name typ name
5326         | name, FUInt32 ->
5327             pr "  printf (\"%s: %%\" PRIu32 \"\\n\", %s->%s);\n" name typ name
5328         | name, FInt32 ->
5329             pr "  printf (\"%s: %%\" PRIi32 \"\\n\", %s->%s);\n" name typ name
5330         | name, FChar ->
5331             pr "  printf (\"%s: %%c\\n\", %s->%s);\n" name typ name
5332         | name, FOptPercent ->
5333             pr "  if (%s->%s >= 0) printf (\"%s: %%g %%%%\\n\", %s->%s);\n"
5334               typ name name typ name;
5335             pr "  else printf (\"%s: \\n\");\n" name
5336       ) cols;
5337       pr "}\n";
5338       pr "\n";
5339       pr "static void print_%s_list (struct guestfs_%s_list *%ss)\n"
5340         typ typ typ;
5341       pr "{\n";
5342       pr "  int i;\n";
5343       pr "\n";
5344       pr "  for (i = 0; i < %ss->len; ++i)\n" typ;
5345       pr "    print_%s (&%ss->val[i]);\n" typ typ;
5346       pr "}\n";
5347       pr "\n";
5348   ) structs;
5349
5350   (* run_<action> actions *)
5351   List.iter (
5352     fun (name, style, _, flags, _, _, _) ->
5353       pr "static int run_%s (const char *cmd, int argc, char *argv[])\n" name;
5354       pr "{\n";
5355       (match fst style with
5356        | RErr
5357        | RInt _
5358        | RBool _ -> pr "  int r;\n"
5359        | RInt64 _ -> pr "  int64_t r;\n"
5360        | RConstString _ -> pr "  const char *r;\n"
5361        | RString _ -> pr "  char *r;\n"
5362        | RStringList _ | RHashtable _ -> pr "  char **r;\n"
5363        | RStruct (_, typ) -> pr "  struct guestfs_%s *r;\n" typ
5364        | RStructList (_, typ) -> pr "  struct guestfs_%s_list *r;\n" typ
5365       );
5366       List.iter (
5367         function
5368         | String n
5369         | OptString n
5370         | FileIn n
5371         | FileOut n -> pr "  const char *%s;\n" n
5372         | StringList n -> pr "  char **%s;\n" n
5373         | Bool n -> pr "  int %s;\n" n
5374         | Int n -> pr "  int %s;\n" n
5375       ) (snd style);
5376
5377       (* Check and convert parameters. *)
5378       let argc_expected = List.length (snd style) in
5379       pr "  if (argc != %d) {\n" argc_expected;
5380       pr "    fprintf (stderr, \"%%s should have %d parameter(s)\\n\", cmd);\n"
5381         argc_expected;
5382       pr "    fprintf (stderr, \"type 'help %%s' for help on %%s\\n\", cmd, cmd);\n";
5383       pr "    return -1;\n";
5384       pr "  }\n";
5385       iteri (
5386         fun i ->
5387           function
5388           | String name -> pr "  %s = argv[%d];\n" name i
5389           | OptString name ->
5390               pr "  %s = strcmp (argv[%d], \"\") != 0 ? argv[%d] : NULL;\n"
5391                 name i i
5392           | FileIn name ->
5393               pr "  %s = strcmp (argv[%d], \"-\") != 0 ? argv[%d] : \"/dev/stdin\";\n"
5394                 name i i
5395           | FileOut name ->
5396               pr "  %s = strcmp (argv[%d], \"-\") != 0 ? argv[%d] : \"/dev/stdout\";\n"
5397                 name i i
5398           | StringList name ->
5399               pr "  %s = parse_string_list (argv[%d]);\n" name i
5400           | Bool name ->
5401               pr "  %s = is_true (argv[%d]) ? 1 : 0;\n" name i
5402           | Int name ->
5403               pr "  %s = atoi (argv[%d]);\n" name i
5404       ) (snd style);
5405
5406       (* Call C API function. *)
5407       let fn =
5408         try find_map (function FishAction n -> Some n | _ -> None) flags
5409         with Not_found -> sprintf "guestfs_%s" name in
5410       pr "  r = %s " fn;
5411       generate_call_args ~handle:"g" (snd style);
5412       pr ";\n";
5413
5414       (* Check return value for errors and display command results. *)
5415       (match fst style with
5416        | RErr -> pr "  return r;\n"
5417        | RInt _ ->
5418            pr "  if (r == -1) return -1;\n";
5419            pr "  printf (\"%%d\\n\", r);\n";
5420            pr "  return 0;\n"
5421        | RInt64 _ ->
5422            pr "  if (r == -1) return -1;\n";
5423            pr "  printf (\"%%\" PRIi64 \"\\n\", r);\n";
5424            pr "  return 0;\n"
5425        | RBool _ ->
5426            pr "  if (r == -1) return -1;\n";
5427            pr "  if (r) printf (\"true\\n\"); else printf (\"false\\n\");\n";
5428            pr "  return 0;\n"
5429        | RConstString _ ->
5430            pr "  if (r == NULL) return -1;\n";
5431            pr "  printf (\"%%s\\n\", r);\n";
5432            pr "  return 0;\n"
5433        | RString _ ->
5434            pr "  if (r == NULL) return -1;\n";
5435            pr "  printf (\"%%s\\n\", r);\n";
5436            pr "  free (r);\n";
5437            pr "  return 0;\n"
5438        | RStringList _ ->
5439            pr "  if (r == NULL) return -1;\n";
5440            pr "  print_strings (r);\n";
5441            pr "  free_strings (r);\n";
5442            pr "  return 0;\n"
5443        | RStruct (_, typ) ->
5444            pr "  if (r == NULL) return -1;\n";
5445            pr "  print_%s (r);\n" typ;
5446            pr "  guestfs_free_%s (r);\n" typ;
5447            pr "  return 0;\n"
5448        | RStructList (_, typ) ->
5449            pr "  if (r == NULL) return -1;\n";
5450            pr "  print_%s_list (r);\n" typ;
5451            pr "  guestfs_free_%s_list (r);\n" typ;
5452            pr "  return 0;\n"
5453        | RHashtable _ ->
5454            pr "  if (r == NULL) return -1;\n";
5455            pr "  print_table (r);\n";
5456            pr "  free_strings (r);\n";
5457            pr "  return 0;\n"
5458       );
5459       pr "}\n";
5460       pr "\n"
5461   ) all_functions;
5462
5463   (* run_action function *)
5464   pr "int run_action (const char *cmd, int argc, char *argv[])\n";
5465   pr "{\n";
5466   List.iter (
5467     fun (name, _, _, flags, _, _, _) ->
5468       let name2 = replace_char name '_' '-' in
5469       let alias =
5470         try find_map (function FishAlias n -> Some n | _ -> None) flags
5471         with Not_found -> name in
5472       pr "  if (";
5473       pr "strcasecmp (cmd, \"%s\") == 0" name;
5474       if name <> name2 then
5475         pr " || strcasecmp (cmd, \"%s\") == 0" name2;
5476       if name <> alias then
5477         pr " || strcasecmp (cmd, \"%s\") == 0" alias;
5478       pr ")\n";
5479       pr "    return run_%s (cmd, argc, argv);\n" name;
5480       pr "  else\n";
5481   ) all_functions;
5482   pr "    {\n";
5483   pr "      fprintf (stderr, \"%%s: unknown command\\n\", cmd);\n";
5484   pr "      return -1;\n";
5485   pr "    }\n";
5486   pr "  return 0;\n";
5487   pr "}\n";
5488   pr "\n"
5489
5490 (* Readline completion for guestfish. *)
5491 and generate_fish_completion () =
5492   generate_header CStyle GPLv2;
5493
5494   let all_functions =
5495     List.filter (
5496       fun (_, _, _, flags, _, _, _) -> not (List.mem NotInFish flags)
5497     ) all_functions in
5498
5499   pr "\
5500 #include <config.h>
5501
5502 #include <stdio.h>
5503 #include <stdlib.h>
5504 #include <string.h>
5505
5506 #ifdef HAVE_LIBREADLINE
5507 #include <readline/readline.h>
5508 #endif
5509
5510 #include \"fish.h\"
5511
5512 #ifdef HAVE_LIBREADLINE
5513
5514 static const char *const commands[] = {
5515   BUILTIN_COMMANDS_FOR_COMPLETION,
5516 ";
5517
5518   (* Get the commands, including the aliases.  They don't need to be
5519    * sorted - the generator() function just does a dumb linear search.
5520    *)
5521   let commands =
5522     List.map (
5523       fun (name, _, _, flags, _, _, _) ->
5524         let name2 = replace_char name '_' '-' in
5525         let alias =
5526           try find_map (function FishAlias n -> Some n | _ -> None) flags
5527           with Not_found -> name in
5528
5529         if name <> alias then [name2; alias] else [name2]
5530     ) all_functions in
5531   let commands = List.flatten commands in
5532
5533   List.iter (pr "  \"%s\",\n") commands;
5534
5535   pr "  NULL
5536 };
5537
5538 static char *
5539 generator (const char *text, int state)
5540 {
5541   static int index, len;
5542   const char *name;
5543
5544   if (!state) {
5545     index = 0;
5546     len = strlen (text);
5547   }
5548
5549   rl_attempted_completion_over = 1;
5550
5551   while ((name = commands[index]) != NULL) {
5552     index++;
5553     if (strncasecmp (name, text, len) == 0)
5554       return strdup (name);
5555   }
5556
5557   return NULL;
5558 }
5559
5560 #endif /* HAVE_LIBREADLINE */
5561
5562 char **do_completion (const char *text, int start, int end)
5563 {
5564   char **matches = NULL;
5565
5566 #ifdef HAVE_LIBREADLINE
5567   rl_completion_append_character = ' ';
5568
5569   if (start == 0)
5570     matches = rl_completion_matches (text, generator);
5571   else if (complete_dest_paths)
5572     matches = rl_completion_matches (text, complete_dest_paths_generator);
5573 #endif
5574
5575   return matches;
5576 }
5577 ";
5578
5579 (* Generate the POD documentation for guestfish. *)
5580 and generate_fish_actions_pod () =
5581   let all_functions_sorted =
5582     List.filter (
5583       fun (_, _, _, flags, _, _, _) ->
5584         not (List.mem NotInFish flags || List.mem NotInDocs flags)
5585     ) all_functions_sorted in
5586
5587   let rex = Str.regexp "C<guestfs_\\([^>]+\\)>" in
5588
5589   List.iter (
5590     fun (name, style, _, flags, _, _, longdesc) ->
5591       let longdesc =
5592         Str.global_substitute rex (
5593           fun s ->
5594             let sub =
5595               try Str.matched_group 1 s
5596               with Not_found ->
5597                 failwithf "error substituting C<guestfs_...> in longdesc of function %s" name in
5598             "C<" ^ replace_char sub '_' '-' ^ ">"
5599         ) longdesc in
5600       let name = replace_char name '_' '-' in
5601       let alias =
5602         try find_map (function FishAlias n -> Some n | _ -> None) flags
5603         with Not_found -> name in
5604
5605       pr "=head2 %s" name;
5606       if name <> alias then
5607         pr " | %s" alias;
5608       pr "\n";
5609       pr "\n";
5610       pr " %s" name;
5611       List.iter (
5612         function
5613         | String n -> pr " %s" n
5614         | OptString n -> pr " %s" n
5615         | StringList n -> pr " '%s ...'" n
5616         | Bool _ -> pr " true|false"
5617         | Int n -> pr " %s" n
5618         | FileIn n | FileOut n -> pr " (%s|-)" n
5619       ) (snd style);
5620       pr "\n";
5621       pr "\n";
5622       pr "%s\n\n" longdesc;
5623
5624       if List.exists (function FileIn _ | FileOut _ -> true
5625                       | _ -> false) (snd style) then
5626         pr "Use C<-> instead of a filename to read/write from stdin/stdout.\n\n";
5627
5628       if List.mem ProtocolLimitWarning flags then
5629         pr "%s\n\n" protocol_limit_warning;
5630
5631       if List.mem DangerWillRobinson flags then
5632         pr "%s\n\n" danger_will_robinson
5633   ) all_functions_sorted
5634
5635 (* Generate a C function prototype. *)
5636 and generate_prototype ?(extern = true) ?(static = false) ?(semicolon = true)
5637     ?(single_line = false) ?(newline = false) ?(in_daemon = false)
5638     ?(prefix = "")
5639     ?handle name style =
5640   if extern then pr "extern ";
5641   if static then pr "static ";
5642   (match fst style with
5643    | RErr -> pr "int "
5644    | RInt _ -> pr "int "
5645    | RInt64 _ -> pr "int64_t "
5646    | RBool _ -> pr "int "
5647    | RConstString _ -> pr "const char *"
5648    | RString _ -> pr "char *"
5649    | RStringList _ | RHashtable _ -> pr "char **"
5650    | RStruct (_, typ) ->
5651        if not in_daemon then pr "struct guestfs_%s *" typ
5652        else pr "guestfs_int_%s *" typ
5653    | RStructList (_, typ) ->
5654        if not in_daemon then pr "struct guestfs_%s_list *" typ
5655        else pr "guestfs_int_%s_list *" typ
5656   );
5657   pr "%s%s (" prefix name;
5658   if handle = None && List.length (snd style) = 0 then
5659     pr "void"
5660   else (
5661     let comma = ref false in
5662     (match handle with
5663      | None -> ()
5664      | Some handle -> pr "guestfs_h *%s" handle; comma := true
5665     );
5666     let next () =
5667       if !comma then (
5668         if single_line then pr ", " else pr ",\n\t\t"
5669       );
5670       comma := true
5671     in
5672     List.iter (
5673       function
5674       | String n
5675       | OptString n ->
5676           next ();
5677           if not in_daemon then pr "const char *%s" n
5678           else pr "char *%s" n
5679       | StringList n ->
5680           next ();
5681           if not in_daemon then pr "char * const* const %s" n
5682           else pr "char **%s" n
5683       | Bool n -> next (); pr "int %s" n
5684       | Int n -> next (); pr "int %s" n
5685       | FileIn n
5686       | FileOut n ->
5687           if not in_daemon then (next (); pr "const char *%s" n)
5688     ) (snd style);
5689   );
5690   pr ")";
5691   if semicolon then pr ";";
5692   if newline then pr "\n"
5693
5694 (* Generate C call arguments, eg "(handle, foo, bar)" *)
5695 and generate_call_args ?handle args =
5696   pr "(";
5697   let comma = ref false in
5698   (match handle with
5699    | None -> ()
5700    | Some handle -> pr "%s" handle; comma := true
5701   );
5702   List.iter (
5703     fun arg ->
5704       if !comma then pr ", ";
5705       comma := true;
5706       pr "%s" (name_of_argt arg)
5707   ) args;
5708   pr ")"
5709
5710 (* Generate the OCaml bindings interface. *)
5711 and generate_ocaml_mli () =
5712   generate_header OCamlStyle LGPLv2;
5713
5714   pr "\
5715 (** For API documentation you should refer to the C API
5716     in the guestfs(3) manual page.  The OCaml API uses almost
5717     exactly the same calls. *)
5718
5719 type t
5720 (** A [guestfs_h] handle. *)
5721
5722 exception Error of string
5723 (** This exception is raised when there is an error. *)
5724
5725 val create : unit -> t
5726
5727 val close : t -> unit
5728 (** Handles are closed by the garbage collector when they become
5729     unreferenced, but callers can also call this in order to
5730     provide predictable cleanup. *)
5731
5732 ";
5733   generate_ocaml_structure_decls ();
5734
5735   (* The actions. *)
5736   List.iter (
5737     fun (name, style, _, _, _, shortdesc, _) ->
5738       generate_ocaml_prototype name style;
5739       pr "(** %s *)\n" shortdesc;
5740       pr "\n"
5741   ) all_functions
5742
5743 (* Generate the OCaml bindings implementation. *)
5744 and generate_ocaml_ml () =
5745   generate_header OCamlStyle LGPLv2;
5746
5747   pr "\
5748 type t
5749 exception Error of string
5750 external create : unit -> t = \"ocaml_guestfs_create\"
5751 external close : t -> unit = \"ocaml_guestfs_close\"
5752
5753 let () =
5754   Callback.register_exception \"ocaml_guestfs_error\" (Error \"\")
5755
5756 ";
5757
5758   generate_ocaml_structure_decls ();
5759
5760   (* The actions. *)
5761   List.iter (
5762     fun (name, style, _, _, _, shortdesc, _) ->
5763       generate_ocaml_prototype ~is_external:true name style;
5764   ) all_functions
5765
5766 (* Generate the OCaml bindings C implementation. *)
5767 and generate_ocaml_c () =
5768   generate_header CStyle LGPLv2;
5769
5770   pr "\
5771 #include <stdio.h>
5772 #include <stdlib.h>
5773 #include <string.h>
5774
5775 #include <caml/config.h>
5776 #include <caml/alloc.h>
5777 #include <caml/callback.h>
5778 #include <caml/fail.h>
5779 #include <caml/memory.h>
5780 #include <caml/mlvalues.h>
5781 #include <caml/signals.h>
5782
5783 #include <guestfs.h>
5784
5785 #include \"guestfs_c.h\"
5786
5787 /* Copy a hashtable of string pairs into an assoc-list.  We return
5788  * the list in reverse order, but hashtables aren't supposed to be
5789  * ordered anyway.
5790  */
5791 static CAMLprim value
5792 copy_table (char * const * argv)
5793 {
5794   CAMLparam0 ();
5795   CAMLlocal5 (rv, pairv, kv, vv, cons);
5796   int i;
5797
5798   rv = Val_int (0);
5799   for (i = 0; argv[i] != NULL; i += 2) {
5800     kv = caml_copy_string (argv[i]);
5801     vv = caml_copy_string (argv[i+1]);
5802     pairv = caml_alloc (2, 0);
5803     Store_field (pairv, 0, kv);
5804     Store_field (pairv, 1, vv);
5805     cons = caml_alloc (2, 0);
5806     Store_field (cons, 1, rv);
5807     rv = cons;
5808     Store_field (cons, 0, pairv);
5809   }
5810
5811   CAMLreturn (rv);
5812 }
5813
5814 ";
5815
5816   (* Struct copy functions. *)
5817   List.iter (
5818     fun (typ, cols) ->
5819       let has_optpercent_col =
5820         List.exists (function (_, FOptPercent) -> true | _ -> false) cols in
5821
5822       pr "static CAMLprim value\n";
5823       pr "copy_%s (const struct guestfs_%s *%s)\n" typ typ typ;
5824       pr "{\n";
5825       pr "  CAMLparam0 ();\n";
5826       if has_optpercent_col then
5827         pr "  CAMLlocal3 (rv, v, v2);\n"
5828       else
5829         pr "  CAMLlocal2 (rv, v);\n";
5830       pr "\n";
5831       pr "  rv = caml_alloc (%d, 0);\n" (List.length cols);
5832       iteri (
5833         fun i col ->
5834           (match col with
5835            | name, FString ->
5836                pr "  v = caml_copy_string (%s->%s);\n" typ name
5837            | name, FBuffer ->
5838                pr "  v = caml_alloc_string (%s->%s_len);\n" typ name;
5839                pr "  memcpy (String_val (v), %s->%s, %s->%s_len);\n"
5840                  typ name typ name
5841            | name, FUUID ->
5842                pr "  v = caml_alloc_string (32);\n";
5843                pr "  memcpy (String_val (v), %s->%s, 32);\n" typ name
5844            | name, (FBytes|FInt64|FUInt64) ->
5845                pr "  v = caml_copy_int64 (%s->%s);\n" typ name
5846            | name, (FInt32|FUInt32) ->
5847                pr "  v = caml_copy_int32 (%s->%s);\n" typ name
5848            | name, FOptPercent ->
5849                pr "  if (%s->%s >= 0) { /* Some %s */\n" typ name name;
5850                pr "    v2 = caml_copy_double (%s->%s);\n" typ name;
5851                pr "    v = caml_alloc (1, 0);\n";
5852                pr "    Store_field (v, 0, v2);\n";
5853                pr "  } else /* None */\n";
5854                pr "    v = Val_int (0);\n";
5855            | name, FChar ->
5856                pr "  v = Val_int (%s->%s);\n" typ name
5857           );
5858           pr "  Store_field (rv, %d, v);\n" i
5859       ) cols;
5860       pr "  CAMLreturn (rv);\n";
5861       pr "}\n";
5862       pr "\n";
5863
5864       pr "static CAMLprim value\n";
5865       pr "copy_%s_list (const struct guestfs_%s_list *%ss)\n"
5866         typ typ typ;
5867       pr "{\n";
5868       pr "  CAMLparam0 ();\n";
5869       pr "  CAMLlocal2 (rv, v);\n";
5870       pr "  int i;\n";
5871       pr "\n";
5872       pr "  if (%ss->len == 0)\n" typ;
5873       pr "    CAMLreturn (Atom (0));\n";
5874       pr "  else {\n";
5875       pr "    rv = caml_alloc (%ss->len, 0);\n" typ;
5876       pr "    for (i = 0; i < %ss->len; ++i) {\n" typ;
5877       pr "      v = copy_%s (&%ss->val[i]);\n" typ typ;
5878       pr "      caml_modify (&Field (rv, i), v);\n";
5879       pr "    }\n";
5880       pr "    CAMLreturn (rv);\n";
5881       pr "  }\n";
5882       pr "}\n";
5883       pr "\n";
5884   ) structs;
5885
5886   (* The wrappers. *)
5887   List.iter (
5888     fun (name, style, _, _, _, _, _) ->
5889       let params =
5890         "gv" :: List.map (fun arg -> name_of_argt arg ^ "v") (snd style) in
5891
5892       pr "CAMLprim value\n";
5893       pr "ocaml_guestfs_%s (value %s" name (List.hd params);
5894       List.iter (pr ", value %s") (List.tl params);
5895       pr ")\n";
5896       pr "{\n";
5897
5898       (match params with
5899        | [p1; p2; p3; p4; p5] ->
5900            pr "  CAMLparam5 (%s);\n" (String.concat ", " params)
5901        | p1 :: p2 :: p3 :: p4 :: p5 :: rest ->
5902            pr "  CAMLparam5 (%s);\n" (String.concat ", " [p1; p2; p3; p4; p5]);
5903            pr "  CAMLxparam%d (%s);\n"
5904              (List.length rest) (String.concat ", " rest)
5905        | ps ->
5906            pr "  CAMLparam%d (%s);\n" (List.length ps) (String.concat ", " ps)
5907       );
5908       pr "  CAMLlocal1 (rv);\n";
5909       pr "\n";
5910
5911       pr "  guestfs_h *g = Guestfs_val (gv);\n";
5912       pr "  if (g == NULL)\n";
5913       pr "    caml_failwith (\"%s: used handle after closing it\");\n" name;
5914       pr "\n";
5915
5916       List.iter (
5917         function
5918         | String n
5919         | FileIn n
5920         | FileOut n ->
5921             pr "  const char *%s = String_val (%sv);\n" n n
5922         | OptString n ->
5923             pr "  const char *%s =\n" n;
5924             pr "    %sv != Val_int (0) ? String_val (Field (%sv, 0)) : NULL;\n"
5925               n n
5926         | StringList n ->
5927             pr "  char **%s = ocaml_guestfs_strings_val (g, %sv);\n" n n
5928         | Bool n ->
5929             pr "  int %s = Bool_val (%sv);\n" n n
5930         | Int n ->
5931             pr "  int %s = Int_val (%sv);\n" n n
5932       ) (snd style);
5933       let error_code =
5934         match fst style with
5935         | RErr -> pr "  int r;\n"; "-1"
5936         | RInt _ -> pr "  int r;\n"; "-1"
5937         | RInt64 _ -> pr "  int64_t r;\n"; "-1"
5938         | RBool _ -> pr "  int r;\n"; "-1"
5939         | RConstString _ -> pr "  const char *r;\n"; "NULL"
5940         | RString _ -> pr "  char *r;\n"; "NULL"
5941         | RStringList _ ->
5942             pr "  int i;\n";
5943             pr "  char **r;\n";
5944             "NULL"
5945         | RStruct (_, typ) ->
5946             pr "  struct guestfs_%s *r;\n" typ; "NULL"
5947         | RStructList (_, typ) ->
5948             pr "  struct guestfs_%s_list *r;\n" typ; "NULL"
5949         | RHashtable _ ->
5950             pr "  int i;\n";
5951             pr "  char **r;\n";
5952             "NULL" in
5953       pr "\n";
5954
5955       pr "  caml_enter_blocking_section ();\n";
5956       pr "  r = guestfs_%s " name;
5957       generate_call_args ~handle:"g" (snd style);
5958       pr ";\n";
5959       pr "  caml_leave_blocking_section ();\n";
5960
5961       List.iter (
5962         function
5963         | StringList n ->
5964             pr "  ocaml_guestfs_free_strings (%s);\n" n;
5965         | String _ | OptString _ | Bool _ | Int _ | FileIn _ | FileOut _ -> ()
5966       ) (snd style);
5967
5968       pr "  if (r == %s)\n" error_code;
5969       pr "    ocaml_guestfs_raise_error (g, \"%s\");\n" name;
5970       pr "\n";
5971
5972       (match fst style with
5973        | RErr -> pr "  rv = Val_unit;\n"
5974        | RInt _ -> pr "  rv = Val_int (r);\n"
5975        | RInt64 _ ->
5976            pr "  rv = caml_copy_int64 (r);\n"
5977        | RBool _ -> pr "  rv = Val_bool (r);\n"
5978        | RConstString _ -> pr "  rv = caml_copy_string (r);\n"
5979        | RString _ ->
5980            pr "  rv = caml_copy_string (r);\n";
5981            pr "  free (r);\n"
5982        | RStringList _ ->
5983            pr "  rv = caml_copy_string_array ((const char **) r);\n";
5984            pr "  for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
5985            pr "  free (r);\n"
5986        | RStruct (_, typ) ->
5987            pr "  rv = copy_%s (r);\n" typ;
5988            pr "  guestfs_free_%s (r);\n" typ;
5989        | RStructList (_, typ) ->
5990            pr "  rv = copy_%s_list (r);\n" typ;
5991            pr "  guestfs_free_%s_list (r);\n" typ;
5992        | RHashtable _ ->
5993            pr "  rv = copy_table (r);\n";
5994            pr "  for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
5995            pr "  free (r);\n";
5996       );
5997
5998       pr "  CAMLreturn (rv);\n";
5999       pr "}\n";
6000       pr "\n";
6001
6002       if List.length params > 5 then (
6003         pr "CAMLprim value\n";
6004         pr "ocaml_guestfs_%s_byte (value *argv, int argn)\n" name;
6005         pr "{\n";
6006         pr "  return ocaml_guestfs_%s (argv[0]" name;
6007         iteri (fun i _ -> pr ", argv[%d]" i) (List.tl params);
6008         pr ");\n";
6009         pr "}\n";
6010         pr "\n"
6011       )
6012   ) all_functions
6013
6014 and generate_ocaml_structure_decls () =
6015   List.iter (
6016     fun (typ, cols) ->
6017       pr "type %s = {\n" typ;
6018       List.iter (
6019         function
6020         | name, FString -> pr "  %s : string;\n" name
6021         | name, FBuffer -> pr "  %s : string;\n" name
6022         | name, FUUID -> pr "  %s : string;\n" name
6023         | name, (FBytes|FInt64|FUInt64) -> pr "  %s : int64;\n" name
6024         | name, (FInt32|FUInt32) -> pr "  %s : int32;\n" name
6025         | name, FChar -> pr "  %s : char;\n" name
6026         | name, FOptPercent -> pr "  %s : float option;\n" name
6027       ) cols;
6028       pr "}\n";
6029       pr "\n"
6030   ) structs
6031
6032 and generate_ocaml_prototype ?(is_external = false) name style =
6033   if is_external then pr "external " else pr "val ";
6034   pr "%s : t -> " name;
6035   List.iter (
6036     function
6037     | String _ | FileIn _ | FileOut _ -> pr "string -> "
6038     | OptString _ -> pr "string option -> "
6039     | StringList _ -> pr "string array -> "
6040     | Bool _ -> pr "bool -> "
6041     | Int _ -> pr "int -> "
6042   ) (snd style);
6043   (match fst style with
6044    | RErr -> pr "unit" (* all errors are turned into exceptions *)
6045    | RInt _ -> pr "int"
6046    | RInt64 _ -> pr "int64"
6047    | RBool _ -> pr "bool"
6048    | RConstString _ -> pr "string"
6049    | RString _ -> pr "string"
6050    | RStringList _ -> pr "string array"
6051    | RStruct (_, typ) -> pr "%s" typ
6052    | RStructList (_, typ) -> pr "%s array" typ
6053    | RHashtable _ -> pr "(string * string) list"
6054   );
6055   if is_external then (
6056     pr " = ";
6057     if List.length (snd style) + 1 > 5 then
6058       pr "\"ocaml_guestfs_%s_byte\" " name;
6059     pr "\"ocaml_guestfs_%s\"" name
6060   );
6061   pr "\n"
6062
6063 (* Generate Perl xs code, a sort of crazy variation of C with macros. *)
6064 and generate_perl_xs () =
6065   generate_header CStyle LGPLv2;
6066
6067   pr "\
6068 #include \"EXTERN.h\"
6069 #include \"perl.h\"
6070 #include \"XSUB.h\"
6071
6072 #include <guestfs.h>
6073
6074 #ifndef PRId64
6075 #define PRId64 \"lld\"
6076 #endif
6077
6078 static SV *
6079 my_newSVll(long long val) {
6080 #ifdef USE_64_BIT_ALL
6081   return newSViv(val);
6082 #else
6083   char buf[100];
6084   int len;
6085   len = snprintf(buf, 100, \"%%\" PRId64, val);
6086   return newSVpv(buf, len);
6087 #endif
6088 }
6089
6090 #ifndef PRIu64
6091 #define PRIu64 \"llu\"
6092 #endif
6093
6094 static SV *
6095 my_newSVull(unsigned long long val) {
6096 #ifdef USE_64_BIT_ALL
6097   return newSVuv(val);
6098 #else
6099   char buf[100];
6100   int len;
6101   len = snprintf(buf, 100, \"%%\" PRIu64, val);
6102   return newSVpv(buf, len);
6103 #endif
6104 }
6105
6106 /* http://www.perlmonks.org/?node_id=680842 */
6107 static char **
6108 XS_unpack_charPtrPtr (SV *arg) {
6109   char **ret;
6110   AV *av;
6111   I32 i;
6112
6113   if (!arg || !SvOK (arg) || !SvROK (arg) || SvTYPE (SvRV (arg)) != SVt_PVAV)
6114     croak (\"array reference expected\");
6115
6116   av = (AV *)SvRV (arg);
6117   ret = malloc ((av_len (av) + 1 + 1) * sizeof (char *));
6118   if (!ret)
6119     croak (\"malloc failed\");
6120
6121   for (i = 0; i <= av_len (av); i++) {
6122     SV **elem = av_fetch (av, i, 0);
6123
6124     if (!elem || !*elem)
6125       croak (\"missing element in list\");
6126
6127     ret[i] = SvPV_nolen (*elem);
6128   }
6129
6130   ret[i] = NULL;
6131
6132   return ret;
6133 }
6134
6135 MODULE = Sys::Guestfs  PACKAGE = Sys::Guestfs
6136
6137 PROTOTYPES: ENABLE
6138
6139 guestfs_h *
6140 _create ()
6141    CODE:
6142       RETVAL = guestfs_create ();
6143       if (!RETVAL)
6144         croak (\"could not create guestfs handle\");
6145       guestfs_set_error_handler (RETVAL, NULL, NULL);
6146  OUTPUT:
6147       RETVAL
6148
6149 void
6150 DESTROY (g)
6151       guestfs_h *g;
6152  PPCODE:
6153       guestfs_close (g);
6154
6155 ";
6156
6157   List.iter (
6158     fun (name, style, _, _, _, _, _) ->
6159       (match fst style with
6160        | RErr -> pr "void\n"
6161        | RInt _ -> pr "SV *\n"
6162        | RInt64 _ -> pr "SV *\n"
6163        | RBool _ -> pr "SV *\n"
6164        | RConstString _ -> pr "SV *\n"
6165        | RString _ -> pr "SV *\n"
6166        | RStringList _
6167        | RStruct _ | RStructList _
6168        | RHashtable _ ->
6169            pr "void\n" (* all lists returned implictly on the stack *)
6170       );
6171       (* Call and arguments. *)
6172       pr "%s " name;
6173       generate_call_args ~handle:"g" (snd style);
6174       pr "\n";
6175       pr "      guestfs_h *g;\n";
6176       iteri (
6177         fun i ->
6178           function
6179           | String n | FileIn n | FileOut n -> pr "      char *%s;\n" n
6180           | OptString n ->
6181               (* http://www.perlmonks.org/?node_id=554277
6182                * Note that the implicit handle argument means we have
6183                * to add 1 to the ST(x) operator.
6184                *)
6185               pr "      char *%s = SvOK(ST(%d)) ? SvPV_nolen(ST(%d)) : NULL;\n" n (i+1) (i+1)
6186           | StringList n -> pr "      char **%s;\n" n
6187           | Bool n -> pr "      int %s;\n" n
6188           | Int n -> pr "      int %s;\n" n
6189       ) (snd style);
6190
6191       let do_cleanups () =
6192         List.iter (
6193           function
6194           | String _ | OptString _ | Bool _ | Int _
6195           | FileIn _ | FileOut _ -> ()
6196           | StringList n -> pr "      free (%s);\n" n
6197         ) (snd style)
6198       in
6199
6200       (* Code. *)
6201       (match fst style with
6202        | RErr ->
6203            pr "PREINIT:\n";
6204            pr "      int r;\n";
6205            pr " PPCODE:\n";
6206            pr "      r = guestfs_%s " name;
6207            generate_call_args ~handle:"g" (snd style);
6208            pr ";\n";
6209            do_cleanups ();
6210            pr "      if (r == -1)\n";
6211            pr "        croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
6212        | RInt n
6213        | RBool n ->
6214            pr "PREINIT:\n";
6215            pr "      int %s;\n" n;
6216            pr "   CODE:\n";
6217            pr "      %s = guestfs_%s " n name;
6218            generate_call_args ~handle:"g" (snd style);
6219            pr ";\n";
6220            do_cleanups ();
6221            pr "      if (%s == -1)\n" n;
6222            pr "        croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
6223            pr "      RETVAL = newSViv (%s);\n" n;
6224            pr " OUTPUT:\n";
6225            pr "      RETVAL\n"
6226        | RInt64 n ->
6227            pr "PREINIT:\n";
6228            pr "      int64_t %s;\n" n;
6229            pr "   CODE:\n";
6230            pr "      %s = guestfs_%s " n name;
6231            generate_call_args ~handle:"g" (snd style);
6232            pr ";\n";
6233            do_cleanups ();
6234            pr "      if (%s == -1)\n" n;
6235            pr "        croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
6236            pr "      RETVAL = my_newSVll (%s);\n" n;
6237            pr " OUTPUT:\n";
6238            pr "      RETVAL\n"
6239        | RConstString n ->
6240            pr "PREINIT:\n";
6241            pr "      const char *%s;\n" n;
6242            pr "   CODE:\n";
6243            pr "      %s = guestfs_%s " n name;
6244            generate_call_args ~handle:"g" (snd style);
6245            pr ";\n";
6246            do_cleanups ();
6247            pr "      if (%s == NULL)\n" n;
6248            pr "        croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
6249            pr "      RETVAL = newSVpv (%s, 0);\n" n;
6250            pr " OUTPUT:\n";
6251            pr "      RETVAL\n"
6252        | RString n ->
6253            pr "PREINIT:\n";
6254            pr "      char *%s;\n" n;
6255            pr "   CODE:\n";
6256            pr "      %s = guestfs_%s " n name;
6257            generate_call_args ~handle:"g" (snd style);
6258            pr ";\n";
6259            do_cleanups ();
6260            pr "      if (%s == NULL)\n" n;
6261            pr "        croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
6262            pr "      RETVAL = newSVpv (%s, 0);\n" n;
6263            pr "      free (%s);\n" n;
6264            pr " OUTPUT:\n";
6265            pr "      RETVAL\n"
6266        | RStringList n | RHashtable n ->
6267            pr "PREINIT:\n";
6268            pr "      char **%s;\n" n;
6269            pr "      int i, n;\n";
6270            pr " PPCODE:\n";
6271            pr "      %s = guestfs_%s " n name;
6272            generate_call_args ~handle:"g" (snd style);
6273            pr ";\n";
6274            do_cleanups ();
6275            pr "      if (%s == NULL)\n" n;
6276            pr "        croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
6277            pr "      for (n = 0; %s[n] != NULL; ++n) /**/;\n" n;
6278            pr "      EXTEND (SP, n);\n";
6279            pr "      for (i = 0; i < n; ++i) {\n";
6280            pr "        PUSHs (sv_2mortal (newSVpv (%s[i], 0)));\n" n;
6281            pr "        free (%s[i]);\n" n;
6282            pr "      }\n";
6283            pr "      free (%s);\n" n;
6284        | RStruct (n, typ) ->
6285            let cols = cols_of_struct typ in
6286            generate_perl_struct_code typ cols name style n do_cleanups
6287        | RStructList (n, typ) ->
6288            let cols = cols_of_struct typ in
6289            generate_perl_struct_list_code typ cols name style n do_cleanups
6290       );
6291
6292       pr "\n"
6293   ) all_functions
6294
6295 and generate_perl_struct_list_code typ cols name style n do_cleanups =
6296   pr "PREINIT:\n";
6297   pr "      struct guestfs_%s_list *%s;\n" typ n;
6298   pr "      int i;\n";
6299   pr "      HV *hv;\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, %s->len);\n" n;
6308   pr "      for (i = 0; i < %s->len; ++i) {\n" n;
6309   pr "        hv = newHV ();\n";
6310   List.iter (
6311     function
6312     | name, FString ->
6313         pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (%s->val[i].%s, 0), 0);\n"
6314           name (String.length name) n name
6315     | name, FUUID ->
6316         pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (%s->val[i].%s, 32), 0);\n"
6317           name (String.length name) n name
6318     | name, FBuffer ->
6319         pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (%s->val[i].%s, %s->val[i].%s_len), 0);\n"
6320           name (String.length name) n name n name
6321     | name, (FBytes|FUInt64) ->
6322         pr "        (void) hv_store (hv, \"%s\", %d, my_newSVull (%s->val[i].%s), 0);\n"
6323           name (String.length name) n name
6324     | name, FInt64 ->
6325         pr "        (void) hv_store (hv, \"%s\", %d, my_newSVll (%s->val[i].%s), 0);\n"
6326           name (String.length name) n name
6327     | name, (FInt32|FUInt32) ->
6328         pr "        (void) hv_store (hv, \"%s\", %d, newSVnv (%s->val[i].%s), 0);\n"
6329           name (String.length name) n name
6330     | name, FChar ->
6331         pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (&%s->val[i].%s, 1), 0);\n"
6332           name (String.length name) n name
6333     | name, FOptPercent ->
6334         pr "        (void) hv_store (hv, \"%s\", %d, newSVnv (%s->val[i].%s), 0);\n"
6335           name (String.length name) n name
6336   ) cols;
6337   pr "        PUSHs (sv_2mortal (newRV ((SV *) hv)));\n";
6338   pr "      }\n";
6339   pr "      guestfs_free_%s_list (%s);\n" typ n
6340
6341 and generate_perl_struct_code typ cols name style n do_cleanups =
6342   pr "PREINIT:\n";
6343   pr "      struct guestfs_%s *%s;\n" typ n;
6344   pr " PPCODE:\n";
6345   pr "      %s = guestfs_%s " n name;
6346   generate_call_args ~handle:"g" (snd style);
6347   pr ";\n";
6348   do_cleanups ();
6349   pr "      if (%s == NULL)\n" n;
6350   pr "        croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
6351   pr "      EXTEND (SP, 2 * %d);\n" (List.length cols);
6352   List.iter (
6353     fun ((name, _) as col) ->
6354       pr "      PUSHs (sv_2mortal (newSVpv (\"%s\", 0)));\n" name;
6355
6356       match col with
6357       | name, FString ->
6358           pr "      PUSHs (sv_2mortal (newSVpv (%s->%s, 0)));\n"
6359             n name
6360       | name, FBuffer ->
6361           pr "      PUSHs (sv_2mortal (newSVpv (%s->%s, %s->%s_len)));\n"
6362             n name n name
6363       | name, FUUID ->
6364           pr "      PUSHs (sv_2mortal (newSVpv (%s->%s, 32)));\n"
6365             n name
6366       | name, (FBytes|FUInt64) ->
6367           pr "      PUSHs (sv_2mortal (my_newSVull (%s->%s)));\n"
6368             n name
6369       | name, FInt64 ->
6370           pr "      PUSHs (sv_2mortal (my_newSVll (%s->%s)));\n"
6371             n name
6372       | name, (FInt32|FUInt32) ->
6373           pr "      PUSHs (sv_2mortal (newSVnv (%s->%s)));\n"
6374             n name
6375       | name, FChar ->
6376           pr "      PUSHs (sv_2mortal (newSVpv (&%s->%s, 1)));\n"
6377             n name
6378       | name, FOptPercent ->
6379           pr "      PUSHs (sv_2mortal (newSVnv (%s->%s)));\n"
6380             n name
6381   ) cols;
6382   pr "      free (%s);\n" n
6383
6384 (* Generate Sys/Guestfs.pm. *)
6385 and generate_perl_pm () =
6386   generate_header HashStyle LGPLv2;
6387
6388   pr "\
6389 =pod
6390
6391 =head1 NAME
6392
6393 Sys::Guestfs - Perl bindings for libguestfs
6394
6395 =head1 SYNOPSIS
6396
6397  use Sys::Guestfs;
6398
6399  my $h = Sys::Guestfs->new ();
6400  $h->add_drive ('guest.img');
6401  $h->launch ();
6402  $h->wait_ready ();
6403  $h->mount ('/dev/sda1', '/');
6404  $h->touch ('/hello');
6405  $h->sync ();
6406
6407 =head1 DESCRIPTION
6408
6409 The C<Sys::Guestfs> module provides a Perl XS binding to the
6410 libguestfs API for examining and modifying virtual machine
6411 disk images.
6412
6413 Amongst the things this is good for: making batch configuration
6414 changes to guests, getting disk used/free statistics (see also:
6415 virt-df), migrating between virtualization systems (see also:
6416 virt-p2v), performing partial backups, performing partial guest
6417 clones, cloning guests and changing registry/UUID/hostname info, and
6418 much else besides.
6419
6420 Libguestfs uses Linux kernel and qemu code, and can access any type of
6421 guest filesystem that Linux and qemu can, including but not limited
6422 to: ext2/3/4, btrfs, FAT and NTFS, LVM, many different disk partition
6423 schemes, qcow, qcow2, vmdk.
6424
6425 Libguestfs provides ways to enumerate guest storage (eg. partitions,
6426 LVs, what filesystem is in each LV, etc.).  It can also run commands
6427 in the context of the guest.  Also you can access filesystems over FTP.
6428
6429 See also L<Sys::Guestfs::Lib(3)> for a set of useful library
6430 functions for using libguestfs from Perl, including integration
6431 with libvirt.
6432
6433 =head1 ERRORS
6434
6435 All errors turn into calls to C<croak> (see L<Carp(3)>).
6436
6437 =head1 METHODS
6438
6439 =over 4
6440
6441 =cut
6442
6443 package Sys::Guestfs;
6444
6445 use strict;
6446 use warnings;
6447
6448 require XSLoader;
6449 XSLoader::load ('Sys::Guestfs');
6450
6451 =item $h = Sys::Guestfs->new ();
6452
6453 Create a new guestfs handle.
6454
6455 =cut
6456
6457 sub new {
6458   my $proto = shift;
6459   my $class = ref ($proto) || $proto;
6460
6461   my $self = Sys::Guestfs::_create ();
6462   bless $self, $class;
6463   return $self;
6464 }
6465
6466 ";
6467
6468   (* Actions.  We only need to print documentation for these as
6469    * they are pulled in from the XS code automatically.
6470    *)
6471   List.iter (
6472     fun (name, style, _, flags, _, _, longdesc) ->
6473       if not (List.mem NotInDocs flags) then (
6474         let longdesc = replace_str longdesc "C<guestfs_" "C<$h-E<gt>" in
6475         pr "=item ";
6476         generate_perl_prototype name style;
6477         pr "\n\n";
6478         pr "%s\n\n" longdesc;
6479         if List.mem ProtocolLimitWarning flags then
6480           pr "%s\n\n" protocol_limit_warning;
6481         if List.mem DangerWillRobinson flags then
6482           pr "%s\n\n" danger_will_robinson
6483       )
6484   ) all_functions_sorted;
6485
6486   (* End of file. *)
6487   pr "\
6488 =cut
6489
6490 1;
6491
6492 =back
6493
6494 =head1 COPYRIGHT
6495
6496 Copyright (C) 2009 Red Hat Inc.
6497
6498 =head1 LICENSE
6499
6500 Please see the file COPYING.LIB for the full license.
6501
6502 =head1 SEE ALSO
6503
6504 L<guestfs(3)>,
6505 L<guestfish(1)>,
6506 L<http://libguestfs.org>,
6507 L<Sys::Guestfs::Lib(3)>.
6508
6509 =cut
6510 "
6511
6512 and generate_perl_prototype name style =
6513   (match fst style with
6514    | RErr -> ()
6515    | RBool n
6516    | RInt n
6517    | RInt64 n
6518    | RConstString n
6519    | RString n -> pr "$%s = " n
6520    | RStruct (n,_)
6521    | RHashtable n -> pr "%%%s = " n
6522    | RStringList n
6523    | RStructList (n,_) -> pr "@%s = " n
6524   );
6525   pr "$h->%s (" name;
6526   let comma = ref false in
6527   List.iter (
6528     fun arg ->
6529       if !comma then pr ", ";
6530       comma := true;
6531       match arg with
6532       | String n | OptString n | Bool n | Int n | FileIn n | FileOut n ->
6533           pr "$%s" n
6534       | StringList n ->
6535           pr "\\@%s" n
6536   ) (snd style);
6537   pr ");"
6538
6539 (* Generate Python C module. *)
6540 and generate_python_c () =
6541   generate_header CStyle LGPLv2;
6542
6543   pr "\
6544 #include <stdio.h>
6545 #include <stdlib.h>
6546 #include <assert.h>
6547
6548 #include <Python.h>
6549
6550 #include \"guestfs.h\"
6551
6552 typedef struct {
6553   PyObject_HEAD
6554   guestfs_h *g;
6555 } Pyguestfs_Object;
6556
6557 static guestfs_h *
6558 get_handle (PyObject *obj)
6559 {
6560   assert (obj);
6561   assert (obj != Py_None);
6562   return ((Pyguestfs_Object *) obj)->g;
6563 }
6564
6565 static PyObject *
6566 put_handle (guestfs_h *g)
6567 {
6568   assert (g);
6569   return
6570     PyCObject_FromVoidPtrAndDesc ((void *) g, (char *) \"guestfs_h\", NULL);
6571 }
6572
6573 /* This list should be freed (but not the strings) after use. */
6574 static const char **
6575 get_string_list (PyObject *obj)
6576 {
6577   int i, len;
6578   const char **r;
6579
6580   assert (obj);
6581
6582   if (!PyList_Check (obj)) {
6583     PyErr_SetString (PyExc_RuntimeError, \"expecting a list parameter\");
6584     return NULL;
6585   }
6586
6587   len = PyList_Size (obj);
6588   r = malloc (sizeof (char *) * (len+1));
6589   if (r == NULL) {
6590     PyErr_SetString (PyExc_RuntimeError, \"get_string_list: out of memory\");
6591     return NULL;
6592   }
6593
6594   for (i = 0; i < len; ++i)
6595     r[i] = PyString_AsString (PyList_GetItem (obj, i));
6596   r[len] = NULL;
6597
6598   return r;
6599 }
6600
6601 static PyObject *
6602 put_string_list (char * const * const argv)
6603 {
6604   PyObject *list;
6605   int argc, i;
6606
6607   for (argc = 0; argv[argc] != NULL; ++argc)
6608     ;
6609
6610   list = PyList_New (argc);
6611   for (i = 0; i < argc; ++i)
6612     PyList_SetItem (list, i, PyString_FromString (argv[i]));
6613
6614   return list;
6615 }
6616
6617 static PyObject *
6618 put_table (char * const * const argv)
6619 {
6620   PyObject *list, *item;
6621   int argc, i;
6622
6623   for (argc = 0; argv[argc] != NULL; ++argc)
6624     ;
6625
6626   list = PyList_New (argc >> 1);
6627   for (i = 0; i < argc; i += 2) {
6628     item = PyTuple_New (2);
6629     PyTuple_SetItem (item, 0, PyString_FromString (argv[i]));
6630     PyTuple_SetItem (item, 1, PyString_FromString (argv[i+1]));
6631     PyList_SetItem (list, i >> 1, item);
6632   }
6633
6634   return list;
6635 }
6636
6637 static void
6638 free_strings (char **argv)
6639 {
6640   int argc;
6641
6642   for (argc = 0; argv[argc] != NULL; ++argc)
6643     free (argv[argc]);
6644   free (argv);
6645 }
6646
6647 static PyObject *
6648 py_guestfs_create (PyObject *self, PyObject *args)
6649 {
6650   guestfs_h *g;
6651
6652   g = guestfs_create ();
6653   if (g == NULL) {
6654     PyErr_SetString (PyExc_RuntimeError,
6655                      \"guestfs.create: failed to allocate handle\");
6656     return NULL;
6657   }
6658   guestfs_set_error_handler (g, NULL, NULL);
6659   return put_handle (g);
6660 }
6661
6662 static PyObject *
6663 py_guestfs_close (PyObject *self, PyObject *args)
6664 {
6665   PyObject *py_g;
6666   guestfs_h *g;
6667
6668   if (!PyArg_ParseTuple (args, (char *) \"O:guestfs_close\", &py_g))
6669     return NULL;
6670   g = get_handle (py_g);
6671
6672   guestfs_close (g);
6673
6674   Py_INCREF (Py_None);
6675   return Py_None;
6676 }
6677
6678 ";
6679
6680   (* Structures, turned into Python dictionaries. *)
6681   List.iter (
6682     fun (typ, cols) ->
6683       pr "static PyObject *\n";
6684       pr "put_%s (struct guestfs_%s *%s)\n" typ typ typ;
6685       pr "{\n";
6686       pr "  PyObject *dict;\n";
6687       pr "\n";
6688       pr "  dict = PyDict_New ();\n";
6689       List.iter (
6690         function
6691         | name, FString ->
6692             pr "  PyDict_SetItemString (dict, \"%s\",\n" name;
6693             pr "                        PyString_FromString (%s->%s));\n"
6694               typ name
6695         | name, FBuffer ->
6696             pr "  PyDict_SetItemString (dict, \"%s\",\n" name;
6697             pr "                        PyString_FromStringAndSize (%s->%s, %s->%s_len));\n"
6698               typ name typ name
6699         | name, FUUID ->
6700             pr "  PyDict_SetItemString (dict, \"%s\",\n" name;
6701             pr "                        PyString_FromStringAndSize (%s->%s, 32));\n"
6702               typ name
6703         | name, (FBytes|FUInt64) ->
6704             pr "  PyDict_SetItemString (dict, \"%s\",\n" name;
6705             pr "                        PyLong_FromUnsignedLongLong (%s->%s));\n"
6706               typ name
6707         | name, FInt64 ->
6708             pr "  PyDict_SetItemString (dict, \"%s\",\n" name;
6709             pr "                        PyLong_FromLongLong (%s->%s));\n"
6710               typ name
6711         | name, FUInt32 ->
6712             pr "  PyDict_SetItemString (dict, \"%s\",\n" name;
6713             pr "                        PyLong_FromUnsignedLong (%s->%s));\n"
6714               typ name
6715         | name, FInt32 ->
6716             pr "  PyDict_SetItemString (dict, \"%s\",\n" name;
6717             pr "                        PyLong_FromLong (%s->%s));\n"
6718               typ name
6719         | name, FOptPercent ->
6720             pr "  if (%s->%s >= 0)\n" typ name;
6721             pr "    PyDict_SetItemString (dict, \"%s\",\n" name;
6722             pr "                          PyFloat_FromDouble ((double) %s->%s));\n"
6723               typ name;
6724             pr "  else {\n";
6725             pr "    Py_INCREF (Py_None);\n";
6726             pr "    PyDict_SetItemString (dict, \"%s\", Py_None);" name;
6727             pr "  }\n"
6728         | name, FChar ->
6729             pr "  PyDict_SetItemString (dict, \"%s\",\n" name;
6730             pr "                        PyString_FromStringAndSize (&dirent->%s, 1));\n" name
6731       ) cols;
6732       pr "  return dict;\n";
6733       pr "};\n";
6734       pr "\n";
6735
6736       pr "static PyObject *\n";
6737       pr "put_%s_list (struct guestfs_%s_list *%ss)\n" typ typ typ;
6738       pr "{\n";
6739       pr "  PyObject *list;\n";
6740       pr "  int i;\n";
6741       pr "\n";
6742       pr "  list = PyList_New (%ss->len);\n" typ;
6743       pr "  for (i = 0; i < %ss->len; ++i)\n" typ;
6744       pr "    PyList_SetItem (list, i, put_%s (&%ss->val[i]));\n" typ typ;
6745       pr "  return list;\n";
6746       pr "};\n";
6747       pr "\n"
6748   ) structs;
6749
6750   (* Python wrapper functions. *)
6751   List.iter (
6752     fun (name, style, _, _, _, _, _) ->
6753       pr "static PyObject *\n";
6754       pr "py_guestfs_%s (PyObject *self, PyObject *args)\n" name;
6755       pr "{\n";
6756
6757       pr "  PyObject *py_g;\n";
6758       pr "  guestfs_h *g;\n";
6759       pr "  PyObject *py_r;\n";
6760
6761       let error_code =
6762         match fst style with
6763         | RErr | RInt _ | RBool _ -> pr "  int r;\n"; "-1"
6764         | RInt64 _ -> pr "  int64_t r;\n"; "-1"
6765         | RConstString _ -> pr "  const char *r;\n"; "NULL"
6766         | RString _ -> pr "  char *r;\n"; "NULL"
6767         | RStringList _ | RHashtable _ -> pr "  char **r;\n"; "NULL"
6768         | RStruct (_, typ) -> pr "  struct guestfs_%s *r;\n" typ; "NULL"
6769         | RStructList (_, typ) ->
6770             pr "  struct guestfs_%s_list *r;\n" typ; "NULL" in
6771
6772       List.iter (
6773         function
6774         | String n | FileIn n | FileOut n -> pr "  const char *%s;\n" n
6775         | OptString n -> pr "  const char *%s;\n" n
6776         | StringList n ->
6777             pr "  PyObject *py_%s;\n" n;
6778             pr "  const char **%s;\n" n
6779         | Bool n -> pr "  int %s;\n" n
6780         | Int n -> pr "  int %s;\n" n
6781       ) (snd style);
6782
6783       pr "\n";
6784
6785       (* Convert the parameters. *)
6786       pr "  if (!PyArg_ParseTuple (args, (char *) \"O";
6787       List.iter (
6788         function
6789         | String _ | FileIn _ | FileOut _ -> pr "s"
6790         | OptString _ -> pr "z"
6791         | StringList _ -> pr "O"
6792         | Bool _ -> pr "i" (* XXX Python has booleans? *)
6793         | Int _ -> pr "i"
6794       ) (snd style);
6795       pr ":guestfs_%s\",\n" name;
6796       pr "                         &py_g";
6797       List.iter (
6798         function
6799         | String n | FileIn n | FileOut n -> pr ", &%s" n
6800         | OptString n -> pr ", &%s" n
6801         | StringList n -> pr ", &py_%s" n
6802         | Bool n -> pr ", &%s" n
6803         | Int n -> pr ", &%s" n
6804       ) (snd style);
6805
6806       pr "))\n";
6807       pr "    return NULL;\n";
6808
6809       pr "  g = get_handle (py_g);\n";
6810       List.iter (
6811         function
6812         | String _ | FileIn _ | FileOut _ | OptString _ | Bool _ | Int _ -> ()
6813         | StringList n ->
6814             pr "  %s = get_string_list (py_%s);\n" n n;
6815             pr "  if (!%s) return NULL;\n" n
6816       ) (snd style);
6817
6818       pr "\n";
6819
6820       pr "  r = guestfs_%s " name;
6821       generate_call_args ~handle:"g" (snd style);
6822       pr ";\n";
6823
6824       List.iter (
6825         function
6826         | String _ | FileIn _ | FileOut _ | OptString _ | Bool _ | Int _ -> ()
6827         | StringList n ->
6828             pr "  free (%s);\n" n
6829       ) (snd style);
6830
6831       pr "  if (r == %s) {\n" error_code;
6832       pr "    PyErr_SetString (PyExc_RuntimeError, guestfs_last_error (g));\n";
6833       pr "    return NULL;\n";
6834       pr "  }\n";
6835       pr "\n";
6836
6837       (match fst style with
6838        | RErr ->
6839            pr "  Py_INCREF (Py_None);\n";
6840            pr "  py_r = Py_None;\n"
6841        | RInt _
6842        | RBool _ -> pr "  py_r = PyInt_FromLong ((long) r);\n"
6843        | RInt64 _ -> pr "  py_r = PyLong_FromLongLong (r);\n"
6844        | RConstString _ -> pr "  py_r = PyString_FromString (r);\n"
6845        | RString _ ->
6846            pr "  py_r = PyString_FromString (r);\n";
6847            pr "  free (r);\n"
6848        | RStringList _ ->
6849            pr "  py_r = put_string_list (r);\n";
6850            pr "  free_strings (r);\n"
6851        | RStruct (_, typ) ->
6852            pr "  py_r = put_%s (r);\n" typ;
6853            pr "  guestfs_free_%s (r);\n" typ
6854        | RStructList (_, typ) ->
6855            pr "  py_r = put_%s_list (r);\n" typ;
6856            pr "  guestfs_free_%s_list (r);\n" typ
6857        | RHashtable n ->
6858            pr "  py_r = put_table (r);\n";
6859            pr "  free_strings (r);\n"
6860       );
6861
6862       pr "  return py_r;\n";
6863       pr "}\n";
6864       pr "\n"
6865   ) all_functions;
6866
6867   (* Table of functions. *)
6868   pr "static PyMethodDef methods[] = {\n";
6869   pr "  { (char *) \"create\", py_guestfs_create, METH_VARARGS, NULL },\n";
6870   pr "  { (char *) \"close\", py_guestfs_close, METH_VARARGS, NULL },\n";
6871   List.iter (
6872     fun (name, _, _, _, _, _, _) ->
6873       pr "  { (char *) \"%s\", py_guestfs_%s, METH_VARARGS, NULL },\n"
6874         name name
6875   ) all_functions;
6876   pr "  { NULL, NULL, 0, NULL }\n";
6877   pr "};\n";
6878   pr "\n";
6879
6880   (* Init function. *)
6881   pr "\
6882 void
6883 initlibguestfsmod (void)
6884 {
6885   static int initialized = 0;
6886
6887   if (initialized) return;
6888   Py_InitModule ((char *) \"libguestfsmod\", methods);
6889   initialized = 1;
6890 }
6891 "
6892
6893 (* Generate Python module. *)
6894 and generate_python_py () =
6895   generate_header HashStyle LGPLv2;
6896
6897   pr "\
6898 u\"\"\"Python bindings for libguestfs
6899
6900 import guestfs
6901 g = guestfs.GuestFS ()
6902 g.add_drive (\"guest.img\")
6903 g.launch ()
6904 g.wait_ready ()
6905 parts = g.list_partitions ()
6906
6907 The guestfs module provides a Python binding to the libguestfs API
6908 for examining and modifying virtual machine disk images.
6909
6910 Amongst the things this is good for: making batch configuration
6911 changes to guests, getting disk used/free statistics (see also:
6912 virt-df), migrating between virtualization systems (see also:
6913 virt-p2v), performing partial backups, performing partial guest
6914 clones, cloning guests and changing registry/UUID/hostname info, and
6915 much else besides.
6916
6917 Libguestfs uses Linux kernel and qemu code, and can access any type of
6918 guest filesystem that Linux and qemu can, including but not limited
6919 to: ext2/3/4, btrfs, FAT and NTFS, LVM, many different disk partition
6920 schemes, qcow, qcow2, vmdk.
6921
6922 Libguestfs provides ways to enumerate guest storage (eg. partitions,
6923 LVs, what filesystem is in each LV, etc.).  It can also run commands
6924 in the context of the guest.  Also you can access filesystems over FTP.
6925
6926 Errors which happen while using the API are turned into Python
6927 RuntimeError exceptions.
6928
6929 To create a guestfs handle you usually have to perform the following
6930 sequence of calls:
6931
6932 # Create the handle, call add_drive at least once, and possibly
6933 # several times if the guest has multiple block devices:
6934 g = guestfs.GuestFS ()
6935 g.add_drive (\"guest.img\")
6936
6937 # Launch the qemu subprocess and wait for it to become ready:
6938 g.launch ()
6939 g.wait_ready ()
6940
6941 # Now you can issue commands, for example:
6942 logvols = g.lvs ()
6943
6944 \"\"\"
6945
6946 import libguestfsmod
6947
6948 class GuestFS:
6949     \"\"\"Instances of this class are libguestfs API handles.\"\"\"
6950
6951     def __init__ (self):
6952         \"\"\"Create a new libguestfs handle.\"\"\"
6953         self._o = libguestfsmod.create ()
6954
6955     def __del__ (self):
6956         libguestfsmod.close (self._o)
6957
6958 ";
6959
6960   List.iter (
6961     fun (name, style, _, flags, _, _, longdesc) ->
6962       pr "    def %s " name;
6963       generate_call_args ~handle:"self" (snd style);
6964       pr ":\n";
6965
6966       if not (List.mem NotInDocs flags) then (
6967         let doc = replace_str longdesc "C<guestfs_" "C<g." in
6968         let doc =
6969           match fst style with
6970           | RErr | RInt _ | RInt64 _ | RBool _ | RConstString _
6971           | RString _ -> doc
6972           | RStringList _ ->
6973               doc ^ "\n\nThis function returns a list of strings."
6974           | RStruct (_, typ) ->
6975               doc ^ sprintf "\n\nThis function returns a dictionary, with keys matching the various fields in the guestfs_%s structure." typ
6976           | RStructList (_, typ) ->
6977               doc ^ sprintf "\n\nThis function returns a list of %ss.  Each %s is represented as a dictionary." typ typ
6978           | RHashtable _ ->
6979               doc ^ "\n\nThis function returns a dictionary." in
6980         let doc =
6981           if List.mem ProtocolLimitWarning flags then
6982             doc ^ "\n\n" ^ protocol_limit_warning
6983           else doc in
6984         let doc =
6985           if List.mem DangerWillRobinson flags then
6986             doc ^ "\n\n" ^ danger_will_robinson
6987           else doc in
6988         let doc = pod2text ~width:60 name doc in
6989         let doc = List.map (fun line -> replace_str line "\\" "\\\\") doc in
6990         let doc = String.concat "\n        " doc in
6991         pr "        u\"\"\"%s\"\"\"\n" doc;
6992       );
6993       pr "        return libguestfsmod.%s " name;
6994       generate_call_args ~handle:"self._o" (snd style);
6995       pr "\n";
6996       pr "\n";
6997   ) all_functions
6998
6999 (* Useful if you need the longdesc POD text as plain text.  Returns a
7000  * list of lines.
7001  *
7002  * Because this is very slow (the slowest part of autogeneration),
7003  * we memoize the results.
7004  *)
7005 and pod2text ~width name longdesc =
7006   let key = width, name, longdesc in
7007   try Hashtbl.find pod2text_memo key
7008   with Not_found ->
7009     let filename, chan = Filename.open_temp_file "gen" ".tmp" in
7010     fprintf chan "=head1 %s\n\n%s\n" name longdesc;
7011     close_out chan;
7012     let cmd = sprintf "pod2text -w %d %s" width (Filename.quote filename) in
7013     let chan = Unix.open_process_in cmd in
7014     let lines = ref [] in
7015     let rec loop i =
7016       let line = input_line chan in
7017       if i = 1 then             (* discard the first line of output *)
7018         loop (i+1)
7019       else (
7020         let line = triml line in
7021         lines := line :: !lines;
7022         loop (i+1)
7023       ) in
7024     let lines = try loop 1 with End_of_file -> List.rev !lines in
7025     Unix.unlink filename;
7026     (match Unix.close_process_in chan with
7027      | Unix.WEXITED 0 -> ()
7028      | Unix.WEXITED i ->
7029          failwithf "pod2text: process exited with non-zero status (%d)" i
7030      | Unix.WSIGNALED i | Unix.WSTOPPED i ->
7031          failwithf "pod2text: process signalled or stopped by signal %d" i
7032     );
7033     Hashtbl.add pod2text_memo key lines;
7034     let chan = open_out pod2text_memo_filename in
7035     output_value chan pod2text_memo;
7036     close_out chan;
7037     lines
7038
7039 (* Generate ruby bindings. *)
7040 and generate_ruby_c () =
7041   generate_header CStyle LGPLv2;
7042
7043   pr "\
7044 #include <stdio.h>
7045 #include <stdlib.h>
7046
7047 #include <ruby.h>
7048
7049 #include \"guestfs.h\"
7050
7051 #include \"extconf.h\"
7052
7053 /* For Ruby < 1.9 */
7054 #ifndef RARRAY_LEN
7055 #define RARRAY_LEN(r) (RARRAY((r))->len)
7056 #endif
7057
7058 static VALUE m_guestfs;                 /* guestfs module */
7059 static VALUE c_guestfs;                 /* guestfs_h handle */
7060 static VALUE e_Error;                   /* used for all errors */
7061
7062 static void ruby_guestfs_free (void *p)
7063 {
7064   if (!p) return;
7065   guestfs_close ((guestfs_h *) p);
7066 }
7067
7068 static VALUE ruby_guestfs_create (VALUE m)
7069 {
7070   guestfs_h *g;
7071
7072   g = guestfs_create ();
7073   if (!g)
7074     rb_raise (e_Error, \"failed to create guestfs handle\");
7075
7076   /* Don't print error messages to stderr by default. */
7077   guestfs_set_error_handler (g, NULL, NULL);
7078
7079   /* Wrap it, and make sure the close function is called when the
7080    * handle goes away.
7081    */
7082   return Data_Wrap_Struct (c_guestfs, NULL, ruby_guestfs_free, g);
7083 }
7084
7085 static VALUE ruby_guestfs_close (VALUE gv)
7086 {
7087   guestfs_h *g;
7088   Data_Get_Struct (gv, guestfs_h, g);
7089
7090   ruby_guestfs_free (g);
7091   DATA_PTR (gv) = NULL;
7092
7093   return Qnil;
7094 }
7095
7096 ";
7097
7098   List.iter (
7099     fun (name, style, _, _, _, _, _) ->
7100       pr "static VALUE ruby_guestfs_%s (VALUE gv" name;
7101       List.iter (fun arg -> pr ", VALUE %sv" (name_of_argt arg)) (snd style);
7102       pr ")\n";
7103       pr "{\n";
7104       pr "  guestfs_h *g;\n";
7105       pr "  Data_Get_Struct (gv, guestfs_h, g);\n";
7106       pr "  if (!g)\n";
7107       pr "    rb_raise (rb_eArgError, \"%%s: used handle after closing it\", \"%s\");\n"
7108         name;
7109       pr "\n";
7110
7111       List.iter (
7112         function
7113         | String n | FileIn n | FileOut n ->
7114             pr "  Check_Type (%sv, T_STRING);\n" n;
7115             pr "  const char *%s = StringValueCStr (%sv);\n" n n;
7116             pr "  if (!%s)\n" n;
7117             pr "    rb_raise (rb_eTypeError, \"expected string for parameter %%s of %%s\",\n";
7118             pr "              \"%s\", \"%s\");\n" n name
7119         | OptString n ->
7120             pr "  const char *%s = !NIL_P (%sv) ? StringValueCStr (%sv) : NULL;\n" n n n
7121         | StringList n ->
7122             pr "  char **%s;\n" n;
7123             pr "  Check_Type (%sv, T_ARRAY);\n" n;
7124             pr "  {\n";
7125             pr "    int i, len;\n";
7126             pr "    len = RARRAY_LEN (%sv);\n" n;
7127             pr "    %s = guestfs_safe_malloc (g, sizeof (char *) * (len+1));\n"
7128               n;
7129             pr "    for (i = 0; i < len; ++i) {\n";
7130             pr "      VALUE v = rb_ary_entry (%sv, i);\n" n;
7131             pr "      %s[i] = StringValueCStr (v);\n" n;
7132             pr "    }\n";
7133             pr "    %s[len] = NULL;\n" n;
7134             pr "  }\n";
7135         | Bool n ->
7136             pr "  int %s = RTEST (%sv);\n" n n
7137         | Int n ->
7138             pr "  int %s = NUM2INT (%sv);\n" n n
7139       ) (snd style);
7140       pr "\n";
7141
7142       let error_code =
7143         match fst style with
7144         | RErr | RInt _ | RBool _ -> pr "  int r;\n"; "-1"
7145         | RInt64 _ -> pr "  int64_t r;\n"; "-1"
7146         | RConstString _ -> pr "  const char *r;\n"; "NULL"
7147         | RString _ -> pr "  char *r;\n"; "NULL"
7148         | RStringList _ | RHashtable _ -> pr "  char **r;\n"; "NULL"
7149         | RStruct (_, typ) -> pr "  struct guestfs_%s *r;\n" typ; "NULL"
7150         | RStructList (_, typ) ->
7151             pr "  struct guestfs_%s_list *r;\n" typ; "NULL" in
7152       pr "\n";
7153
7154       pr "  r = guestfs_%s " name;
7155       generate_call_args ~handle:"g" (snd style);
7156       pr ";\n";
7157
7158       List.iter (
7159         function
7160         | String _ | FileIn _ | FileOut _ | OptString _ | Bool _ | Int _ -> ()
7161         | StringList n ->
7162             pr "  free (%s);\n" n
7163       ) (snd style);
7164
7165       pr "  if (r == %s)\n" error_code;
7166       pr "    rb_raise (e_Error, \"%%s\", guestfs_last_error (g));\n";
7167       pr "\n";
7168
7169       (match fst style with
7170        | RErr ->
7171            pr "  return Qnil;\n"
7172        | RInt _ | RBool _ ->
7173            pr "  return INT2NUM (r);\n"
7174        | RInt64 _ ->
7175            pr "  return ULL2NUM (r);\n"
7176        | RConstString _ ->
7177            pr "  return rb_str_new2 (r);\n";
7178        | RString _ ->
7179            pr "  VALUE rv = rb_str_new2 (r);\n";
7180            pr "  free (r);\n";
7181            pr "  return rv;\n";
7182        | RStringList _ ->
7183            pr "  int i, len = 0;\n";
7184            pr "  for (i = 0; r[i] != NULL; ++i) len++;\n";
7185            pr "  VALUE rv = rb_ary_new2 (len);\n";
7186            pr "  for (i = 0; r[i] != NULL; ++i) {\n";
7187            pr "    rb_ary_push (rv, rb_str_new2 (r[i]));\n";
7188            pr "    free (r[i]);\n";
7189            pr "  }\n";
7190            pr "  free (r);\n";
7191            pr "  return rv;\n"
7192        | RStruct (_, typ) ->
7193            let cols = cols_of_struct typ in
7194            generate_ruby_struct_code typ cols
7195        | RStructList (_, typ) ->
7196            let cols = cols_of_struct typ in
7197            generate_ruby_struct_list_code typ cols
7198        | RHashtable _ ->
7199            pr "  VALUE rv = rb_hash_new ();\n";
7200            pr "  int i;\n";
7201            pr "  for (i = 0; r[i] != NULL; i+=2) {\n";
7202            pr "    rb_hash_aset (rv, rb_str_new2 (r[i]), rb_str_new2 (r[i+1]));\n";
7203            pr "    free (r[i]);\n";
7204            pr "    free (r[i+1]);\n";
7205            pr "  }\n";
7206            pr "  free (r);\n";
7207            pr "  return rv;\n"
7208       );
7209
7210       pr "}\n";
7211       pr "\n"
7212   ) all_functions;
7213
7214   pr "\
7215 /* Initialize the module. */
7216 void Init__guestfs ()
7217 {
7218   m_guestfs = rb_define_module (\"Guestfs\");
7219   c_guestfs = rb_define_class_under (m_guestfs, \"Guestfs\", rb_cObject);
7220   e_Error = rb_define_class_under (m_guestfs, \"Error\", rb_eStandardError);
7221
7222   rb_define_module_function (m_guestfs, \"create\", ruby_guestfs_create, 0);
7223   rb_define_method (c_guestfs, \"close\", ruby_guestfs_close, 0);
7224
7225 ";
7226   (* Define the rest of the methods. *)
7227   List.iter (
7228     fun (name, style, _, _, _, _, _) ->
7229       pr "  rb_define_method (c_guestfs, \"%s\",\n" name;
7230       pr "        ruby_guestfs_%s, %d);\n" name (List.length (snd style))
7231   ) all_functions;
7232
7233   pr "}\n"
7234
7235 (* Ruby code to return a struct. *)
7236 and generate_ruby_struct_code typ cols =
7237   pr "  VALUE rv = rb_hash_new ();\n";
7238   List.iter (
7239     function
7240     | name, FString ->
7241         pr "  rb_hash_aset (rv, rb_str_new2 (\"%s\"), rb_str_new2 (r->%s));\n" name name
7242     | name, FBuffer ->
7243         pr "  rb_hash_aset (rv, rb_str_new2 (\"%s\"), rb_str_new (r->%s, r->%s_len));\n" name name name
7244     | name, FUUID ->
7245         pr "  rb_hash_aset (rv, rb_str_new2 (\"%s\"), rb_str_new (r->%s, 32));\n" name name
7246     | name, (FBytes|FUInt64) ->
7247         pr "  rb_hash_aset (rv, rb_str_new2 (\"%s\"), ULL2NUM (r->%s));\n" name name
7248     | name, FInt64 ->
7249         pr "  rb_hash_aset (rv, rb_str_new2 (\"%s\"), LL2NUM (r->%s));\n" name name
7250     | name, FUInt32 ->
7251         pr "  rb_hash_aset (rv, rb_str_new2 (\"%s\"), UINT2NUM (r->%s));\n" name name
7252     | name, FInt32 ->
7253         pr "  rb_hash_aset (rv, rb_str_new2 (\"%s\"), INT2NUM (r->%s));\n" name name
7254     | name, FOptPercent ->
7255         pr "  rb_hash_aset (rv, rb_str_new2 (\"%s\"), rb_dbl2big (r->%s));\n" name name
7256     | name, FChar -> (* XXX wrong? *)
7257         pr "  rb_hash_aset (rv, rb_str_new2 (\"%s\"), ULL2NUM (r->%s));\n" name name
7258   ) cols;
7259   pr "  guestfs_free_%s (r);\n" typ;
7260   pr "  return rv;\n"
7261
7262 (* Ruby code to return a struct list. *)
7263 and generate_ruby_struct_list_code typ cols =
7264   pr "  VALUE rv = rb_ary_new2 (r->len);\n";
7265   pr "  int i;\n";
7266   pr "  for (i = 0; i < r->len; ++i) {\n";
7267   pr "    VALUE hv = rb_hash_new ();\n";
7268   List.iter (
7269     function
7270     | name, FString ->
7271         pr "    rb_hash_aset (hv, rb_str_new2 (\"%s\"), rb_str_new2 (r->val[i].%s));\n" name name
7272     | name, FBuffer ->
7273         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
7274     | name, FUUID ->
7275         pr "    rb_hash_aset (hv, rb_str_new2 (\"%s\"), rb_str_new (r->val[i].%s, 32));\n" name name
7276     | name, (FBytes|FUInt64) ->
7277         pr "    rb_hash_aset (hv, rb_str_new2 (\"%s\"), ULL2NUM (r->val[i].%s));\n" name name
7278     | name, FInt64 ->
7279         pr "    rb_hash_aset (hv, rb_str_new2 (\"%s\"), LL2NUM (r->val[i].%s));\n" name name
7280     | name, FUInt32 ->
7281         pr "    rb_hash_aset (hv, rb_str_new2 (\"%s\"), UINT2NUM (r->val[i].%s));\n" name name
7282     | name, FInt32 ->
7283         pr "    rb_hash_aset (hv, rb_str_new2 (\"%s\"), INT2NUM (r->val[i].%s));\n" name name
7284     | name, FOptPercent ->
7285         pr "    rb_hash_aset (hv, rb_str_new2 (\"%s\"), rb_dbl2big (r->val[i].%s));\n" name name
7286     | name, FChar -> (* XXX wrong? *)
7287         pr "    rb_hash_aset (hv, rb_str_new2 (\"%s\"), ULL2NUM (r->val[i].%s));\n" name name
7288   ) cols;
7289   pr "    rb_ary_push (rv, hv);\n";
7290   pr "  }\n";
7291   pr "  guestfs_free_%s_list (r);\n" typ;
7292   pr "  return rv;\n"
7293
7294 (* Generate Java bindings GuestFS.java file. *)
7295 and generate_java_java () =
7296   generate_header CStyle LGPLv2;
7297
7298   pr "\
7299 package com.redhat.et.libguestfs;
7300
7301 import java.util.HashMap;
7302 import com.redhat.et.libguestfs.LibGuestFSException;
7303 import com.redhat.et.libguestfs.PV;
7304 import com.redhat.et.libguestfs.VG;
7305 import com.redhat.et.libguestfs.LV;
7306 import com.redhat.et.libguestfs.Stat;
7307 import com.redhat.et.libguestfs.StatVFS;
7308 import com.redhat.et.libguestfs.IntBool;
7309 import com.redhat.et.libguestfs.Dirent;
7310
7311 /**
7312  * The GuestFS object is a libguestfs handle.
7313  *
7314  * @author rjones
7315  */
7316 public class GuestFS {
7317   // Load the native code.
7318   static {
7319     System.loadLibrary (\"guestfs_jni\");
7320   }
7321
7322   /**
7323    * The native guestfs_h pointer.
7324    */
7325   long g;
7326
7327   /**
7328    * Create a libguestfs handle.
7329    *
7330    * @throws LibGuestFSException
7331    */
7332   public GuestFS () throws LibGuestFSException
7333   {
7334     g = _create ();
7335   }
7336   private native long _create () throws LibGuestFSException;
7337
7338   /**
7339    * Close a libguestfs handle.
7340    *
7341    * You can also leave handles to be collected by the garbage
7342    * collector, but this method ensures that the resources used
7343    * by the handle are freed up immediately.  If you call any
7344    * other methods after closing the handle, you will get an
7345    * exception.
7346    *
7347    * @throws LibGuestFSException
7348    */
7349   public void close () throws LibGuestFSException
7350   {
7351     if (g != 0)
7352       _close (g);
7353     g = 0;
7354   }
7355   private native void _close (long g) throws LibGuestFSException;
7356
7357   public void finalize () throws LibGuestFSException
7358   {
7359     close ();
7360   }
7361
7362 ";
7363
7364   List.iter (
7365     fun (name, style, _, flags, _, shortdesc, longdesc) ->
7366       if not (List.mem NotInDocs flags); then (
7367         let doc = replace_str longdesc "C<guestfs_" "C<g." in
7368         let doc =
7369           if List.mem ProtocolLimitWarning flags then
7370             doc ^ "\n\n" ^ protocol_limit_warning
7371           else doc in
7372         let doc =
7373           if List.mem DangerWillRobinson flags then
7374             doc ^ "\n\n" ^ danger_will_robinson
7375           else doc in
7376         let doc = pod2text ~width:60 name doc in
7377         let doc = List.map (            (* RHBZ#501883 *)
7378           function
7379           | "" -> "<p>"
7380           | nonempty -> nonempty
7381         ) doc in
7382         let doc = String.concat "\n   * " doc in
7383
7384         pr "  /**\n";
7385         pr "   * %s\n" shortdesc;
7386         pr "   * <p>\n";
7387         pr "   * %s\n" doc;
7388         pr "   * @throws LibGuestFSException\n";
7389         pr "   */\n";
7390         pr "  ";
7391       );
7392       generate_java_prototype ~public:true ~semicolon:false name style;
7393       pr "\n";
7394       pr "  {\n";
7395       pr "    if (g == 0)\n";
7396       pr "      throw new LibGuestFSException (\"%s: handle is closed\");\n"
7397         name;
7398       pr "    ";
7399       if fst style <> RErr then pr "return ";
7400       pr "_%s " name;
7401       generate_call_args ~handle:"g" (snd style);
7402       pr ";\n";
7403       pr "  }\n";
7404       pr "  ";
7405       generate_java_prototype ~privat:true ~native:true name style;
7406       pr "\n";
7407       pr "\n";
7408   ) all_functions;
7409
7410   pr "}\n"
7411
7412 and generate_java_prototype ?(public=false) ?(privat=false) ?(native=false)
7413     ?(semicolon=true) name style =
7414   if privat then pr "private ";
7415   if public then pr "public ";
7416   if native then pr "native ";
7417
7418   (* return type *)
7419   (match fst style with
7420    | RErr -> pr "void ";
7421    | RInt _ -> pr "int ";
7422    | RInt64 _ -> pr "long ";
7423    | RBool _ -> pr "boolean ";
7424    | RConstString _ | RString _ -> pr "String ";
7425    | RStringList _ -> pr "String[] ";
7426    | RStruct (_, typ) ->
7427        let name = java_name_of_struct typ in
7428        pr "%s " name;
7429    | RStructList (_, typ) ->
7430        let name = java_name_of_struct typ in
7431        pr "%s[] " name;
7432    | RHashtable _ -> pr "HashMap<String,String> ";
7433   );
7434
7435   if native then pr "_%s " name else pr "%s " name;
7436   pr "(";
7437   let needs_comma = ref false in
7438   if native then (
7439     pr "long g";
7440     needs_comma := true
7441   );
7442
7443   (* args *)
7444   List.iter (
7445     fun arg ->
7446       if !needs_comma then pr ", ";
7447       needs_comma := true;
7448
7449       match arg with
7450       | String n
7451       | OptString n
7452       | FileIn n
7453       | FileOut n ->
7454           pr "String %s" n
7455       | StringList n ->
7456           pr "String[] %s" n
7457       | Bool n ->
7458           pr "boolean %s" n
7459       | Int n ->
7460           pr "int %s" n
7461   ) (snd style);
7462
7463   pr ")\n";
7464   pr "    throws LibGuestFSException";
7465   if semicolon then pr ";"
7466
7467 and generate_java_struct jtyp cols =
7468   generate_header CStyle LGPLv2;
7469
7470   pr "\
7471 package com.redhat.et.libguestfs;
7472
7473 /**
7474  * Libguestfs %s structure.
7475  *
7476  * @author rjones
7477  * @see GuestFS
7478  */
7479 public class %s {
7480 " jtyp jtyp;
7481
7482   List.iter (
7483     function
7484     | name, FString
7485     | name, FUUID
7486     | name, FBuffer -> pr "  public String %s;\n" name
7487     | name, (FBytes|FUInt64|FInt64) -> pr "  public long %s;\n" name
7488     | name, (FUInt32|FInt32) -> pr "  public int %s;\n" name
7489     | name, FChar -> pr "  public char %s;\n" name
7490     | name, FOptPercent ->
7491         pr "  /* The next field is [0..100] or -1 meaning 'not present': */\n";
7492         pr "  public float %s;\n" name
7493   ) cols;
7494
7495   pr "}\n"
7496
7497 and generate_java_c () =
7498   generate_header CStyle LGPLv2;
7499
7500   pr "\
7501 #include <stdio.h>
7502 #include <stdlib.h>
7503 #include <string.h>
7504
7505 #include \"com_redhat_et_libguestfs_GuestFS.h\"
7506 #include \"guestfs.h\"
7507
7508 /* Note that this function returns.  The exception is not thrown
7509  * until after the wrapper function returns.
7510  */
7511 static void
7512 throw_exception (JNIEnv *env, const char *msg)
7513 {
7514   jclass cl;
7515   cl = (*env)->FindClass (env,
7516                           \"com/redhat/et/libguestfs/LibGuestFSException\");
7517   (*env)->ThrowNew (env, cl, msg);
7518 }
7519
7520 JNIEXPORT jlong JNICALL
7521 Java_com_redhat_et_libguestfs_GuestFS__1create
7522   (JNIEnv *env, jobject obj)
7523 {
7524   guestfs_h *g;
7525
7526   g = guestfs_create ();
7527   if (g == NULL) {
7528     throw_exception (env, \"GuestFS.create: failed to allocate handle\");
7529     return 0;
7530   }
7531   guestfs_set_error_handler (g, NULL, NULL);
7532   return (jlong) (long) g;
7533 }
7534
7535 JNIEXPORT void JNICALL
7536 Java_com_redhat_et_libguestfs_GuestFS__1close
7537   (JNIEnv *env, jobject obj, jlong jg)
7538 {
7539   guestfs_h *g = (guestfs_h *) (long) jg;
7540   guestfs_close (g);
7541 }
7542
7543 ";
7544
7545   List.iter (
7546     fun (name, style, _, _, _, _, _) ->
7547       pr "JNIEXPORT ";
7548       (match fst style with
7549        | RErr -> pr "void ";
7550        | RInt _ -> pr "jint ";
7551        | RInt64 _ -> pr "jlong ";
7552        | RBool _ -> pr "jboolean ";
7553        | RConstString _ | RString _ -> pr "jstring ";
7554        | RStruct _ | RHashtable _ ->
7555            pr "jobject ";
7556        | RStringList _ | RStructList _ ->
7557            pr "jobjectArray ";
7558       );
7559       pr "JNICALL\n";
7560       pr "Java_com_redhat_et_libguestfs_GuestFS_";
7561       pr "%s" (replace_str ("_" ^ name) "_" "_1");
7562       pr "\n";
7563       pr "  (JNIEnv *env, jobject obj, jlong jg";
7564       List.iter (
7565         function
7566         | String n
7567         | OptString n
7568         | FileIn n
7569         | FileOut n ->
7570             pr ", jstring j%s" n
7571         | StringList n ->
7572             pr ", jobjectArray j%s" n
7573         | Bool n ->
7574             pr ", jboolean j%s" n
7575         | Int n ->
7576             pr ", jint j%s" n
7577       ) (snd style);
7578       pr ")\n";
7579       pr "{\n";
7580       pr "  guestfs_h *g = (guestfs_h *) (long) jg;\n";
7581       let error_code, no_ret =
7582         match fst style with
7583         | RErr -> pr "  int r;\n"; "-1", ""
7584         | RBool _
7585         | RInt _ -> pr "  int r;\n"; "-1", "0"
7586         | RInt64 _ -> pr "  int64_t r;\n"; "-1", "0"
7587         | RConstString _ -> pr "  const char *r;\n"; "NULL", "NULL"
7588         | RString _ ->
7589             pr "  jstring jr;\n";
7590             pr "  char *r;\n"; "NULL", "NULL"
7591         | RStringList _ ->
7592             pr "  jobjectArray jr;\n";
7593             pr "  int r_len;\n";
7594             pr "  jclass cl;\n";
7595             pr "  jstring jstr;\n";
7596             pr "  char **r;\n"; "NULL", "NULL"
7597         | RStruct (_, typ) ->
7598             pr "  jobject jr;\n";
7599             pr "  jclass cl;\n";
7600             pr "  jfieldID fl;\n";
7601             pr "  struct guestfs_%s *r;\n" typ; "NULL", "NULL"
7602         | RStructList (_, typ) ->
7603             pr "  jobjectArray jr;\n";
7604             pr "  jclass cl;\n";
7605             pr "  jfieldID fl;\n";
7606             pr "  jobject jfl;\n";
7607             pr "  struct guestfs_%s_list *r;\n" typ; "NULL", "NULL"
7608         | RHashtable _ -> pr "  char **r;\n"; "NULL", "NULL" in
7609       List.iter (
7610         function
7611         | String n
7612         | OptString n
7613         | FileIn n
7614         | FileOut n ->
7615             pr "  const char *%s;\n" n
7616         | StringList n ->
7617             pr "  int %s_len;\n" n;
7618             pr "  const char **%s;\n" n
7619         | Bool n
7620         | Int n ->
7621             pr "  int %s;\n" n
7622       ) (snd style);
7623
7624       let needs_i =
7625         (match fst style with
7626          | RStringList _ | RStructList _ -> true
7627          | RErr | RBool _ | RInt _ | RInt64 _ | RConstString _
7628          | RString _ | RStruct _ | RHashtable _ -> false) ||
7629           List.exists (function StringList _ -> true | _ -> false) (snd style) in
7630       if needs_i then
7631         pr "  int i;\n";
7632
7633       pr "\n";
7634
7635       (* Get the parameters. *)
7636       List.iter (
7637         function
7638         | String n
7639         | FileIn n
7640         | FileOut n ->
7641             pr "  %s = (*env)->GetStringUTFChars (env, j%s, NULL);\n" n n
7642         | OptString n ->
7643             (* This is completely undocumented, but Java null becomes
7644              * a NULL parameter.
7645              *)
7646             pr "  %s = j%s ? (*env)->GetStringUTFChars (env, j%s, NULL) : NULL;\n" n n n
7647         | StringList n ->
7648             pr "  %s_len = (*env)->GetArrayLength (env, j%s);\n" n n;
7649             pr "  %s = guestfs_safe_malloc (g, sizeof (char *) * (%s_len+1));\n" n n;
7650             pr "  for (i = 0; i < %s_len; ++i) {\n" n;
7651             pr "    jobject o = (*env)->GetObjectArrayElement (env, j%s, i);\n"
7652               n;
7653             pr "    %s[i] = (*env)->GetStringUTFChars (env, o, NULL);\n" n;
7654             pr "  }\n";
7655             pr "  %s[%s_len] = NULL;\n" n n;
7656         | Bool n
7657         | Int n ->
7658             pr "  %s = j%s;\n" n n
7659       ) (snd style);
7660
7661       (* Make the call. *)
7662       pr "  r = guestfs_%s " name;
7663       generate_call_args ~handle:"g" (snd style);
7664       pr ";\n";
7665
7666       (* Release the parameters. *)
7667       List.iter (
7668         function
7669         | String n
7670         | FileIn n
7671         | FileOut n ->
7672             pr "  (*env)->ReleaseStringUTFChars (env, j%s, %s);\n" n n
7673         | OptString n ->
7674             pr "  if (j%s)\n" n;
7675             pr "    (*env)->ReleaseStringUTFChars (env, j%s, %s);\n" n n
7676         | StringList n ->
7677             pr "  for (i = 0; i < %s_len; ++i) {\n" n;
7678             pr "    jobject o = (*env)->GetObjectArrayElement (env, j%s, i);\n"
7679               n;
7680             pr "    (*env)->ReleaseStringUTFChars (env, o, %s[i]);\n" n;
7681             pr "  }\n";
7682             pr "  free (%s);\n" n
7683         | Bool n
7684         | Int n -> ()
7685       ) (snd style);
7686
7687       (* Check for errors. *)
7688       pr "  if (r == %s) {\n" error_code;
7689       pr "    throw_exception (env, guestfs_last_error (g));\n";
7690       pr "    return %s;\n" no_ret;
7691       pr "  }\n";
7692
7693       (* Return value. *)
7694       (match fst style with
7695        | RErr -> ()
7696        | RInt _ -> pr "  return (jint) r;\n"
7697        | RBool _ -> pr "  return (jboolean) r;\n"
7698        | RInt64 _ -> pr "  return (jlong) r;\n"
7699        | RConstString _ -> pr "  return (*env)->NewStringUTF (env, r);\n"
7700        | RString _ ->
7701            pr "  jr = (*env)->NewStringUTF (env, r);\n";
7702            pr "  free (r);\n";
7703            pr "  return jr;\n"
7704        | RStringList _ ->
7705            pr "  for (r_len = 0; r[r_len] != NULL; ++r_len) ;\n";
7706            pr "  cl = (*env)->FindClass (env, \"java/lang/String\");\n";
7707            pr "  jstr = (*env)->NewStringUTF (env, \"\");\n";
7708            pr "  jr = (*env)->NewObjectArray (env, r_len, cl, jstr);\n";
7709            pr "  for (i = 0; i < r_len; ++i) {\n";
7710            pr "    jstr = (*env)->NewStringUTF (env, r[i]);\n";
7711            pr "    (*env)->SetObjectArrayElement (env, jr, i, jstr);\n";
7712            pr "    free (r[i]);\n";
7713            pr "  }\n";
7714            pr "  free (r);\n";
7715            pr "  return jr;\n"
7716        | RStruct (_, typ) ->
7717            let jtyp = java_name_of_struct typ in
7718            let cols = cols_of_struct typ in
7719            generate_java_struct_return typ jtyp cols
7720        | RStructList (_, typ) ->
7721            let jtyp = java_name_of_struct typ in
7722            let cols = cols_of_struct typ in
7723            generate_java_struct_list_return typ jtyp cols
7724        | RHashtable _ ->
7725            (* XXX *)
7726            pr "  throw_exception (env, \"%s: internal error: please let us know how to make a Java HashMap from JNI bindings!\");\n" name;
7727            pr "  return NULL;\n"
7728       );
7729
7730       pr "}\n";
7731       pr "\n"
7732   ) all_functions
7733
7734 and generate_java_struct_return typ jtyp cols =
7735   pr "  cl = (*env)->FindClass (env, \"com/redhat/et/libguestfs/%s\");\n" jtyp;
7736   pr "  jr = (*env)->AllocObject (env, cl);\n";
7737   List.iter (
7738     function
7739     | name, FString ->
7740         pr "  fl = (*env)->GetFieldID (env, cl, \"%s\", \"Ljava/lang/String;\");\n" name;
7741         pr "  (*env)->SetObjectField (env, jr, fl, (*env)->NewStringUTF (env, r->%s));\n" name;
7742     | name, FUUID ->
7743         pr "  {\n";
7744         pr "    char s[33];\n";
7745         pr "    memcpy (s, r->%s, 32);\n" name;
7746         pr "    s[32] = 0;\n";
7747         pr "    fl = (*env)->GetFieldID (env, cl, \"%s\", \"Ljava/lang/String;\");\n" name;
7748         pr "    (*env)->SetObjectField (env, jr, fl, (*env)->NewStringUTF (env, s));\n";
7749         pr "  }\n";
7750     | name, FBuffer ->
7751         pr "  {\n";
7752         pr "    int len = r->%s_len;\n" name;
7753         pr "    char s[len+1];\n";
7754         pr "    memcpy (s, r->%s, len);\n" name;
7755         pr "    s[len] = 0;\n";
7756         pr "    fl = (*env)->GetFieldID (env, cl, \"%s\", \"Ljava/lang/String;\");\n" name;
7757         pr "    (*env)->SetObjectField (env, jr, fl, (*env)->NewStringUTF (env, s));\n";
7758         pr "  }\n";
7759     | name, (FBytes|FUInt64|FInt64) ->
7760         pr "  fl = (*env)->GetFieldID (env, cl, \"%s\", \"J\");\n" name;
7761         pr "  (*env)->SetLongField (env, jr, fl, r->%s);\n" name;
7762     | name, (FUInt32|FInt32) ->
7763         pr "  fl = (*env)->GetFieldID (env, cl, \"%s\", \"I\");\n" name;
7764         pr "  (*env)->SetLongField (env, jr, fl, r->%s);\n" name;
7765     | name, FOptPercent ->
7766         pr "  fl = (*env)->GetFieldID (env, cl, \"%s\", \"F\");\n" name;
7767         pr "  (*env)->SetFloatField (env, jr, fl, r->%s);\n" name;
7768     | name, FChar ->
7769         pr "  fl = (*env)->GetFieldID (env, cl, \"%s\", \"C\");\n" name;
7770         pr "  (*env)->SetLongField (env, jr, fl, r->%s);\n" name;
7771   ) cols;
7772   pr "  free (r);\n";
7773   pr "  return jr;\n"
7774
7775 and generate_java_struct_list_return typ jtyp cols =
7776   pr "  cl = (*env)->FindClass (env, \"com/redhat/et/libguestfs/%s\");\n" jtyp;
7777   pr "  jr = (*env)->NewObjectArray (env, r->len, cl, NULL);\n";
7778   pr "  for (i = 0; i < r->len; ++i) {\n";
7779   pr "    jfl = (*env)->AllocObject (env, cl);\n";
7780   List.iter (
7781     function
7782     | name, FString ->
7783         pr "    fl = (*env)->GetFieldID (env, cl, \"%s\", \"Ljava/lang/String;\");\n" name;
7784         pr "    (*env)->SetObjectField (env, jfl, fl, (*env)->NewStringUTF (env, r->val[i].%s));\n" name;
7785     | name, FUUID ->
7786         pr "    {\n";
7787         pr "      char s[33];\n";
7788         pr "      memcpy (s, r->val[i].%s, 32);\n" name;
7789         pr "      s[32] = 0;\n";
7790         pr "      fl = (*env)->GetFieldID (env, cl, \"%s\", \"Ljava/lang/String;\");\n" name;
7791         pr "      (*env)->SetObjectField (env, jfl, fl, (*env)->NewStringUTF (env, s));\n";
7792         pr "    }\n";
7793     | name, FBuffer ->
7794         pr "    {\n";
7795         pr "      int len = r->val[i].%s_len;\n" name;
7796         pr "      char s[len+1];\n";
7797         pr "      memcpy (s, r->val[i].%s, len);\n" name;
7798         pr "      s[len] = 0;\n";
7799         pr "      fl = (*env)->GetFieldID (env, cl, \"%s\", \"Ljava/lang/String;\");\n" name;
7800         pr "      (*env)->SetObjectField (env, jfl, fl, (*env)->NewStringUTF (env, s));\n";
7801         pr "    }\n";
7802     | name, (FBytes|FUInt64|FInt64) ->
7803         pr "    fl = (*env)->GetFieldID (env, cl, \"%s\", \"J\");\n" name;
7804         pr "    (*env)->SetLongField (env, jfl, fl, r->val[i].%s);\n" name;
7805     | name, (FUInt32|FInt32) ->
7806         pr "    fl = (*env)->GetFieldID (env, cl, \"%s\", \"I\");\n" name;
7807         pr "    (*env)->SetLongField (env, jfl, fl, r->val[i].%s);\n" name;
7808     | name, FOptPercent ->
7809         pr "    fl = (*env)->GetFieldID (env, cl, \"%s\", \"F\");\n" name;
7810         pr "    (*env)->SetFloatField (env, jfl, fl, r->val[i].%s);\n" name;
7811     | name, FChar ->
7812         pr "    fl = (*env)->GetFieldID (env, cl, \"%s\", \"C\");\n" name;
7813         pr "    (*env)->SetLongField (env, jfl, fl, r->val[i].%s);\n" name;
7814   ) cols;
7815   pr "    (*env)->SetObjectArrayElement (env, jfl, i, jfl);\n";
7816   pr "  }\n";
7817   pr "  guestfs_free_%s_list (r);\n" typ;
7818   pr "  return jr;\n"
7819
7820 and generate_haskell_hs () =
7821   generate_header HaskellStyle LGPLv2;
7822
7823   (* XXX We only know how to generate partial FFI for Haskell
7824    * at the moment.  Please help out!
7825    *)
7826   let can_generate style =
7827     match style with
7828     | RErr, _
7829     | RInt _, _
7830     | RInt64 _, _ -> true
7831     | RBool _, _
7832     | RConstString _, _
7833     | RString _, _
7834     | RStringList _, _
7835     | RStruct _, _
7836     | RStructList _, _
7837     | RHashtable _, _ -> false in
7838
7839   pr "\
7840 {-# INCLUDE <guestfs.h> #-}
7841 {-# LANGUAGE ForeignFunctionInterface #-}
7842
7843 module Guestfs (
7844   create";
7845
7846   (* List out the names of the actions we want to export. *)
7847   List.iter (
7848     fun (name, style, _, _, _, _, _) ->
7849       if can_generate style then pr ",\n  %s" name
7850   ) all_functions;
7851
7852   pr "
7853   ) where
7854 import Foreign
7855 import Foreign.C
7856 import Foreign.C.Types
7857 import IO
7858 import Control.Exception
7859 import Data.Typeable
7860
7861 data GuestfsS = GuestfsS            -- represents the opaque C struct
7862 type GuestfsP = Ptr GuestfsS        -- guestfs_h *
7863 type GuestfsH = ForeignPtr GuestfsS -- guestfs_h * with attached finalizer
7864
7865 -- XXX define properly later XXX
7866 data PV = PV
7867 data VG = VG
7868 data LV = LV
7869 data IntBool = IntBool
7870 data Stat = Stat
7871 data StatVFS = StatVFS
7872 data Hashtable = Hashtable
7873
7874 foreign import ccall unsafe \"guestfs_create\" c_create
7875   :: IO GuestfsP
7876 foreign import ccall unsafe \"&guestfs_close\" c_close
7877   :: FunPtr (GuestfsP -> IO ())
7878 foreign import ccall unsafe \"guestfs_set_error_handler\" c_set_error_handler
7879   :: GuestfsP -> Ptr CInt -> Ptr CInt -> IO ()
7880
7881 create :: IO GuestfsH
7882 create = do
7883   p <- c_create
7884   c_set_error_handler p nullPtr nullPtr
7885   h <- newForeignPtr c_close p
7886   return h
7887
7888 foreign import ccall unsafe \"guestfs_last_error\" c_last_error
7889   :: GuestfsP -> IO CString
7890
7891 -- last_error :: GuestfsH -> IO (Maybe String)
7892 -- last_error h = do
7893 --   str <- withForeignPtr h (\\p -> c_last_error p)
7894 --   maybePeek peekCString str
7895
7896 last_error :: GuestfsH -> IO (String)
7897 last_error h = do
7898   str <- withForeignPtr h (\\p -> c_last_error p)
7899   if (str == nullPtr)
7900     then return \"no error\"
7901     else peekCString str
7902
7903 ";
7904
7905   (* Generate wrappers for each foreign function. *)
7906   List.iter (
7907     fun (name, style, _, _, _, _, _) ->
7908       if can_generate style then (
7909         pr "foreign import ccall unsafe \"guestfs_%s\" c_%s\n" name name;
7910         pr "  :: ";
7911         generate_haskell_prototype ~handle:"GuestfsP" style;
7912         pr "\n";
7913         pr "\n";
7914         pr "%s :: " name;
7915         generate_haskell_prototype ~handle:"GuestfsH" ~hs:true style;
7916         pr "\n";
7917         pr "%s %s = do\n" name
7918           (String.concat " " ("h" :: List.map name_of_argt (snd style)));
7919         pr "  r <- ";
7920         (* Convert pointer arguments using with* functions. *)
7921         List.iter (
7922           function
7923           | FileIn n
7924           | FileOut n
7925           | String n -> pr "withCString %s $ \\%s -> " n n
7926           | OptString n -> pr "maybeWith withCString %s $ \\%s -> " n n
7927           | StringList n -> pr "withMany withCString %s $ \\%s -> withArray0 nullPtr %s $ \\%s -> " n n n n
7928           | Bool _ | Int _ -> ()
7929         ) (snd style);
7930         (* Convert integer arguments. *)
7931         let args =
7932           List.map (
7933             function
7934             | Bool n -> sprintf "(fromBool %s)" n
7935             | Int n -> sprintf "(fromIntegral %s)" n
7936             | FileIn n | FileOut n | String n | OptString n | StringList n -> n
7937           ) (snd style) in
7938         pr "withForeignPtr h (\\p -> c_%s %s)\n" name
7939           (String.concat " " ("p" :: args));
7940         (match fst style with
7941          | RErr | RInt _ | RInt64 _ | RBool _ ->
7942              pr "  if (r == -1)\n";
7943              pr "    then do\n";
7944              pr "      err <- last_error h\n";
7945              pr "      fail err\n";
7946          | RConstString _ | RString _ | RStringList _ | RStruct _
7947          | RStructList _ | RHashtable _ ->
7948              pr "  if (r == nullPtr)\n";
7949              pr "    then do\n";
7950              pr "      err <- last_error h\n";
7951              pr "      fail err\n";
7952         );
7953         (match fst style with
7954          | RErr ->
7955              pr "    else return ()\n"
7956          | RInt _ ->
7957              pr "    else return (fromIntegral r)\n"
7958          | RInt64 _ ->
7959              pr "    else return (fromIntegral r)\n"
7960          | RBool _ ->
7961              pr "    else return (toBool r)\n"
7962          | RConstString _
7963          | RString _
7964          | RStringList _
7965          | RStruct _
7966          | RStructList _
7967          | RHashtable _ ->
7968              pr "    else return ()\n" (* XXXXXXXXXXXXXXXXXXXX *)
7969         );
7970         pr "\n";
7971       )
7972   ) all_functions
7973
7974 and generate_haskell_prototype ~handle ?(hs = false) style =
7975   pr "%s -> " handle;
7976   let string = if hs then "String" else "CString" in
7977   let int = if hs then "Int" else "CInt" in
7978   let bool = if hs then "Bool" else "CInt" in
7979   let int64 = if hs then "Integer" else "Int64" in
7980   List.iter (
7981     fun arg ->
7982       (match arg with
7983        | String _ -> pr "%s" string
7984        | OptString _ -> if hs then pr "Maybe String" else pr "CString"
7985        | StringList _ -> if hs then pr "[String]" else pr "Ptr CString"
7986        | Bool _ -> pr "%s" bool
7987        | Int _ -> pr "%s" int
7988        | FileIn _ -> pr "%s" string
7989        | FileOut _ -> pr "%s" string
7990       );
7991       pr " -> ";
7992   ) (snd style);
7993   pr "IO (";
7994   (match fst style with
7995    | RErr -> if not hs then pr "CInt"
7996    | RInt _ -> pr "%s" int
7997    | RInt64 _ -> pr "%s" int64
7998    | RBool _ -> pr "%s" bool
7999    | RConstString _ -> pr "%s" string
8000    | RString _ -> pr "%s" string
8001    | RStringList _ -> pr "[%s]" string
8002    | RStruct (_, typ) ->
8003        let name = java_name_of_struct typ in
8004        pr "%s" name
8005    | RStructList (_, typ) ->
8006        let name = java_name_of_struct typ in
8007        pr "[%s]" name
8008    | RHashtable _ -> pr "Hashtable"
8009   );
8010   pr ")"
8011
8012 and generate_bindtests () =
8013   generate_header CStyle LGPLv2;
8014
8015   pr "\
8016 #include <stdio.h>
8017 #include <stdlib.h>
8018 #include <inttypes.h>
8019 #include <string.h>
8020
8021 #include \"guestfs.h\"
8022 #include \"guestfs_protocol.h\"
8023
8024 #define error guestfs_error
8025 #define safe_calloc guestfs_safe_calloc
8026 #define safe_malloc guestfs_safe_malloc
8027
8028 static void
8029 print_strings (char * const* const argv)
8030 {
8031   int argc;
8032
8033   printf (\"[\");
8034   for (argc = 0; argv[argc] != NULL; ++argc) {
8035     if (argc > 0) printf (\", \");
8036     printf (\"\\\"%%s\\\"\", argv[argc]);
8037   }
8038   printf (\"]\\n\");
8039 }
8040
8041 /* The test0 function prints its parameters to stdout. */
8042 ";
8043
8044   let test0, tests =
8045     match test_functions with
8046     | [] -> assert false
8047     | test0 :: tests -> test0, tests in
8048
8049   let () =
8050     let (name, style, _, _, _, _, _) = test0 in
8051     generate_prototype ~extern:false ~semicolon:false ~newline:true
8052       ~handle:"g" ~prefix:"guestfs_" name style;
8053     pr "{\n";
8054     List.iter (
8055       function
8056       | String n
8057       | FileIn n
8058       | FileOut n -> pr "  printf (\"%%s\\n\", %s);\n" n
8059       | OptString n -> pr "  printf (\"%%s\\n\", %s ? %s : \"null\");\n" n n
8060       | StringList n -> pr "  print_strings (%s);\n" n
8061       | Bool n -> pr "  printf (\"%%s\\n\", %s ? \"true\" : \"false\");\n" n
8062       | Int n -> pr "  printf (\"%%d\\n\", %s);\n" n
8063     ) (snd style);
8064     pr "  /* Java changes stdout line buffering so we need this: */\n";
8065     pr "  fflush (stdout);\n";
8066     pr "  return 0;\n";
8067     pr "}\n";
8068     pr "\n" in
8069
8070   List.iter (
8071     fun (name, style, _, _, _, _, _) ->
8072       if String.sub name (String.length name - 3) 3 <> "err" then (
8073         pr "/* Test normal return. */\n";
8074         generate_prototype ~extern:false ~semicolon:false ~newline:true
8075           ~handle:"g" ~prefix:"guestfs_" name style;
8076         pr "{\n";
8077         (match fst style with
8078          | RErr ->
8079              pr "  return 0;\n"
8080          | RInt _ ->
8081              pr "  int r;\n";
8082              pr "  sscanf (val, \"%%d\", &r);\n";
8083              pr "  return r;\n"
8084          | RInt64 _ ->
8085              pr "  int64_t r;\n";
8086              pr "  sscanf (val, \"%%\" SCNi64, &r);\n";
8087              pr "  return r;\n"
8088          | RBool _ ->
8089              pr "  return strcmp (val, \"true\") == 0;\n"
8090          | RConstString _ ->
8091              (* Can't return the input string here.  Return a static
8092               * string so we ensure we get a segfault if the caller
8093               * tries to free it.
8094               *)
8095              pr "  return \"static string\";\n"
8096          | RString _ ->
8097              pr "  return strdup (val);\n"
8098          | RStringList _ ->
8099              pr "  char **strs;\n";
8100              pr "  int n, i;\n";
8101              pr "  sscanf (val, \"%%d\", &n);\n";
8102              pr "  strs = safe_malloc (g, (n+1) * sizeof (char *));\n";
8103              pr "  for (i = 0; i < n; ++i) {\n";
8104              pr "    strs[i] = safe_malloc (g, 16);\n";
8105              pr "    snprintf (strs[i], 16, \"%%d\", i);\n";
8106              pr "  }\n";
8107              pr "  strs[n] = NULL;\n";
8108              pr "  return strs;\n"
8109          | RStruct (_, typ) ->
8110              pr "  struct guestfs_%s *r;\n" typ;
8111              pr "  r = safe_calloc (g, sizeof *r, 1);\n";
8112              pr "  return r;\n"
8113          | RStructList (_, typ) ->
8114              pr "  struct guestfs_%s_list *r;\n" typ;
8115              pr "  r = safe_calloc (g, sizeof *r, 1);\n";
8116              pr "  sscanf (val, \"%%d\", &r->len);\n";
8117              pr "  r->val = safe_calloc (g, r->len, sizeof *r->val);\n";
8118              pr "  return r;\n"
8119          | RHashtable _ ->
8120              pr "  char **strs;\n";
8121              pr "  int n, i;\n";
8122              pr "  sscanf (val, \"%%d\", &n);\n";
8123              pr "  strs = safe_malloc (g, (n*2+1) * sizeof (*strs));\n";
8124              pr "  for (i = 0; i < n; ++i) {\n";
8125              pr "    strs[i*2] = safe_malloc (g, 16);\n";
8126              pr "    strs[i*2+1] = safe_malloc (g, 16);\n";
8127              pr "    snprintf (strs[i*2], 16, \"%%d\", i);\n";
8128              pr "    snprintf (strs[i*2+1], 16, \"%%d\", i);\n";
8129              pr "  }\n";
8130              pr "  strs[n*2] = NULL;\n";
8131              pr "  return strs;\n"
8132         );
8133         pr "}\n";
8134         pr "\n"
8135       ) else (
8136         pr "/* Test error return. */\n";
8137         generate_prototype ~extern:false ~semicolon:false ~newline:true
8138           ~handle:"g" ~prefix:"guestfs_" name style;
8139         pr "{\n";
8140         pr "  error (g, \"error\");\n";
8141         (match fst style with
8142          | RErr | RInt _ | RInt64 _ | RBool _ ->
8143              pr "  return -1;\n"
8144          | RConstString _
8145          | RString _ | RStringList _ | RStruct _
8146          | RStructList _
8147          | RHashtable _ ->
8148              pr "  return NULL;\n"
8149         );
8150         pr "}\n";
8151         pr "\n"
8152       )
8153   ) tests
8154
8155 and generate_ocaml_bindtests () =
8156   generate_header OCamlStyle GPLv2;
8157
8158   pr "\
8159 let () =
8160   let g = Guestfs.create () in
8161 ";
8162
8163   let mkargs args =
8164     String.concat " " (
8165       List.map (
8166         function
8167         | CallString s -> "\"" ^ s ^ "\""
8168         | CallOptString None -> "None"
8169         | CallOptString (Some s) -> sprintf "(Some \"%s\")" s
8170         | CallStringList xs ->
8171             "[|" ^ String.concat ";" (List.map (sprintf "\"%s\"") xs) ^ "|]"
8172         | CallInt i when i >= 0 -> string_of_int i
8173         | CallInt i (* when i < 0 *) -> "(" ^ string_of_int i ^ ")"
8174         | CallBool b -> string_of_bool b
8175       ) args
8176     )
8177   in
8178
8179   generate_lang_bindtests (
8180     fun f args -> pr "  Guestfs.%s g %s;\n" f (mkargs args)
8181   );
8182
8183   pr "print_endline \"EOF\"\n"
8184
8185 and generate_perl_bindtests () =
8186   pr "#!/usr/bin/perl -w\n";
8187   generate_header HashStyle GPLv2;
8188
8189   pr "\
8190 use strict;
8191
8192 use Sys::Guestfs;
8193
8194 my $g = Sys::Guestfs->new ();
8195 ";
8196
8197   let mkargs args =
8198     String.concat ", " (
8199       List.map (
8200         function
8201         | CallString s -> "\"" ^ s ^ "\""
8202         | CallOptString None -> "undef"
8203         | CallOptString (Some s) -> sprintf "\"%s\"" s
8204         | CallStringList xs ->
8205             "[" ^ String.concat "," (List.map (sprintf "\"%s\"") xs) ^ "]"
8206         | CallInt i -> string_of_int i
8207         | CallBool b -> if b then "1" else "0"
8208       ) args
8209     )
8210   in
8211
8212   generate_lang_bindtests (
8213     fun f args -> pr "$g->%s (%s);\n" f (mkargs args)
8214   );
8215
8216   pr "print \"EOF\\n\"\n"
8217
8218 and generate_python_bindtests () =
8219   generate_header HashStyle GPLv2;
8220
8221   pr "\
8222 import guestfs
8223
8224 g = guestfs.GuestFS ()
8225 ";
8226
8227   let mkargs args =
8228     String.concat ", " (
8229       List.map (
8230         function
8231         | CallString s -> "\"" ^ s ^ "\""
8232         | CallOptString None -> "None"
8233         | CallOptString (Some s) -> sprintf "\"%s\"" s
8234         | CallStringList xs ->
8235             "[" ^ String.concat "," (List.map (sprintf "\"%s\"") xs) ^ "]"
8236         | CallInt i -> string_of_int i
8237         | CallBool b -> if b then "1" else "0"
8238       ) args
8239     )
8240   in
8241
8242   generate_lang_bindtests (
8243     fun f args -> pr "g.%s (%s)\n" f (mkargs args)
8244   );
8245
8246   pr "print \"EOF\"\n"
8247
8248 and generate_ruby_bindtests () =
8249   generate_header HashStyle GPLv2;
8250
8251   pr "\
8252 require 'guestfs'
8253
8254 g = Guestfs::create()
8255 ";
8256
8257   let mkargs args =
8258     String.concat ", " (
8259       List.map (
8260         function
8261         | CallString s -> "\"" ^ s ^ "\""
8262         | CallOptString None -> "nil"
8263         | CallOptString (Some s) -> sprintf "\"%s\"" s
8264         | CallStringList xs ->
8265             "[" ^ String.concat "," (List.map (sprintf "\"%s\"") xs) ^ "]"
8266         | CallInt i -> string_of_int i
8267         | CallBool b -> string_of_bool b
8268       ) args
8269     )
8270   in
8271
8272   generate_lang_bindtests (
8273     fun f args -> pr "g.%s(%s)\n" f (mkargs args)
8274   );
8275
8276   pr "print \"EOF\\n\"\n"
8277
8278 and generate_java_bindtests () =
8279   generate_header CStyle GPLv2;
8280
8281   pr "\
8282 import com.redhat.et.libguestfs.*;
8283
8284 public class Bindtests {
8285     public static void main (String[] argv)
8286     {
8287         try {
8288             GuestFS g = new GuestFS ();
8289 ";
8290
8291   let mkargs args =
8292     String.concat ", " (
8293       List.map (
8294         function
8295         | CallString s -> "\"" ^ s ^ "\""
8296         | CallOptString None -> "null"
8297         | CallOptString (Some s) -> sprintf "\"%s\"" s
8298         | CallStringList xs ->
8299             "new String[]{" ^
8300               String.concat "," (List.map (sprintf "\"%s\"") xs) ^ "}"
8301         | CallInt i -> string_of_int i
8302         | CallBool b -> string_of_bool b
8303       ) args
8304     )
8305   in
8306
8307   generate_lang_bindtests (
8308     fun f args -> pr "            g.%s (%s);\n" f (mkargs args)
8309   );
8310
8311   pr "
8312             System.out.println (\"EOF\");
8313         }
8314         catch (Exception exn) {
8315             System.err.println (exn);
8316             System.exit (1);
8317         }
8318     }
8319 }
8320 "
8321
8322 and generate_haskell_bindtests () =
8323   generate_header HaskellStyle GPLv2;
8324
8325   pr "\
8326 module Bindtests where
8327 import qualified Guestfs
8328
8329 main = do
8330   g <- Guestfs.create
8331 ";
8332
8333   let mkargs args =
8334     String.concat " " (
8335       List.map (
8336         function
8337         | CallString s -> "\"" ^ s ^ "\""
8338         | CallOptString None -> "Nothing"
8339         | CallOptString (Some s) -> sprintf "(Just \"%s\")" s
8340         | CallStringList xs ->
8341             "[" ^ String.concat "," (List.map (sprintf "\"%s\"") xs) ^ "]"
8342         | CallInt i when i < 0 -> "(" ^ string_of_int i ^ ")"
8343         | CallInt i -> string_of_int i
8344         | CallBool true -> "True"
8345         | CallBool false -> "False"
8346       ) args
8347     )
8348   in
8349
8350   generate_lang_bindtests (
8351     fun f args -> pr "  Guestfs.%s g %s\n" f (mkargs args)
8352   );
8353
8354   pr "  putStrLn \"EOF\"\n"
8355
8356 (* Language-independent bindings tests - we do it this way to
8357  * ensure there is parity in testing bindings across all languages.
8358  *)
8359 and generate_lang_bindtests call =
8360   call "test0" [CallString "abc"; CallOptString (Some "def");
8361                 CallStringList []; CallBool false;
8362                 CallInt 0; CallString "123"; CallString "456"];
8363   call "test0" [CallString "abc"; CallOptString None;
8364                 CallStringList []; CallBool false;
8365                 CallInt 0; CallString "123"; CallString "456"];
8366   call "test0" [CallString ""; CallOptString (Some "def");
8367                 CallStringList []; CallBool false;
8368                 CallInt 0; CallString "123"; CallString "456"];
8369   call "test0" [CallString ""; CallOptString (Some "");
8370                 CallStringList []; CallBool false;
8371                 CallInt 0; CallString "123"; CallString "456"];
8372   call "test0" [CallString "abc"; CallOptString (Some "def");
8373                 CallStringList ["1"]; CallBool false;
8374                 CallInt 0; CallString "123"; CallString "456"];
8375   call "test0" [CallString "abc"; CallOptString (Some "def");
8376                 CallStringList ["1"; "2"]; CallBool false;
8377                 CallInt 0; CallString "123"; CallString "456"];
8378   call "test0" [CallString "abc"; CallOptString (Some "def");
8379                 CallStringList ["1"]; CallBool true;
8380                 CallInt 0; CallString "123"; CallString "456"];
8381   call "test0" [CallString "abc"; CallOptString (Some "def");
8382                 CallStringList ["1"]; CallBool false;
8383                 CallInt (-1); CallString "123"; CallString "456"];
8384   call "test0" [CallString "abc"; CallOptString (Some "def");
8385                 CallStringList ["1"]; CallBool false;
8386                 CallInt (-2); CallString "123"; CallString "456"];
8387   call "test0" [CallString "abc"; CallOptString (Some "def");
8388                 CallStringList ["1"]; CallBool false;
8389                 CallInt 1; CallString "123"; CallString "456"];
8390   call "test0" [CallString "abc"; CallOptString (Some "def");
8391                 CallStringList ["1"]; CallBool false;
8392                 CallInt 2; CallString "123"; CallString "456"];
8393   call "test0" [CallString "abc"; CallOptString (Some "def");
8394                 CallStringList ["1"]; CallBool false;
8395                 CallInt 4095; CallString "123"; CallString "456"];
8396   call "test0" [CallString "abc"; CallOptString (Some "def");
8397                 CallStringList ["1"]; CallBool false;
8398                 CallInt 0; CallString ""; CallString ""]
8399
8400 (* XXX Add here tests of the return and error functions. *)
8401
8402 (* This is used to generate the src/MAX_PROC_NR file which
8403  * contains the maximum procedure number, a surrogate for the
8404  * ABI version number.  See src/Makefile.am for the details.
8405  *)
8406 and generate_max_proc_nr () =
8407   let proc_nrs = List.map (
8408     fun (_, _, proc_nr, _, _, _, _) -> proc_nr
8409   ) daemon_functions in
8410
8411   let max_proc_nr = List.fold_left max 0 proc_nrs in
8412
8413   pr "%d\n" max_proc_nr
8414
8415 let output_to filename =
8416   let filename_new = filename ^ ".new" in
8417   chan := open_out filename_new;
8418   let close () =
8419     close_out !chan;
8420     chan := stdout;
8421
8422     (* Is the new file different from the current file? *)
8423     if Sys.file_exists filename && files_equal filename filename_new then
8424       Unix.unlink filename_new          (* same, so skip it *)
8425     else (
8426       (* different, overwrite old one *)
8427       (try Unix.chmod filename 0o644 with Unix.Unix_error _ -> ());
8428       Unix.rename filename_new filename;
8429       Unix.chmod filename 0o444;
8430       printf "written %s\n%!" filename;
8431     )
8432   in
8433   close
8434
8435 (* Main program. *)
8436 let () =
8437   check_functions ();
8438
8439   if not (Sys.file_exists "HACKING") then (
8440     eprintf "\
8441 You are probably running this from the wrong directory.
8442 Run it from the top source directory using the command
8443   src/generator.ml
8444 ";
8445     exit 1
8446   );
8447
8448   let close = output_to "src/guestfs_protocol.x" in
8449   generate_xdr ();
8450   close ();
8451
8452   let close = output_to "src/guestfs-structs.h" in
8453   generate_structs_h ();
8454   close ();
8455
8456   let close = output_to "src/guestfs-actions.h" in
8457   generate_actions_h ();
8458   close ();
8459
8460   let close = output_to "src/guestfs-actions.c" in
8461   generate_client_actions ();
8462   close ();
8463
8464   let close = output_to "daemon/actions.h" in
8465   generate_daemon_actions_h ();
8466   close ();
8467
8468   let close = output_to "daemon/stubs.c" in
8469   generate_daemon_actions ();
8470   close ();
8471
8472   let close = output_to "daemon/names.c" in
8473   generate_daemon_names ();
8474   close ();
8475
8476   let close = output_to "capitests/tests.c" in
8477   generate_tests ();
8478   close ();
8479
8480   let close = output_to "src/guestfs-bindtests.c" in
8481   generate_bindtests ();
8482   close ();
8483
8484   let close = output_to "fish/cmds.c" in
8485   generate_fish_cmds ();
8486   close ();
8487
8488   let close = output_to "fish/completion.c" in
8489   generate_fish_completion ();
8490   close ();
8491
8492   let close = output_to "guestfs-structs.pod" in
8493   generate_structs_pod ();
8494   close ();
8495
8496   let close = output_to "guestfs-actions.pod" in
8497   generate_actions_pod ();
8498   close ();
8499
8500   let close = output_to "guestfish-actions.pod" in
8501   generate_fish_actions_pod ();
8502   close ();
8503
8504   let close = output_to "ocaml/guestfs.mli" in
8505   generate_ocaml_mli ();
8506   close ();
8507
8508   let close = output_to "ocaml/guestfs.ml" in
8509   generate_ocaml_ml ();
8510   close ();
8511
8512   let close = output_to "ocaml/guestfs_c_actions.c" in
8513   generate_ocaml_c ();
8514   close ();
8515
8516   let close = output_to "ocaml/bindtests.ml" in
8517   generate_ocaml_bindtests ();
8518   close ();
8519
8520   let close = output_to "perl/Guestfs.xs" in
8521   generate_perl_xs ();
8522   close ();
8523
8524   let close = output_to "perl/lib/Sys/Guestfs.pm" in
8525   generate_perl_pm ();
8526   close ();
8527
8528   let close = output_to "perl/bindtests.pl" in
8529   generate_perl_bindtests ();
8530   close ();
8531
8532   let close = output_to "python/guestfs-py.c" in
8533   generate_python_c ();
8534   close ();
8535
8536   let close = output_to "python/guestfs.py" in
8537   generate_python_py ();
8538   close ();
8539
8540   let close = output_to "python/bindtests.py" in
8541   generate_python_bindtests ();
8542   close ();
8543
8544   let close = output_to "ruby/ext/guestfs/_guestfs.c" in
8545   generate_ruby_c ();
8546   close ();
8547
8548   let close = output_to "ruby/bindtests.rb" in
8549   generate_ruby_bindtests ();
8550   close ();
8551
8552   let close = output_to "java/com/redhat/et/libguestfs/GuestFS.java" in
8553   generate_java_java ();
8554   close ();
8555
8556   List.iter (
8557     fun (typ, jtyp) ->
8558       let cols = cols_of_struct typ in
8559       let filename = sprintf "java/com/redhat/et/libguestfs/%s.java" jtyp in
8560       let close = output_to filename in
8561       generate_java_struct jtyp cols;
8562       close ();
8563   ) java_structs;
8564
8565   let close = output_to "java/Makefile.inc" in
8566   pr "java_built_sources =";
8567   List.iter (
8568     fun (typ, jtyp) ->
8569         pr " com/redhat/et/libguestfs/%s.java" jtyp;
8570   ) java_structs;
8571   pr " com/redhat/et/libguestfs/GuestFS.java\n";
8572   close ();
8573
8574   let close = output_to "java/com_redhat_et_libguestfs_GuestFS.c" in
8575   generate_java_c ();
8576   close ();
8577
8578   let close = output_to "java/Bindtests.java" in
8579   generate_java_bindtests ();
8580   close ();
8581
8582   let close = output_to "haskell/Guestfs.hs" in
8583   generate_haskell_hs ();
8584   close ();
8585
8586   let close = output_to "haskell/Bindtests.hs" in
8587   generate_haskell_bindtests ();
8588   close ();
8589
8590   let close = output_to "src/MAX_PROC_NR" in
8591   generate_max_proc_nr ();
8592   close ();
8593
8594   (* Always generate this file last, and unconditionally.  It's used
8595    * by the Makefile to know when we must re-run the generator.
8596    *)
8597   let chan = open_out "src/stamp-generator" in
8598   fprintf chan "1\n";
8599   close_out chan