src/generator.ml

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