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