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