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