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