src/generator.ml

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