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