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