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