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