a01eeb7983a177efd38c558c3bd2be05c4710740
[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 umount-all and lvm-remove-all (except InitNone).
140  *
141  * Don't assume anything about the previous contents of the block
142  * devices.  Use 'Init*' to create some initial scenarios.
143  *)
144 type tests = (test_init * test) list
145 and test =
146     (* Run the command sequence and just expect nothing to fail. *)
147   | TestRun of seq
148     (* Run the command sequence and expect the output of the final
149      * command to be the string.
150      *)
151   | TestOutput of seq * string
152     (* Run the command sequence and expect the output of the final
153      * command to be the list of strings.
154      *)
155   | TestOutputList of seq * string list
156     (* Run the command sequence and expect the output of the final
157      * command to be the integer.
158      *)
159   | TestOutputInt of seq * int
160     (* Run the command sequence and expect the output of the final
161      * command to be a true value (!= 0 or != NULL).
162      *)
163   | TestOutputTrue of seq
164     (* Run the command sequence and expect the output of the final
165      * command to be a false value (== 0 or == NULL, but not an error).
166      *)
167   | TestOutputFalse of seq
168     (* Run the command sequence and expect the output of the final
169      * command to be a list of the given length (but don't care about
170      * content).
171      *)
172   | TestOutputLength of seq * int
173     (* Run the command sequence and expect the output of the final
174      * command to be a structure.
175      *)
176   | TestOutputStruct of seq * test_field_compare list
177     (* Run the command sequence and expect the final command (only)
178      * to fail.
179      *)
180   | TestLastFail of seq
181
182 and test_field_compare =
183   | CompareWithInt of string * int
184   | CompareWithString of string * string
185   | CompareFieldsIntEq of string * string
186   | CompareFieldsStrEq of string * string
187
188 (* Some initial scenarios for testing. *)
189 and test_init =
190     (* Do nothing, block devices could contain random stuff including
191      * LVM PVs, and some filesystems might be mounted.  This is usually
192      * a bad idea.
193      *)
194   | InitNone
195     (* Block devices are empty and no filesystems are mounted. *)
196   | InitEmpty
197     (* /dev/sda contains a single partition /dev/sda1, which is formatted
198      * as ext2, empty [except for lost+found] and mounted on /.
199      * /dev/sdb and /dev/sdc may have random content.
200      * No LVM.
201      *)
202   | InitBasicFS
203     (* /dev/sda:
204      *   /dev/sda1 (is a PV):
205      *     /dev/VG/LV (size 8MB):
206      *       formatted as ext2, empty [except for lost+found], mounted on /
207      * /dev/sdb and /dev/sdc may have random content.
208      *)
209   | InitBasicFSonLVM
210
211 (* Sequence of commands for testing. *)
212 and seq = cmd list
213 and cmd = string list
214
215 (* Note about long descriptions: When referring to another
216  * action, use the format C<guestfs_other> (ie. the full name of
217  * the C function).  This will be replaced as appropriate in other
218  * language bindings.
219  *
220  * Apart from that, long descriptions are just perldoc paragraphs.
221  *)
222
223 let non_daemon_functions = [
224   ("launch", (RErr, []), -1, [FishAlias "run"; FishAction "launch"],
225    [],
226    "launch the qemu subprocess",
227    "\
228 Internally libguestfs is implemented by running a virtual machine
229 using L<qemu(1)>.
230
231 You should call this after configuring the handle
232 (eg. adding drives) but before performing any actions.");
233
234   ("wait_ready", (RErr, []), -1, [NotInFish],
235    [],
236    "wait until the qemu subprocess launches",
237    "\
238 Internally libguestfs is implemented by running a virtual machine
239 using L<qemu(1)>.
240
241 You should call this after C<guestfs_launch> to wait for the launch
242 to complete.");
243
244   ("kill_subprocess", (RErr, []), -1, [],
245    [],
246    "kill the qemu subprocess",
247    "\
248 This kills the qemu subprocess.  You should never need to call this.");
249
250   ("add_drive", (RErr, [String "filename"]), -1, [FishAlias "add"],
251    [],
252    "add an image to examine or modify",
253    "\
254 This function adds a virtual machine disk image C<filename> to the
255 guest.  The first time you call this function, the disk appears as IDE
256 disk 0 (C</dev/sda>) in the guest, the second time as C</dev/sdb>, and
257 so on.
258
259 You don't necessarily need to be root when using libguestfs.  However
260 you obviously do need sufficient permissions to access the filename
261 for whatever operations you want to perform (ie. read access if you
262 just want to read the image or write access if you want to modify the
263 image).
264
265 This is equivalent to the qemu parameter C<-drive file=filename>.");
266
267   ("add_cdrom", (RErr, [String "filename"]), -1, [FishAlias "cdrom"],
268    [],
269    "add a CD-ROM disk image to examine",
270    "\
271 This function adds a virtual CD-ROM disk image to the guest.
272
273 This is equivalent to the qemu parameter C<-cdrom filename>.");
274
275   ("config", (RErr, [String "qemuparam"; OptString "qemuvalue"]), -1, [],
276    [],
277    "add qemu parameters",
278    "\
279 This can be used to add arbitrary qemu command line parameters
280 of the form C<-param value>.  Actually it's not quite arbitrary - we
281 prevent you from setting some parameters which would interfere with
282 parameters that we use.
283
284 The first character of C<param> string must be a C<-> (dash).
285
286 C<value> can be NULL.");
287
288   ("set_qemu", (RErr, [String "qemu"]), -1, [FishAlias "qemu"],
289    [],
290    "set the qemu binary",
291    "\
292 Set the qemu binary that we will use.
293
294 The default is chosen when the library was compiled by the
295 configure script.
296
297 You can also override this by setting the C<LIBGUESTFS_QEMU>
298 environment variable.
299
300 The string C<qemu> is stashed in the libguestfs handle, so the caller
301 must make sure it remains valid for the lifetime of the handle.
302
303 Setting C<qemu> to C<NULL> restores the default qemu binary.");
304
305   ("get_qemu", (RConstString "qemu", []), -1, [],
306    [],
307    "get the qemu binary",
308    "\
309 Return the current qemu binary.
310
311 This is always non-NULL.  If it wasn't set already, then this will
312 return the default qemu binary name.");
313
314   ("set_path", (RErr, [String "path"]), -1, [FishAlias "path"],
315    [],
316    "set the search path",
317    "\
318 Set the path that libguestfs searches for kernel and initrd.img.
319
320 The default is C<$libdir/guestfs> unless overridden by setting
321 C<LIBGUESTFS_PATH> environment variable.
322
323 The string C<path> is stashed in the libguestfs handle, so the caller
324 must make sure it remains valid for the lifetime of the handle.
325
326 Setting C<path> to C<NULL> restores the default path.");
327
328   ("get_path", (RConstString "path", []), -1, [],
329    [],
330    "get the search path",
331    "\
332 Return the current search path.
333
334 This is always non-NULL.  If it wasn't set already, then this will
335 return the default path.");
336
337   ("set_autosync", (RErr, [Bool "autosync"]), -1, [FishAlias "autosync"],
338    [],
339    "set autosync mode",
340    "\
341 If C<autosync> is true, this enables autosync.  Libguestfs will make a
342 best effort attempt to run C<guestfs_sync> when the handle is closed
343 (also if the program exits without closing handles).");
344
345   ("get_autosync", (RBool "autosync", []), -1, [],
346    [],
347    "get autosync mode",
348    "\
349 Get the autosync flag.");
350
351   ("set_verbose", (RErr, [Bool "verbose"]), -1, [FishAlias "verbose"],
352    [],
353    "set verbose mode",
354    "\
355 If C<verbose> is true, this turns on verbose messages (to C<stderr>).
356
357 Verbose messages are disabled unless the environment variable
358 C<LIBGUESTFS_DEBUG> is defined and set to C<1>.");
359
360   ("get_verbose", (RBool "verbose", []), -1, [],
361    [],
362    "get verbose mode",
363    "\
364 This returns the verbose messages flag.");
365
366   ("is_ready", (RBool "ready", []), -1, [],
367    [],
368    "is ready to accept commands",
369    "\
370 This returns true iff this handle is ready to accept commands
371 (in the C<READY> state).
372
373 For more information on states, see L<guestfs(3)>.");
374
375   ("is_config", (RBool "config", []), -1, [],
376    [],
377    "is in configuration state",
378    "\
379 This returns true iff this handle is being configured
380 (in the C<CONFIG> state).
381
382 For more information on states, see L<guestfs(3)>.");
383
384   ("is_launching", (RBool "launching", []), -1, [],
385    [],
386    "is launching subprocess",
387    "\
388 This returns true iff this handle is launching the subprocess
389 (in the C<LAUNCHING> state).
390
391 For more information on states, see L<guestfs(3)>.");
392
393   ("is_busy", (RBool "busy", []), -1, [],
394    [],
395    "is busy processing a command",
396    "\
397 This returns true iff this handle is busy processing a command
398 (in the C<BUSY> state).
399
400 For more information on states, see L<guestfs(3)>.");
401
402   ("get_state", (RInt "state", []), -1, [],
403    [],
404    "get the current state",
405    "\
406 This returns the current state as an opaque integer.  This is
407 only useful for printing debug and internal error messages.
408
409 For more information on states, see L<guestfs(3)>.");
410
411   ("set_busy", (RErr, []), -1, [NotInFish],
412    [],
413    "set state to busy",
414    "\
415 This sets the state to C<BUSY>.  This is only used when implementing
416 actions using the low-level API.
417
418 For more information on states, see L<guestfs(3)>.");
419
420   ("set_ready", (RErr, []), -1, [NotInFish],
421    [],
422    "set state to ready",
423    "\
424 This sets the state to C<READY>.  This is only used when implementing
425 actions using the low-level API.
426
427 For more information on states, see L<guestfs(3)>.");
428
429 ]
430
431 let daemon_functions = [
432   ("mount", (RErr, [String "device"; String "mountpoint"]), 1, [],
433    [InitEmpty, TestOutput (
434       [["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ","];
435        ["mkfs"; "ext2"; "/dev/sda1"];
436        ["mount"; "/dev/sda1"; "/"];
437        ["write_file"; "/new"; "new file contents"; "0"];
438        ["cat"; "/new"]], "new file contents")],
439    "mount a guest disk at a position in the filesystem",
440    "\
441 Mount a guest disk at a position in the filesystem.  Block devices
442 are named C</dev/sda>, C</dev/sdb> and so on, as they were added to
443 the guest.  If those block devices contain partitions, they will have
444 the usual names (eg. C</dev/sda1>).  Also LVM C</dev/VG/LV>-style
445 names can be used.
446
447 The rules are the same as for L<mount(2)>:  A filesystem must
448 first be mounted on C</> before others can be mounted.  Other
449 filesystems can only be mounted on directories which already
450 exist.
451
452 The mounted filesystem is writable, if we have sufficient permissions
453 on the underlying device.
454
455 The filesystem options C<sync> and C<noatime> are set with this
456 call, in order to improve reliability.");
457
458   ("sync", (RErr, []), 2, [],
459    [ InitEmpty, TestRun [["sync"]]],
460    "sync disks, writes are flushed through to the disk image",
461    "\
462 This syncs the disk, so that any writes are flushed through to the
463 underlying disk image.
464
465 You should always call this if you have modified a disk image, before
466 closing the handle.");
467
468   ("touch", (RErr, [String "path"]), 3, [],
469    [InitBasicFS, TestOutputTrue (
470       [["touch"; "/new"];
471        ["exists"; "/new"]])],
472    "update file timestamps or create a new file",
473    "\
474 Touch acts like the L<touch(1)> command.  It can be used to
475 update the timestamps on a file, or, if the file does not exist,
476 to create a new zero-length file.");
477
478   ("cat", (RString "content", [String "path"]), 4, [ProtocolLimitWarning],
479    [InitBasicFS, TestOutput (
480       [["write_file"; "/new"; "new file contents"; "0"];
481        ["cat"; "/new"]], "new file contents")],
482    "list the contents of a file",
483    "\
484 Return the contents of the file named C<path>.
485
486 Note that this function cannot correctly handle binary files
487 (specifically, files containing C<\\0> character which is treated
488 as end of string).  For those you need to use the C<guestfs_download>
489 function which has a more complex interface.");
490
491   ("ll", (RString "listing", [String "directory"]), 5, [],
492    [], (* XXX Tricky to test because it depends on the exact format
493         * of the 'ls -l' command, which changes between F10 and F11.
494         *)
495    "list the files in a directory (long format)",
496    "\
497 List the files in C<directory> (relative to the root directory,
498 there is no cwd) in the format of 'ls -la'.
499
500 This command is mostly useful for interactive sessions.  It
501 is I<not> intended that you try to parse the output string.");
502
503   ("ls", (RStringList "listing", [String "directory"]), 6, [],
504    [InitBasicFS, TestOutputList (
505       [["touch"; "/new"];
506        ["touch"; "/newer"];
507        ["touch"; "/newest"];
508        ["ls"; "/"]], ["lost+found"; "new"; "newer"; "newest"])],
509    "list the files in a directory",
510    "\
511 List the files in C<directory> (relative to the root directory,
512 there is no cwd).  The '.' and '..' entries are not returned, but
513 hidden files are shown.
514
515 This command is mostly useful for interactive sessions.  Programs
516 should probably use C<guestfs_readdir> instead.");
517
518   ("list_devices", (RStringList "devices", []), 7, [],
519    [InitEmpty, TestOutputList (
520       [["list_devices"]], ["/dev/sda"; "/dev/sdb"; "/dev/sdc"])],
521    "list the block devices",
522    "\
523 List all the block devices.
524
525 The full block device names are returned, eg. C</dev/sda>");
526
527   ("list_partitions", (RStringList "partitions", []), 8, [],
528    [InitBasicFS, TestOutputList (
529       [["list_partitions"]], ["/dev/sda1"]);
530     InitEmpty, TestOutputList (
531       [["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ",10 ,20 ,"];
532        ["list_partitions"]], ["/dev/sda1"; "/dev/sda2"; "/dev/sda3"])],
533    "list the partitions",
534    "\
535 List all the partitions detected on all block devices.
536
537 The full partition device names are returned, eg. C</dev/sda1>
538
539 This does not return logical volumes.  For that you will need to
540 call C<guestfs_lvs>.");
541
542   ("pvs", (RStringList "physvols", []), 9, [],
543    [InitBasicFSonLVM, TestOutputList (
544       [["pvs"]], ["/dev/sda1"]);
545     InitEmpty, TestOutputList (
546       [["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ",10 ,20 ,"];
547        ["pvcreate"; "/dev/sda1"];
548        ["pvcreate"; "/dev/sda2"];
549        ["pvcreate"; "/dev/sda3"];
550        ["pvs"]], ["/dev/sda1"; "/dev/sda2"; "/dev/sda3"])],
551    "list the LVM physical volumes (PVs)",
552    "\
553 List all the physical volumes detected.  This is the equivalent
554 of the L<pvs(8)> command.
555
556 This returns a list of just the device names that contain
557 PVs (eg. C</dev/sda2>).
558
559 See also C<guestfs_pvs_full>.");
560
561   ("vgs", (RStringList "volgroups", []), 10, [],
562    [InitBasicFSonLVM, TestOutputList (
563       [["vgs"]], ["VG"]);
564     InitEmpty, TestOutputList (
565       [["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ",10 ,20 ,"];
566        ["pvcreate"; "/dev/sda1"];
567        ["pvcreate"; "/dev/sda2"];
568        ["pvcreate"; "/dev/sda3"];
569        ["vgcreate"; "VG1"; "/dev/sda1 /dev/sda2"];
570        ["vgcreate"; "VG2"; "/dev/sda3"];
571        ["vgs"]], ["VG1"; "VG2"])],
572    "list the LVM volume groups (VGs)",
573    "\
574 List all the volumes groups detected.  This is the equivalent
575 of the L<vgs(8)> command.
576
577 This returns a list of just the volume group names that were
578 detected (eg. C<VolGroup00>).
579
580 See also C<guestfs_vgs_full>.");
581
582   ("lvs", (RStringList "logvols", []), 11, [],
583    [InitBasicFSonLVM, TestOutputList (
584       [["lvs"]], ["/dev/VG/LV"]);
585     InitEmpty, TestOutputList (
586       [["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ",10 ,20 ,"];
587        ["pvcreate"; "/dev/sda1"];
588        ["pvcreate"; "/dev/sda2"];
589        ["pvcreate"; "/dev/sda3"];
590        ["vgcreate"; "VG1"; "/dev/sda1 /dev/sda2"];
591        ["vgcreate"; "VG2"; "/dev/sda3"];
592        ["lvcreate"; "LV1"; "VG1"; "50"];
593        ["lvcreate"; "LV2"; "VG1"; "50"];
594        ["lvcreate"; "LV3"; "VG2"; "50"];
595        ["lvs"]], ["/dev/VG1/LV1"; "/dev/VG1/LV2"; "/dev/VG2/LV3"])],
596    "list the LVM logical volumes (LVs)",
597    "\
598 List all the logical volumes detected.  This is the equivalent
599 of the L<lvs(8)> command.
600
601 This returns a list of the logical volume device names
602 (eg. C</dev/VolGroup00/LogVol00>).
603
604 See also C<guestfs_lvs_full>.");
605
606   ("pvs_full", (RPVList "physvols", []), 12, [],
607    [], (* XXX how to test? *)
608    "list the LVM physical volumes (PVs)",
609    "\
610 List all the physical volumes detected.  This is the equivalent
611 of the L<pvs(8)> command.  The \"full\" version includes all fields.");
612
613   ("vgs_full", (RVGList "volgroups", []), 13, [],
614    [], (* XXX how to test? *)
615    "list the LVM volume groups (VGs)",
616    "\
617 List all the volumes groups detected.  This is the equivalent
618 of the L<vgs(8)> command.  The \"full\" version includes all fields.");
619
620   ("lvs_full", (RLVList "logvols", []), 14, [],
621    [], (* XXX how to test? *)
622    "list the LVM logical volumes (LVs)",
623    "\
624 List all the logical volumes detected.  This is the equivalent
625 of the L<lvs(8)> command.  The \"full\" version includes all fields.");
626
627   ("read_lines", (RStringList "lines", [String "path"]), 15, [],
628    [InitBasicFS, TestOutputList (
629       [["write_file"; "/new"; "line1\r\nline2\nline3"; "0"];
630        ["read_lines"; "/new"]], ["line1"; "line2"; "line3"]);
631     InitBasicFS, TestOutputList (
632       [["write_file"; "/new"; ""; "0"];
633        ["read_lines"; "/new"]], [])],
634    "read file as lines",
635    "\
636 Return the contents of the file named C<path>.
637
638 The file contents are returned as a list of lines.  Trailing
639 C<LF> and C<CRLF> character sequences are I<not> returned.
640
641 Note that this function cannot correctly handle binary files
642 (specifically, files containing C<\\0> character which is treated
643 as end of line).  For those you need to use the C<guestfs_read_file>
644 function which has a more complex interface.");
645
646   ("aug_init", (RErr, [String "root"; Int "flags"]), 16, [],
647    [], (* XXX Augeas code needs tests. *)
648    "create a new Augeas handle",
649    "\
650 Create a new Augeas handle for editing configuration files.
651 If there was any previous Augeas handle associated with this
652 guestfs session, then it is closed.
653
654 You must call this before using any other C<guestfs_aug_*>
655 commands.
656
657 C<root> is the filesystem root.  C<root> must not be NULL,
658 use C</> instead.
659
660 The flags are the same as the flags defined in
661 E<lt>augeas.hE<gt>, the logical I<or> of the following
662 integers:
663
664 =over 4
665
666 =item C<AUG_SAVE_BACKUP> = 1
667
668 Keep the original file with a C<.augsave> extension.
669
670 =item C<AUG_SAVE_NEWFILE> = 2
671
672 Save changes into a file with extension C<.augnew>, and
673 do not overwrite original.  Overrides C<AUG_SAVE_BACKUP>.
674
675 =item C<AUG_TYPE_CHECK> = 4
676
677 Typecheck lenses (can be expensive).
678
679 =item C<AUG_NO_STDINC> = 8
680
681 Do not use standard load path for modules.
682
683 =item C<AUG_SAVE_NOOP> = 16
684
685 Make save a no-op, just record what would have been changed.
686
687 =item C<AUG_NO_LOAD> = 32
688
689 Do not load the tree in C<guestfs_aug_init>.
690
691 =back
692
693 To close the handle, you can call C<guestfs_aug_close>.
694
695 To find out more about Augeas, see L<http://augeas.net/>.");
696
697   ("aug_close", (RErr, []), 26, [],
698    [], (* XXX Augeas code needs tests. *)
699    "close the current Augeas handle",
700    "\
701 Close the current Augeas handle and free up any resources
702 used by it.  After calling this, you have to call
703 C<guestfs_aug_init> again before you can use any other
704 Augeas functions.");
705
706   ("aug_defvar", (RInt "nrnodes", [String "name"; OptString "expr"]), 17, [],
707    [], (* XXX Augeas code needs tests. *)
708    "define an Augeas variable",
709    "\
710 Defines an Augeas variable C<name> whose value is the result
711 of evaluating C<expr>.  If C<expr> is NULL, then C<name> is
712 undefined.
713
714 On success this returns the number of nodes in C<expr>, or
715 C<0> if C<expr> evaluates to something which is not a nodeset.");
716
717   ("aug_defnode", (RIntBool ("nrnodes", "created"), [String "name"; String "expr"; String "val"]), 18, [],
718    [], (* XXX Augeas code needs tests. *)
719    "define an Augeas node",
720    "\
721 Defines a variable C<name> whose value is the result of
722 evaluating C<expr>.
723
724 If C<expr> evaluates to an empty nodeset, a node is created,
725 equivalent to calling C<guestfs_aug_set> C<expr>, C<value>.
726 C<name> will be the nodeset containing that single node.
727
728 On success this returns a pair containing the
729 number of nodes in the nodeset, and a boolean flag
730 if a node was created.");
731
732   ("aug_get", (RString "val", [String "path"]), 19, [],
733    [], (* XXX Augeas code needs tests. *)
734    "look up the value of an Augeas path",
735    "\
736 Look up the value associated with C<path>.  If C<path>
737 matches exactly one node, the C<value> is returned.");
738
739   ("aug_set", (RErr, [String "path"; String "val"]), 20, [],
740    [], (* XXX Augeas code needs tests. *)
741    "set Augeas path to value",
742    "\
743 Set the value associated with C<path> to C<value>.");
744
745   ("aug_insert", (RErr, [String "path"; String "label"; Bool "before"]), 21, [],
746    [], (* XXX Augeas code needs tests. *)
747    "insert a sibling Augeas node",
748    "\
749 Create a new sibling C<label> for C<path>, inserting it into
750 the tree before or after C<path> (depending on the boolean
751 flag C<before>).
752
753 C<path> must match exactly one existing node in the tree, and
754 C<label> must be a label, ie. not contain C</>, C<*> or end
755 with a bracketed index C<[N]>.");
756
757   ("aug_rm", (RInt "nrnodes", [String "path"]), 22, [],
758    [], (* XXX Augeas code needs tests. *)
759    "remove an Augeas path",
760    "\
761 Remove C<path> and all of its children.
762
763 On success this returns the number of entries which were removed.");
764
765   ("aug_mv", (RErr, [String "src"; String "dest"]), 23, [],
766    [], (* XXX Augeas code needs tests. *)
767    "move Augeas node",
768    "\
769 Move the node C<src> to C<dest>.  C<src> must match exactly
770 one node.  C<dest> is overwritten if it exists.");
771
772   ("aug_match", (RStringList "matches", [String "path"]), 24, [],
773    [], (* XXX Augeas code needs tests. *)
774    "return Augeas nodes which match path",
775    "\
776 Returns a list of paths which match the path expression C<path>.
777 The returned paths are sufficiently qualified so that they match
778 exactly one node in the current tree.");
779
780   ("aug_save", (RErr, []), 25, [],
781    [], (* XXX Augeas code needs tests. *)
782    "write all pending Augeas changes to disk",
783    "\
784 This writes all pending changes to disk.
785
786 The flags which were passed to C<guestfs_aug_init> affect exactly
787 how files are saved.");
788
789   ("aug_load", (RErr, []), 27, [],
790    [], (* XXX Augeas code needs tests. *)
791    "load files into the tree",
792    "\
793 Load files into the tree.
794
795 See C<aug_load> in the Augeas documentation for the full gory
796 details.");
797
798   ("aug_ls", (RStringList "matches", [String "path"]), 28, [],
799    [], (* XXX Augeas code needs tests. *)
800    "list Augeas nodes under a path",
801    "\
802 This is just a shortcut for listing C<guestfs_aug_match>
803 C<path/*> and sorting the resulting nodes into alphabetical order.");
804
805   ("rm", (RErr, [String "path"]), 29, [],
806    [InitBasicFS, TestRun
807       [["touch"; "/new"];
808        ["rm"; "/new"]];
809     InitBasicFS, TestLastFail
810       [["rm"; "/new"]];
811     InitBasicFS, TestLastFail
812       [["mkdir"; "/new"];
813        ["rm"; "/new"]]],
814    "remove a file",
815    "\
816 Remove the single file C<path>.");
817
818   ("rmdir", (RErr, [String "path"]), 30, [],
819    [InitBasicFS, TestRun
820       [["mkdir"; "/new"];
821        ["rmdir"; "/new"]];
822     InitBasicFS, TestLastFail
823       [["rmdir"; "/new"]];
824     InitBasicFS, TestLastFail
825       [["touch"; "/new"];
826        ["rmdir"; "/new"]]],
827    "remove a directory",
828    "\
829 Remove the single directory C<path>.");
830
831   ("rm_rf", (RErr, [String "path"]), 31, [],
832    [InitBasicFS, TestOutputFalse
833       [["mkdir"; "/new"];
834        ["mkdir"; "/new/foo"];
835        ["touch"; "/new/foo/bar"];
836        ["rm_rf"; "/new"];
837        ["exists"; "/new"]]],
838    "remove a file or directory recursively",
839    "\
840 Remove the file or directory C<path>, recursively removing the
841 contents if its a directory.  This is like the C<rm -rf> shell
842 command.");
843
844   ("mkdir", (RErr, [String "path"]), 32, [],
845    [InitBasicFS, TestOutputTrue
846       [["mkdir"; "/new"];
847        ["is_dir"; "/new"]];
848     InitBasicFS, TestLastFail
849       [["mkdir"; "/new/foo/bar"]]],
850    "create a directory",
851    "\
852 Create a directory named C<path>.");
853
854   ("mkdir_p", (RErr, [String "path"]), 33, [],
855    [InitBasicFS, TestOutputTrue
856       [["mkdir_p"; "/new/foo/bar"];
857        ["is_dir"; "/new/foo/bar"]];
858     InitBasicFS, TestOutputTrue
859       [["mkdir_p"; "/new/foo/bar"];
860        ["is_dir"; "/new/foo"]];
861     InitBasicFS, TestOutputTrue
862       [["mkdir_p"; "/new/foo/bar"];
863        ["is_dir"; "/new"]]],
864    "create a directory and parents",
865    "\
866 Create a directory named C<path>, creating any parent directories
867 as necessary.  This is like the C<mkdir -p> shell command.");
868
869   ("chmod", (RErr, [Int "mode"; String "path"]), 34, [],
870    [], (* XXX Need stat command to test *)
871    "change file mode",
872    "\
873 Change the mode (permissions) of C<path> to C<mode>.  Only
874 numeric modes are supported.");
875
876   ("chown", (RErr, [Int "owner"; Int "group"; String "path"]), 35, [],
877    [], (* XXX Need stat command to test *)
878    "change file owner and group",
879    "\
880 Change the file owner to C<owner> and group to C<group>.
881
882 Only numeric uid and gid are supported.  If you want to use
883 names, you will need to locate and parse the password file
884 yourself (Augeas support makes this relatively easy).");
885
886   ("exists", (RBool "existsflag", [String "path"]), 36, [],
887    [InitBasicFS, TestOutputTrue (
888       [["touch"; "/new"];
889        ["exists"; "/new"]]);
890     InitBasicFS, TestOutputTrue (
891       [["mkdir"; "/new"];
892        ["exists"; "/new"]])],
893    "test if file or directory exists",
894    "\
895 This returns C<true> if and only if there is a file, directory
896 (or anything) with the given C<path> name.
897
898 See also C<guestfs_is_file>, C<guestfs_is_dir>, C<guestfs_stat>.");
899
900   ("is_file", (RBool "fileflag", [String "path"]), 37, [],
901    [InitBasicFS, TestOutputTrue (
902       [["touch"; "/new"];
903        ["is_file"; "/new"]]);
904     InitBasicFS, TestOutputFalse (
905       [["mkdir"; "/new"];
906        ["is_file"; "/new"]])],
907    "test if file exists",
908    "\
909 This returns C<true> if and only if there is a file
910 with the given C<path> name.  Note that it returns false for
911 other objects like directories.
912
913 See also C<guestfs_stat>.");
914
915   ("is_dir", (RBool "dirflag", [String "path"]), 38, [],
916    [InitBasicFS, TestOutputFalse (
917       [["touch"; "/new"];
918        ["is_dir"; "/new"]]);
919     InitBasicFS, TestOutputTrue (
920       [["mkdir"; "/new"];
921        ["is_dir"; "/new"]])],
922    "test if file exists",
923    "\
924 This returns C<true> if and only if there is a directory
925 with the given C<path> name.  Note that it returns false for
926 other objects like files.
927
928 See also C<guestfs_stat>.");
929
930   ("pvcreate", (RErr, [String "device"]), 39, [],
931    [InitEmpty, TestOutputList (
932       [["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ",10 ,20 ,"];
933        ["pvcreate"; "/dev/sda1"];
934        ["pvcreate"; "/dev/sda2"];
935        ["pvcreate"; "/dev/sda3"];
936        ["pvs"]], ["/dev/sda1"; "/dev/sda2"; "/dev/sda3"])],
937    "create an LVM physical volume",
938    "\
939 This creates an LVM physical volume on the named C<device>,
940 where C<device> should usually be a partition name such
941 as C</dev/sda1>.");
942
943   ("vgcreate", (RErr, [String "volgroup"; StringList "physvols"]), 40, [],
944    [InitEmpty, TestOutputList (
945       [["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ",10 ,20 ,"];
946        ["pvcreate"; "/dev/sda1"];
947        ["pvcreate"; "/dev/sda2"];
948        ["pvcreate"; "/dev/sda3"];
949        ["vgcreate"; "VG1"; "/dev/sda1 /dev/sda2"];
950        ["vgcreate"; "VG2"; "/dev/sda3"];
951        ["vgs"]], ["VG1"; "VG2"])],
952    "create an LVM volume group",
953    "\
954 This creates an LVM volume group called C<volgroup>
955 from the non-empty list of physical volumes C<physvols>.");
956
957   ("lvcreate", (RErr, [String "logvol"; String "volgroup"; Int "mbytes"]), 41, [],
958    [InitEmpty, TestOutputList (
959       [["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ",10 ,20 ,"];
960        ["pvcreate"; "/dev/sda1"];
961        ["pvcreate"; "/dev/sda2"];
962        ["pvcreate"; "/dev/sda3"];
963        ["vgcreate"; "VG1"; "/dev/sda1 /dev/sda2"];
964        ["vgcreate"; "VG2"; "/dev/sda3"];
965        ["lvcreate"; "LV1"; "VG1"; "50"];
966        ["lvcreate"; "LV2"; "VG1"; "50"];
967        ["lvcreate"; "LV3"; "VG2"; "50"];
968        ["lvcreate"; "LV4"; "VG2"; "50"];
969        ["lvcreate"; "LV5"; "VG2"; "50"];
970        ["lvs"]],
971       ["/dev/VG1/LV1"; "/dev/VG1/LV2";
972        "/dev/VG2/LV3"; "/dev/VG2/LV4"; "/dev/VG2/LV5"])],
973    "create an LVM volume group",
974    "\
975 This creates an LVM volume group called C<logvol>
976 on the volume group C<volgroup>, with C<size> megabytes.");
977
978   ("mkfs", (RErr, [String "fstype"; String "device"]), 42, [],
979    [InitEmpty, TestOutput (
980       [["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ","];
981        ["mkfs"; "ext2"; "/dev/sda1"];
982        ["mount"; "/dev/sda1"; "/"];
983        ["write_file"; "/new"; "new file contents"; "0"];
984        ["cat"; "/new"]], "new file contents")],
985    "make a filesystem",
986    "\
987 This creates a filesystem on C<device> (usually a partition
988 of LVM logical volume).  The filesystem type is C<fstype>, for
989 example C<ext3>.");
990
991   ("sfdisk", (RErr, [String "device";
992                      Int "cyls"; Int "heads"; Int "sectors";
993                      StringList "lines"]), 43, [DangerWillRobinson],
994    [],
995    "create partitions on a block device",
996    "\
997 This is a direct interface to the L<sfdisk(8)> program for creating
998 partitions on block devices.
999
1000 C<device> should be a block device, for example C</dev/sda>.
1001
1002 C<cyls>, C<heads> and C<sectors> are the number of cylinders, heads
1003 and sectors on the device, which are passed directly to sfdisk as
1004 the I<-C>, I<-H> and I<-S> parameters.  If you pass C<0> for any
1005 of these, then the corresponding parameter is omitted.  Usually for
1006 'large' disks, you can just pass C<0> for these, but for small
1007 (floppy-sized) disks, sfdisk (or rather, the kernel) cannot work
1008 out the right geometry and you will need to tell it.
1009
1010 C<lines> is a list of lines that we feed to C<sfdisk>.  For more
1011 information refer to the L<sfdisk(8)> manpage.
1012
1013 To create a single partition occupying the whole disk, you would
1014 pass C<lines> as a single element list, when the single element being
1015 the string C<,> (comma).");
1016
1017   ("write_file", (RErr, [String "path"; String "content"; Int "size"]), 44, [ProtocolLimitWarning],
1018    [InitBasicFS, TestOutput (
1019       [["write_file"; "/new"; "new file contents"; "0"];
1020        ["cat"; "/new"]], "new file contents");
1021     InitBasicFS, TestOutput (
1022       [["write_file"; "/new"; "\nnew file contents\n"; "0"];
1023        ["cat"; "/new"]], "\nnew file contents\n");
1024     InitBasicFS, TestOutput (
1025       [["write_file"; "/new"; "\n\n"; "0"];
1026        ["cat"; "/new"]], "\n\n");
1027     InitBasicFS, TestOutput (
1028       [["write_file"; "/new"; ""; "0"];
1029        ["cat"; "/new"]], "");
1030     InitBasicFS, TestOutput (
1031       [["write_file"; "/new"; "\n\n\n"; "0"];
1032        ["cat"; "/new"]], "\n\n\n");
1033     InitBasicFS, TestOutput (
1034       [["write_file"; "/new"; "\n"; "0"];
1035        ["cat"; "/new"]], "\n")],
1036    "create a file",
1037    "\
1038 This call creates a file called C<path>.  The contents of the
1039 file is the string C<content> (which can contain any 8 bit data),
1040 with length C<size>.
1041
1042 As a special case, if C<size> is C<0>
1043 then the length is calculated using C<strlen> (so in this case
1044 the content cannot contain embedded ASCII NULs).");
1045
1046   ("umount", (RErr, [String "pathordevice"]), 45, [FishAlias "unmount"],
1047    [InitEmpty, TestOutputList (
1048       [["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ","];
1049        ["mkfs"; "ext2"; "/dev/sda1"];
1050        ["mount"; "/dev/sda1"; "/"];
1051        ["mounts"]], ["/dev/sda1"]);
1052     InitEmpty, TestOutputList (
1053       [["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ","];
1054        ["mkfs"; "ext2"; "/dev/sda1"];
1055        ["mount"; "/dev/sda1"; "/"];
1056        ["umount"; "/"];
1057        ["mounts"]], [])],
1058    "unmount a filesystem",
1059    "\
1060 This unmounts the given filesystem.  The filesystem may be
1061 specified either by its mountpoint (path) or the device which
1062 contains the filesystem.");
1063
1064   ("mounts", (RStringList "devices", []), 46, [],
1065    [InitBasicFS, TestOutputList (
1066       [["mounts"]], ["/dev/sda1"])],
1067    "show mounted filesystems",
1068    "\
1069 This returns the list of currently mounted filesystems.  It returns
1070 the list of devices (eg. C</dev/sda1>, C</dev/VG/LV>).
1071
1072 Some internal mounts are not shown.");
1073
1074   ("umount_all", (RErr, []), 47, [FishAlias "unmount-all"],
1075    [InitBasicFS, TestOutputList (
1076       [["umount_all"];
1077        ["mounts"]], [])],
1078    "unmount all filesystems",
1079    "\
1080 This unmounts all mounted filesystems.
1081
1082 Some internal mounts are not unmounted by this call.");
1083
1084   ("lvm_remove_all", (RErr, []), 48, [DangerWillRobinson],
1085    [],
1086    "remove all LVM LVs, VGs and PVs",
1087    "\
1088 This command removes all LVM logical volumes, volume groups
1089 and physical volumes.");
1090
1091   ("file", (RString "description", [String "path"]), 49, [],
1092    [InitBasicFS, TestOutput (
1093       [["touch"; "/new"];
1094        ["file"; "/new"]], "empty");
1095     InitBasicFS, TestOutput (
1096       [["write_file"; "/new"; "some content\n"; "0"];
1097        ["file"; "/new"]], "ASCII text");
1098     InitBasicFS, TestLastFail (
1099       [["file"; "/nofile"]])],
1100    "determine file type",
1101    "\
1102 This call uses the standard L<file(1)> command to determine
1103 the type or contents of the file.  This also works on devices,
1104 for example to find out whether a partition contains a filesystem.
1105
1106 The exact command which runs is C<file -bsL path>.  Note in
1107 particular that the filename is not prepended to the output
1108 (the C<-b> option).");
1109
1110   ("command", (RString "output", [StringList "arguments"]), 50, [],
1111    [], (* XXX how to test? *)
1112    "run a command from the guest filesystem",
1113    "\
1114 This call runs a command from the guest filesystem.  The
1115 filesystem must be mounted, and must contain a compatible
1116 operating system (ie. something Linux, with the same
1117 or compatible processor architecture).
1118
1119 The single parameter is an argv-style list of arguments.
1120 The first element is the name of the program to run.
1121 Subsequent elements are parameters.  The list must be
1122 non-empty (ie. must contain a program name).
1123
1124 The C<$PATH> environment variable will contain at least
1125 C</usr/bin> and C</bin>.  If you require a program from
1126 another location, you should provide the full path in the
1127 first parameter.
1128
1129 Shared libraries and data files required by the program
1130 must be available on filesystems which are mounted in the
1131 correct places.  It is the caller's responsibility to ensure
1132 all filesystems that are needed are mounted at the right
1133 locations.");
1134
1135   ("command_lines", (RStringList "lines", [StringList "arguments"]), 51, [],
1136    [], (* XXX how to test? *)
1137    "run a command, returning lines",
1138    "\
1139 This is the same as C<guestfs_command>, but splits the
1140 result into a list of lines.");
1141
1142   ("stat", (RStat "statbuf", [String "path"]), 52, [],
1143    [InitBasicFS, TestOutputStruct (
1144       [["touch"; "/new"];
1145        ["stat"; "/new"]], [CompareWithInt ("size", 0)])],
1146    "get file information",
1147    "\
1148 Returns file information for the given C<path>.
1149
1150 This is the same as the C<stat(2)> system call.");
1151
1152   ("lstat", (RStat "statbuf", [String "path"]), 53, [],
1153    [InitBasicFS, TestOutputStruct (
1154       [["touch"; "/new"];
1155        ["lstat"; "/new"]], [CompareWithInt ("size", 0)])],
1156    "get file information for a symbolic link",
1157    "\
1158 Returns file information for the given C<path>.
1159
1160 This is the same as C<guestfs_stat> except that if C<path>
1161 is a symbolic link, then the link is stat-ed, not the file it
1162 refers to.
1163
1164 This is the same as the C<lstat(2)> system call.");
1165
1166   ("statvfs", (RStatVFS "statbuf", [String "path"]), 54, [],
1167    [InitBasicFS, TestOutputStruct (
1168       [["statvfs"; "/"]], [CompareWithInt ("bfree", 487702);
1169                            CompareWithInt ("blocks", 490020);
1170                            CompareWithInt ("bsize", 1024)])],
1171    "get file system statistics",
1172    "\
1173 Returns file system statistics for any mounted file system.
1174 C<path> should be a file or directory in the mounted file system
1175 (typically it is the mount point itself, but it doesn't need to be).
1176
1177 This is the same as the C<statvfs(2)> system call.");
1178
1179   ("tune2fs_l", (RHashtable "superblock", [String "device"]), 55, [],
1180    [], (* XXX test *)
1181    "get ext2/ext3/ext4 superblock details",
1182    "\
1183 This returns the contents of the ext2, ext3 or ext4 filesystem
1184 superblock on C<device>.
1185
1186 It is the same as running C<tune2fs -l device>.  See L<tune2fs(8)>
1187 manpage for more details.  The list of fields returned isn't
1188 clearly defined, and depends on both the version of C<tune2fs>
1189 that libguestfs was built against, and the filesystem itself.");
1190
1191   ("blockdev_setro", (RErr, [String "device"]), 56, [],
1192    [InitEmpty, TestOutputTrue (
1193       [["blockdev_setro"; "/dev/sda"];
1194        ["blockdev_getro"; "/dev/sda"]])],
1195    "set block device to read-only",
1196    "\
1197 Sets the block device named C<device> to read-only.
1198
1199 This uses the L<blockdev(8)> command.");
1200
1201   ("blockdev_setrw", (RErr, [String "device"]), 57, [],
1202    [InitEmpty, TestOutputFalse (
1203       [["blockdev_setrw"; "/dev/sda"];
1204        ["blockdev_getro"; "/dev/sda"]])],
1205    "set block device to read-write",
1206    "\
1207 Sets the block device named C<device> to read-write.
1208
1209 This uses the L<blockdev(8)> command.");
1210
1211   ("blockdev_getro", (RBool "ro", [String "device"]), 58, [],
1212    [InitEmpty, TestOutputTrue (
1213       [["blockdev_setro"; "/dev/sda"];
1214        ["blockdev_getro"; "/dev/sda"]])],
1215    "is block device set to read-only",
1216    "\
1217 Returns a boolean indicating if the block device is read-only
1218 (true if read-only, false if not).
1219
1220 This uses the L<blockdev(8)> command.");
1221
1222   ("blockdev_getss", (RInt "sectorsize", [String "device"]), 59, [],
1223    [InitEmpty, TestOutputInt (
1224       [["blockdev_getss"; "/dev/sda"]], 512)],
1225    "get sectorsize of block device",
1226    "\
1227 This returns the size of sectors on a block device.
1228 Usually 512, but can be larger for modern devices.
1229
1230 (Note, this is not the size in sectors, use C<guestfs_blockdev_getsz>
1231 for that).
1232
1233 This uses the L<blockdev(8)> command.");
1234
1235   ("blockdev_getbsz", (RInt "blocksize", [String "device"]), 60, [],
1236    [InitEmpty, TestOutputInt (
1237       [["blockdev_getbsz"; "/dev/sda"]], 4096)],
1238    "get blocksize of block device",
1239    "\
1240 This returns the block size of a device.
1241
1242 (Note this is different from both I<size in blocks> and
1243 I<filesystem block size>).
1244
1245 This uses the L<blockdev(8)> command.");
1246
1247   ("blockdev_setbsz", (RErr, [String "device"; Int "blocksize"]), 61, [],
1248    [], (* XXX test *)
1249    "set blocksize of block device",
1250    "\
1251 This sets the block size of a device.
1252
1253 (Note this is different from both I<size in blocks> and
1254 I<filesystem block size>).
1255
1256 This uses the L<blockdev(8)> command.");
1257
1258   ("blockdev_getsz", (RInt64 "sizeinsectors", [String "device"]), 62, [],
1259    [InitEmpty, TestOutputInt (
1260       [["blockdev_getsz"; "/dev/sda"]], 1024000)],
1261    "get total size of device in 512-byte sectors",
1262    "\
1263 This returns the size of the device in units of 512-byte sectors
1264 (even if the sectorsize isn't 512 bytes ... weird).
1265
1266 See also C<guestfs_blockdev_getss> for the real sector size of
1267 the device, and C<guestfs_blockdev_getsize64> for the more
1268 useful I<size in bytes>.
1269
1270 This uses the L<blockdev(8)> command.");
1271
1272   ("blockdev_getsize64", (RInt64 "sizeinbytes", [String "device"]), 63, [],
1273    [InitEmpty, TestOutputInt (
1274       [["blockdev_getsize64"; "/dev/sda"]], 524288000)],
1275    "get total size of device in bytes",
1276    "\
1277 This returns the size of the device in bytes.
1278
1279 See also C<guestfs_blockdev_getsz>.
1280
1281 This uses the L<blockdev(8)> command.");
1282
1283   ("blockdev_flushbufs", (RErr, [String "device"]), 64, [],
1284    [InitEmpty, TestRun
1285       [["blockdev_flushbufs"; "/dev/sda"]]],
1286    "flush device buffers",
1287    "\
1288 This tells the kernel to flush internal buffers associated
1289 with C<device>.
1290
1291 This uses the L<blockdev(8)> command.");
1292
1293   ("blockdev_rereadpt", (RErr, [String "device"]), 65, [],
1294    [InitEmpty, TestRun
1295       [["blockdev_rereadpt"; "/dev/sda"]]],
1296    "reread partition table",
1297    "\
1298 Reread the partition table on C<device>.
1299
1300 This uses the L<blockdev(8)> command.");
1301
1302   ("upload", (RErr, [FileIn "filename"; String "remotefilename"]), 66, [],
1303    [InitBasicFS, TestOutput (
1304       (* Pick a file from cwd which isn't likely to change. *)
1305     [["upload"; "COPYING.LIB"; "/COPYING.LIB"];
1306      ["checksum"; "md5"; "/COPYING.LIB"]], "e3eda01d9815f8d24aae2dbd89b68b06")],
1307    "upload a file from the local machine",
1308    "\
1309 Upload local file C<filename> to C<remotefilename> on the
1310 filesystem.
1311
1312 C<filename> can also be a named pipe.
1313
1314 See also C<guestfs_download>.");
1315
1316   ("download", (RErr, [String "remotefilename"; FileOut "filename"]), 67, [],
1317    [InitBasicFS, TestOutput (
1318       (* Pick a file from cwd which isn't likely to change. *)
1319     [["upload"; "COPYING.LIB"; "/COPYING.LIB"];
1320      ["download"; "/COPYING.LIB"; "testdownload.tmp"];
1321      ["upload"; "testdownload.tmp"; "/upload"];
1322      ["checksum"; "md5"; "/upload"]], "e3eda01d9815f8d24aae2dbd89b68b06")],
1323    "download a file to the local machine",
1324    "\
1325 Download file C<remotefilename> and save it as C<filename>
1326 on the local machine.
1327
1328 C<filename> can also be a named pipe.
1329
1330 See also C<guestfs_upload>, C<guestfs_cat>.");
1331
1332   ("checksum", (RString "checksum", [String "csumtype"; String "path"]), 68, [],
1333    [InitBasicFS, TestOutput (
1334       [["write_file"; "/new"; "test\n"; "0"];
1335        ["checksum"; "crc"; "/new"]], "935282863");
1336     InitBasicFS, TestLastFail (
1337       [["checksum"; "crc"; "/new"]]);
1338     InitBasicFS, TestOutput (
1339       [["write_file"; "/new"; "test\n"; "0"];
1340        ["checksum"; "md5"; "/new"]], "d8e8fca2dc0f896fd7cb4cb0031ba249");
1341     InitBasicFS, TestOutput (
1342       [["write_file"; "/new"; "test\n"; "0"];
1343        ["checksum"; "sha1"; "/new"]], "4e1243bd22c66e76c2ba9eddc1f91394e57f9f83");
1344     InitBasicFS, TestOutput (
1345       [["write_file"; "/new"; "test\n"; "0"];
1346        ["checksum"; "sha224"; "/new"]], "52f1bf093f4b7588726035c176c0cdb4376cfea53819f1395ac9e6ec");
1347     InitBasicFS, TestOutput (
1348       [["write_file"; "/new"; "test\n"; "0"];
1349        ["checksum"; "sha256"; "/new"]], "f2ca1bb6c7e907d06dafe4687e579fce76b37e4e93b7605022da52e6ccc26fd2");
1350     InitBasicFS, TestOutput (
1351       [["write_file"; "/new"; "test\n"; "0"];
1352        ["checksum"; "sha384"; "/new"]], "109bb6b5b6d5547c1ce03c7a8bd7d8f80c1cb0957f50c4f7fda04692079917e4f9cad52b878f3d8234e1a170b154b72d");
1353     InitBasicFS, TestOutput (
1354       [["write_file"; "/new"; "test\n"; "0"];
1355        ["checksum"; "sha512"; "/new"]], "0e3e75234abc68f4378a86b3f4b32a198ba301845b0cd6e50106e874345700cc6663a86c1ea125dc5e92be17c98f9a0f85ca9d5f595db2012f7cc3571945c123")],
1356    "compute MD5, SHAx or CRC checksum of file",
1357    "\
1358 This call computes the MD5, SHAx or CRC checksum of the
1359 file named C<path>.
1360
1361 The type of checksum to compute is given by the C<csumtype>
1362 parameter which must have one of the following values:
1363
1364 =over 4
1365
1366 =item C<crc>
1367
1368 Compute the cyclic redundancy check (CRC) specified by POSIX
1369 for the C<cksum> command.
1370
1371 =item C<md5>
1372
1373 Compute the MD5 hash (using the C<md5sum> program).
1374
1375 =item C<sha1>
1376
1377 Compute the SHA1 hash (using the C<sha1sum> program).
1378
1379 =item C<sha224>
1380
1381 Compute the SHA224 hash (using the C<sha224sum> program).
1382
1383 =item C<sha256>
1384
1385 Compute the SHA256 hash (using the C<sha256sum> program).
1386
1387 =item C<sha384>
1388
1389 Compute the SHA384 hash (using the C<sha384sum> program).
1390
1391 =item C<sha512>
1392
1393 Compute the SHA512 hash (using the C<sha512sum> program).
1394
1395 =back
1396
1397 The checksum is returned as a printable string.");
1398
1399   ("tar_in", (RErr, [FileIn "tarfile"; String "directory"]), 69, [],
1400    [InitBasicFS, TestOutput (
1401       [["tar_in"; "images/helloworld.tar"; "/"];
1402        ["cat"; "/hello"]], "hello\n")],
1403    "unpack tarfile to directory",
1404    "\
1405 This command uploads and unpacks local file C<tarfile> (an
1406 I<uncompressed> tar file) into C<directory>.
1407
1408 To upload a compressed tarball, use C<guestfs_tgz_in>.");
1409
1410   ("tar_out", (RErr, [String "directory"; FileOut "tarfile"]), 70, [],
1411    [],
1412    "pack directory into tarfile",
1413    "\
1414 This command packs the contents of C<directory> and downloads
1415 it to local file C<tarfile>.
1416
1417 To download a compressed tarball, use C<guestfs_tgz_out>.");
1418
1419   ("tgz_in", (RErr, [FileIn "tarball"; String "directory"]), 71, [],
1420    [InitBasicFS, TestOutput (
1421       [["tgz_in"; "images/helloworld.tar.gz"; "/"];
1422        ["cat"; "/hello"]], "hello\n")],
1423    "unpack compressed tarball to directory",
1424    "\
1425 This command uploads and unpacks local file C<tarball> (a
1426 I<gzip compressed> tar file) into C<directory>.
1427
1428 To upload an uncompressed tarball, use C<guestfs_tar_in>.");
1429
1430   ("tgz_out", (RErr, [String "directory"; FileOut "tarball"]), 72, [],
1431    [],
1432    "pack directory into compressed tarball",
1433    "\
1434 This command packs the contents of C<directory> and downloads
1435 it to local file C<tarball>.
1436
1437 To download an uncompressed tarball, use C<guestfs_tar_out>.");
1438
1439   ("mount_ro", (RErr, [String "device"; String "mountpoint"]), 73, [],
1440    [InitBasicFS, TestLastFail (
1441       [["umount"; "/"];
1442        ["mount_ro"; "/dev/sda1"; "/"];
1443        ["touch"; "/new"]]);
1444     InitBasicFS, TestOutput (
1445       [["write_file"; "/new"; "data"; "0"];
1446        ["umount"; "/"];
1447        ["mount_ro"; "/dev/sda1"; "/"];
1448        ["cat"; "/new"]], "data")],
1449    "mount a guest disk, read-only",
1450    "\
1451 This is the same as the C<guestfs_mount> command, but it
1452 mounts the filesystem with the read-only (I<-o ro>) flag.");
1453
1454   ("mount_options", (RErr, [String "options"; String "device"; String "mountpoint"]), 74, [],
1455    [],
1456    "mount a guest disk with mount options",
1457    "\
1458 This is the same as the C<guestfs_mount> command, but it
1459 allows you to set the mount options as for the
1460 L<mount(8)> I<-o> flag.");
1461
1462   ("mount_vfs", (RErr, [String "options"; String "vfstype"; String "device"; String "mountpoint"]), 75, [],
1463    [],
1464    "mount a guest disk with mount options and vfstype",
1465    "\
1466 This is the same as the C<guestfs_mount> command, but it
1467 allows you to set both the mount options and the vfstype
1468 as for the L<mount(8)> I<-o> and I<-t> flags.");
1469
1470   ("debug", (RString "result", [String "subcmd"; StringList "extraargs"]), 76, [],
1471    [],
1472    "debugging and internals",
1473    "\
1474 The C<guestfs_debug> command exposes some internals of
1475 C<guestfsd> (the guestfs daemon) that runs inside the
1476 qemu subprocess.
1477
1478 There is no comprehensive help for this command.  You have
1479 to look at the file C<daemon/debug.c> in the libguestfs source
1480 to find out what you can do.");
1481
1482   ("lvremove", (RErr, [String "device"]), 77, [],
1483    [InitEmpty, TestOutputList (
1484       [["pvcreate"; "/dev/sda"];
1485        ["vgcreate"; "VG"; "/dev/sda"];
1486        ["lvcreate"; "LV1"; "VG"; "50"];
1487        ["lvcreate"; "LV2"; "VG"; "50"];
1488        ["lvremove"; "/dev/VG/LV1"];
1489        ["lvs"]], ["/dev/VG/LV2"]);
1490     InitEmpty, TestOutputList (
1491       [["pvcreate"; "/dev/sda"];
1492        ["vgcreate"; "VG"; "/dev/sda"];
1493        ["lvcreate"; "LV1"; "VG"; "50"];
1494        ["lvcreate"; "LV2"; "VG"; "50"];
1495        ["lvremove"; "/dev/VG"];
1496        ["lvs"]], []);
1497     InitEmpty, TestOutputList (
1498       [["pvcreate"; "/dev/sda"];
1499        ["vgcreate"; "VG"; "/dev/sda"];
1500        ["lvcreate"; "LV1"; "VG"; "50"];
1501        ["lvcreate"; "LV2"; "VG"; "50"];
1502        ["lvremove"; "/dev/VG"];
1503        ["vgs"]], ["VG"])],
1504    "remove an LVM logical volume",
1505    "\
1506 Remove an LVM logical volume C<device>, where C<device> is
1507 the path to the LV, such as C</dev/VG/LV>.
1508
1509 You can also remove all LVs in a volume group by specifying
1510 the VG name, C</dev/VG>.");
1511
1512   ("vgremove", (RErr, [String "vgname"]), 78, [],
1513    [InitEmpty, TestOutputList (
1514       [["pvcreate"; "/dev/sda"];
1515        ["vgcreate"; "VG"; "/dev/sda"];
1516        ["lvcreate"; "LV1"; "VG"; "50"];
1517        ["lvcreate"; "LV2"; "VG"; "50"];
1518        ["vgremove"; "VG"];
1519        ["lvs"]], []);
1520     InitEmpty, TestOutputList (
1521       [["pvcreate"; "/dev/sda"];
1522        ["vgcreate"; "VG"; "/dev/sda"];
1523        ["lvcreate"; "LV1"; "VG"; "50"];
1524        ["lvcreate"; "LV2"; "VG"; "50"];
1525        ["vgremove"; "VG"];
1526        ["vgs"]], [])],
1527    "remove an LVM volume group",
1528    "\
1529 Remove an LVM volume group C<vgname>, (for example C<VG>).
1530
1531 This also forcibly removes all logical volumes in the volume
1532 group (if any).");
1533
1534   ("pvremove", (RErr, [String "device"]), 79, [],
1535    [InitEmpty, TestOutputList (
1536       [["pvcreate"; "/dev/sda"];
1537        ["vgcreate"; "VG"; "/dev/sda"];
1538        ["lvcreate"; "LV1"; "VG"; "50"];
1539        ["lvcreate"; "LV2"; "VG"; "50"];
1540        ["vgremove"; "VG"];
1541        ["pvremove"; "/dev/sda"];
1542        ["lvs"]], []);
1543     InitEmpty, TestOutputList (
1544       [["pvcreate"; "/dev/sda"];
1545        ["vgcreate"; "VG"; "/dev/sda"];
1546        ["lvcreate"; "LV1"; "VG"; "50"];
1547        ["lvcreate"; "LV2"; "VG"; "50"];
1548        ["vgremove"; "VG"];
1549        ["pvremove"; "/dev/sda"];
1550        ["vgs"]], []);
1551     InitEmpty, TestOutputList (
1552       [["pvcreate"; "/dev/sda"];
1553        ["vgcreate"; "VG"; "/dev/sda"];
1554        ["lvcreate"; "LV1"; "VG"; "50"];
1555        ["lvcreate"; "LV2"; "VG"; "50"];
1556        ["vgremove"; "VG"];
1557        ["pvremove"; "/dev/sda"];
1558        ["pvs"]], [])],
1559    "remove an LVM physical volume",
1560    "\
1561 This wipes a physical volume C<device> so that LVM will no longer
1562 recognise it.
1563
1564 The implementation uses the C<pvremove> command which refuses to
1565 wipe physical volumes that contain any volume groups, so you have
1566 to remove those first.");
1567
1568   ("set_e2label", (RErr, [String "device"; String "label"]), 80, [],
1569    [InitBasicFS, TestOutput (
1570       [["set_e2label"; "/dev/sda1"; "testlabel"];
1571        ["get_e2label"; "/dev/sda1"]], "testlabel")],
1572    "set the ext2/3/4 filesystem label",
1573    "\
1574 This sets the ext2/3/4 filesystem label of the filesystem on
1575 C<device> to C<label>.  Filesystem labels are limited to
1576 16 characters.
1577
1578 You can use either C<guestfs_tune2fs_l> or C<guestfs_get_e2label>
1579 to return the existing label on a filesystem.");
1580
1581   ("get_e2label", (RString "label", [String "device"]), 81, [],
1582    [],
1583    "get the ext2/3/4 filesystem label",
1584    "\
1585 This returns the ext2/3/4 filesystem label of the filesystem on
1586 C<device>.");
1587
1588   ("set_e2uuid", (RErr, [String "device"; String "uuid"]), 82, [],
1589    [InitBasicFS, TestOutput (
1590       [["set_e2uuid"; "/dev/sda1"; "a3a61220-882b-4f61-89f4-cf24dcc7297d"];
1591        ["get_e2uuid"; "/dev/sda1"]], "a3a61220-882b-4f61-89f4-cf24dcc7297d");
1592     InitBasicFS, TestOutput (
1593       [["set_e2uuid"; "/dev/sda1"; "clear"];
1594        ["get_e2uuid"; "/dev/sda1"]], "");
1595     (* We can't predict what UUIDs will be, so just check the commands run. *)
1596     InitBasicFS, TestRun (
1597       [["set_e2uuid"; "/dev/sda1"; "random"]]);
1598     InitBasicFS, TestRun (
1599       [["set_e2uuid"; "/dev/sda1"; "time"]])],
1600    "set the ext2/3/4 filesystem UUID",
1601    "\
1602 This sets the ext2/3/4 filesystem UUID of the filesystem on
1603 C<device> to C<uuid>.  The format of the UUID and alternatives
1604 such as C<clear>, C<random> and C<time> are described in the
1605 L<tune2fs(8)> manpage.
1606
1607 You can use either C<guestfs_tune2fs_l> or C<guestfs_get_e2uuid>
1608 to return the existing UUID of a filesystem.");
1609
1610   ("get_e2uuid", (RString "uuid", [String "device"]), 83, [],
1611    [],
1612    "get the ext2/3/4 filesystem UUID",
1613    "\
1614 This returns the ext2/3/4 filesystem UUID of the filesystem on
1615 C<device>.");
1616
1617 ]
1618
1619 let all_functions = non_daemon_functions @ daemon_functions
1620
1621 (* In some places we want the functions to be displayed sorted
1622  * alphabetically, so this is useful:
1623  *)
1624 let all_functions_sorted =
1625   List.sort (fun (n1,_,_,_,_,_,_) (n2,_,_,_,_,_,_) ->
1626                compare n1 n2) all_functions
1627
1628 (* Column names and types from LVM PVs/VGs/LVs. *)
1629 let pv_cols = [
1630   "pv_name", `String;
1631   "pv_uuid", `UUID;
1632   "pv_fmt", `String;
1633   "pv_size", `Bytes;
1634   "dev_size", `Bytes;
1635   "pv_free", `Bytes;
1636   "pv_used", `Bytes;
1637   "pv_attr", `String (* XXX *);
1638   "pv_pe_count", `Int;
1639   "pv_pe_alloc_count", `Int;
1640   "pv_tags", `String;
1641   "pe_start", `Bytes;
1642   "pv_mda_count", `Int;
1643   "pv_mda_free", `Bytes;
1644 (* Not in Fedora 10:
1645   "pv_mda_size", `Bytes;
1646 *)
1647 ]
1648 let vg_cols = [
1649   "vg_name", `String;
1650   "vg_uuid", `UUID;
1651   "vg_fmt", `String;
1652   "vg_attr", `String (* XXX *);
1653   "vg_size", `Bytes;
1654   "vg_free", `Bytes;
1655   "vg_sysid", `String;
1656   "vg_extent_size", `Bytes;
1657   "vg_extent_count", `Int;
1658   "vg_free_count", `Int;
1659   "max_lv", `Int;
1660   "max_pv", `Int;
1661   "pv_count", `Int;
1662   "lv_count", `Int;
1663   "snap_count", `Int;
1664   "vg_seqno", `Int;
1665   "vg_tags", `String;
1666   "vg_mda_count", `Int;
1667   "vg_mda_free", `Bytes;
1668 (* Not in Fedora 10:
1669   "vg_mda_size", `Bytes;
1670 *)
1671 ]
1672 let lv_cols = [
1673   "lv_name", `String;
1674   "lv_uuid", `UUID;
1675   "lv_attr", `String (* XXX *);
1676   "lv_major", `Int;
1677   "lv_minor", `Int;
1678   "lv_kernel_major", `Int;
1679   "lv_kernel_minor", `Int;
1680   "lv_size", `Bytes;
1681   "seg_count", `Int;
1682   "origin", `String;
1683   "snap_percent", `OptPercent;
1684   "copy_percent", `OptPercent;
1685   "move_pv", `String;
1686   "lv_tags", `String;
1687   "mirror_log", `String;
1688   "modules", `String;
1689 ]
1690
1691 (* Column names and types from stat structures.
1692  * NB. Can't use things like 'st_atime' because glibc header files
1693  * define some of these as macros.  Ugh.
1694  *)
1695 let stat_cols = [
1696   "dev", `Int;
1697   "ino", `Int;
1698   "mode", `Int;
1699   "nlink", `Int;
1700   "uid", `Int;
1701   "gid", `Int;
1702   "rdev", `Int;
1703   "size", `Int;
1704   "blksize", `Int;
1705   "blocks", `Int;
1706   "atime", `Int;
1707   "mtime", `Int;
1708   "ctime", `Int;
1709 ]
1710 let statvfs_cols = [
1711   "bsize", `Int;
1712   "frsize", `Int;
1713   "blocks", `Int;
1714   "bfree", `Int;
1715   "bavail", `Int;
1716   "files", `Int;
1717   "ffree", `Int;
1718   "favail", `Int;
1719   "fsid", `Int;
1720   "flag", `Int;
1721   "namemax", `Int;
1722 ]
1723
1724 (* Useful functions.
1725  * Note we don't want to use any external OCaml libraries which
1726  * makes this a bit harder than it should be.
1727  *)
1728 let failwithf fs = ksprintf failwith fs
1729
1730 let replace_char s c1 c2 =
1731   let s2 = String.copy s in
1732   let r = ref false in
1733   for i = 0 to String.length s2 - 1 do
1734     if String.unsafe_get s2 i = c1 then (
1735       String.unsafe_set s2 i c2;
1736       r := true
1737     )
1738   done;
1739   if not !r then s else s2
1740
1741 let isspace c =
1742   c = ' '
1743   (* || c = '\f' *) || c = '\n' || c = '\r' || c = '\t' (* || c = '\v' *)
1744
1745 let triml ?(test = isspace) str =
1746   let i = ref 0 in
1747   let n = ref (String.length str) in
1748   while !n > 0 && test str.[!i]; do
1749     decr n;
1750     incr i
1751   done;
1752   if !i = 0 then str
1753   else String.sub str !i !n
1754
1755 let trimr ?(test = isspace) str =
1756   let n = ref (String.length str) in
1757   while !n > 0 && test str.[!n-1]; do
1758     decr n
1759   done;
1760   if !n = String.length str then str
1761   else String.sub str 0 !n
1762
1763 let trim ?(test = isspace) str =
1764   trimr ~test (triml ~test str)
1765
1766 let rec find s sub =
1767   let len = String.length s in
1768   let sublen = String.length sub in
1769   let rec loop i =
1770     if i <= len-sublen then (
1771       let rec loop2 j =
1772         if j < sublen then (
1773           if s.[i+j] = sub.[j] then loop2 (j+1)
1774           else -1
1775         ) else
1776           i (* found *)
1777       in
1778       let r = loop2 0 in
1779       if r = -1 then loop (i+1) else r
1780     ) else
1781       -1 (* not found *)
1782   in
1783   loop 0
1784
1785 let rec replace_str s s1 s2 =
1786   let len = String.length s in
1787   let sublen = String.length s1 in
1788   let i = find s s1 in
1789   if i = -1 then s
1790   else (
1791     let s' = String.sub s 0 i in
1792     let s'' = String.sub s (i+sublen) (len-i-sublen) in
1793     s' ^ s2 ^ replace_str s'' s1 s2
1794   )
1795
1796 let rec string_split sep str =
1797   let len = String.length str in
1798   let seplen = String.length sep in
1799   let i = find str sep in
1800   if i = -1 then [str]
1801   else (
1802     let s' = String.sub str 0 i in
1803     let s'' = String.sub str (i+seplen) (len-i-seplen) in
1804     s' :: string_split sep s''
1805   )
1806
1807 let rec find_map f = function
1808   | [] -> raise Not_found
1809   | x :: xs ->
1810       match f x with
1811       | Some y -> y
1812       | None -> find_map f xs
1813
1814 let iteri f xs =
1815   let rec loop i = function
1816     | [] -> ()
1817     | x :: xs -> f i x; loop (i+1) xs
1818   in
1819   loop 0 xs
1820
1821 let mapi f xs =
1822   let rec loop i = function
1823     | [] -> []
1824     | x :: xs -> let r = f i x in r :: loop (i+1) xs
1825   in
1826   loop 0 xs
1827
1828 let name_of_argt = function
1829   | String n | OptString n | StringList n | Bool n | Int n
1830   | FileIn n | FileOut n -> n
1831
1832 let seq_of_test = function
1833   | TestRun s | TestOutput (s, _) | TestOutputList (s, _)
1834   | TestOutputInt (s, _) | TestOutputTrue s | TestOutputFalse s
1835   | TestOutputLength (s, _) | TestOutputStruct (s, _)
1836   | TestLastFail s -> s
1837
1838 (* Check function names etc. for consistency. *)
1839 let check_functions () =
1840   let contains_uppercase str =
1841     let len = String.length str in
1842     let rec loop i =
1843       if i >= len then false
1844       else (
1845         let c = str.[i] in
1846         if c >= 'A' && c <= 'Z' then true
1847         else loop (i+1)
1848       )
1849     in
1850     loop 0
1851   in
1852
1853   (* Check function names. *)
1854   List.iter (
1855     fun (name, _, _, _, _, _, _) ->
1856       if String.length name >= 7 && String.sub name 0 7 = "guestfs" then
1857         failwithf "function name %s does not need 'guestfs' prefix" name;
1858       if contains_uppercase name then
1859         failwithf "function name %s should not contain uppercase chars" name;
1860       if String.contains name '-' then
1861         failwithf "function name %s should not contain '-', use '_' instead."
1862           name
1863   ) all_functions;
1864
1865   (* Check function parameter/return names. *)
1866   List.iter (
1867     fun (name, style, _, _, _, _, _) ->
1868       let check_arg_ret_name n =
1869         if contains_uppercase n then
1870           failwithf "%s param/ret %s should not contain uppercase chars"
1871             name n;
1872         if String.contains n '-' || String.contains n '_' then
1873           failwithf "%s param/ret %s should not contain '-' or '_'"
1874             name n;
1875         if n = "value" then
1876           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;
1877         if n = "argv" || n = "args" then
1878           failwithf "%s has a param/ret called 'argv' or 'args', which will cause some conflicts in the generated code" n
1879       in
1880
1881       (match fst style with
1882        | RErr -> ()
1883        | RInt n | RInt64 n | RBool n | RConstString n | RString n
1884        | RStringList n | RPVList n | RVGList n | RLVList n
1885        | RStat n | RStatVFS n
1886        | RHashtable n ->
1887            check_arg_ret_name n
1888        | RIntBool (n,m) ->
1889            check_arg_ret_name n;
1890            check_arg_ret_name m
1891       );
1892       List.iter (fun arg -> check_arg_ret_name (name_of_argt arg)) (snd style)
1893   ) all_functions;
1894
1895   (* Check short descriptions. *)
1896   List.iter (
1897     fun (name, _, _, _, _, shortdesc, _) ->
1898       if shortdesc.[0] <> Char.lowercase shortdesc.[0] then
1899         failwithf "short description of %s should begin with lowercase." name;
1900       let c = shortdesc.[String.length shortdesc-1] in
1901       if c = '\n' || c = '.' then
1902         failwithf "short description of %s should not end with . or \\n." name
1903   ) all_functions;
1904
1905   (* Check long dscriptions. *)
1906   List.iter (
1907     fun (name, _, _, _, _, _, longdesc) ->
1908       if longdesc.[String.length longdesc-1] = '\n' then
1909         failwithf "long description of %s should not end with \\n." name
1910   ) all_functions;
1911
1912   (* Check proc_nrs. *)
1913   List.iter (
1914     fun (name, _, proc_nr, _, _, _, _) ->
1915       if proc_nr <= 0 then
1916         failwithf "daemon function %s should have proc_nr > 0" name
1917   ) daemon_functions;
1918
1919   List.iter (
1920     fun (name, _, proc_nr, _, _, _, _) ->
1921       if proc_nr <> -1 then
1922         failwithf "non-daemon function %s should have proc_nr -1" name
1923   ) non_daemon_functions;
1924
1925   let proc_nrs =
1926     List.map (fun (name, _, proc_nr, _, _, _, _) -> name, proc_nr)
1927       daemon_functions in
1928   let proc_nrs =
1929     List.sort (fun (_,nr1) (_,nr2) -> compare nr1 nr2) proc_nrs in
1930   let rec loop = function
1931     | [] -> ()
1932     | [_] -> ()
1933     | (name1,nr1) :: ((name2,nr2) :: _ as rest) when nr1 < nr2 ->
1934         loop rest
1935     | (name1,nr1) :: (name2,nr2) :: _ ->
1936         failwithf "%s and %s have conflicting procedure numbers (%d, %d)"
1937           name1 name2 nr1 nr2
1938   in
1939   loop proc_nrs;
1940
1941   (* Check tests. *)
1942   List.iter (
1943     function
1944       (* Ignore functions that have no tests.  We generate a
1945        * warning when the user does 'make check' instead.
1946        *)
1947     | name, _, _, _, [], _, _ -> ()
1948     | name, _, _, _, tests, _, _ ->
1949         let funcs =
1950           List.map (
1951             fun (_, test) ->
1952               match seq_of_test test with
1953               | [] ->
1954                   failwithf "%s has a test containing an empty sequence" name
1955               | cmds -> List.map List.hd cmds
1956           ) tests in
1957         let funcs = List.flatten funcs in
1958
1959         let tested = List.mem name funcs in
1960
1961         if not tested then
1962           failwithf "function %s has tests but does not test itself" name
1963   ) all_functions
1964
1965 (* 'pr' prints to the current output file. *)
1966 let chan = ref stdout
1967 let pr fs = ksprintf (output_string !chan) fs
1968
1969 (* Generate a header block in a number of standard styles. *)
1970 type comment_style = CStyle | HashStyle | OCamlStyle
1971 type license = GPLv2 | LGPLv2
1972
1973 let generate_header comment license =
1974   let c = match comment with
1975     | CStyle ->     pr "/* "; " *"
1976     | HashStyle ->  pr "# ";  "#"
1977     | OCamlStyle -> pr "(* "; " *" in
1978   pr "libguestfs generated file\n";
1979   pr "%s WARNING: THIS FILE IS GENERATED BY 'src/generator.ml'.\n" c;
1980   pr "%s ANY CHANGES YOU MAKE TO THIS FILE WILL BE LOST.\n" c;
1981   pr "%s\n" c;
1982   pr "%s Copyright (C) 2009 Red Hat Inc.\n" c;
1983   pr "%s\n" c;
1984   (match license with
1985    | GPLv2 ->
1986        pr "%s This program is free software; you can redistribute it and/or modify\n" c;
1987        pr "%s it under the terms of the GNU General Public License as published by\n" c;
1988        pr "%s the Free Software Foundation; either version 2 of the License, or\n" c;
1989        pr "%s (at your option) any later version.\n" c;
1990        pr "%s\n" c;
1991        pr "%s This program is distributed in the hope that it will be useful,\n" c;
1992        pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
1993        pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the\n" c;
1994        pr "%s GNU General Public License for more details.\n" c;
1995        pr "%s\n" c;
1996        pr "%s You should have received a copy of the GNU General Public License along\n" c;
1997        pr "%s with this program; if not, write to the Free Software Foundation, Inc.,\n" c;
1998        pr "%s 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n" c;
1999
2000    | LGPLv2 ->
2001        pr "%s This library is free software; you can redistribute it and/or\n" c;
2002        pr "%s modify it under the terms of the GNU Lesser General Public\n" c;
2003        pr "%s License as published by the Free Software Foundation; either\n" c;
2004        pr "%s version 2 of the License, or (at your option) any later version.\n" c;
2005        pr "%s\n" c;
2006        pr "%s This library is distributed in the hope that it will be useful,\n" c;
2007        pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
2008        pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU\n" c;
2009        pr "%s Lesser General Public License for more details.\n" c;
2010        pr "%s\n" c;
2011        pr "%s You should have received a copy of the GNU Lesser General Public\n" c;
2012        pr "%s License along with this library; if not, write to the Free Software\n" c;
2013        pr "%s Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA\n" c;
2014   );
2015   (match comment with
2016    | CStyle -> pr " */\n"
2017    | HashStyle -> ()
2018    | OCamlStyle -> pr " *)\n"
2019   );
2020   pr "\n"
2021
2022 (* Start of main code generation functions below this line. *)
2023
2024 (* Generate the pod documentation for the C API. *)
2025 let rec generate_actions_pod () =
2026   List.iter (
2027     fun (shortname, style, _, flags, _, _, longdesc) ->
2028       let name = "guestfs_" ^ shortname in
2029       pr "=head2 %s\n\n" name;
2030       pr " ";
2031       generate_prototype ~extern:false ~handle:"handle" name style;
2032       pr "\n\n";
2033       pr "%s\n\n" longdesc;
2034       (match fst style with
2035        | RErr ->
2036            pr "This function returns 0 on success or -1 on error.\n\n"
2037        | RInt _ ->
2038            pr "On error this function returns -1.\n\n"
2039        | RInt64 _ ->
2040            pr "On error this function returns -1.\n\n"
2041        | RBool _ ->
2042            pr "This function returns a C truth value on success or -1 on error.\n\n"
2043        | RConstString _ ->
2044            pr "This function returns a string, or NULL on error.
2045 The string is owned by the guest handle and must I<not> be freed.\n\n"
2046        | RString _ ->
2047            pr "This function returns a string, or NULL on error.
2048 I<The caller must free the returned string after use>.\n\n"
2049        | RStringList _ ->
2050            pr "This function returns a NULL-terminated array of strings
2051 (like L<environ(3)>), or NULL if there was an error.
2052 I<The caller must free the strings and the array after use>.\n\n"
2053        | RIntBool _ ->
2054            pr "This function returns a C<struct guestfs_int_bool *>,
2055 or NULL if there was an error.
2056 I<The caller must call C<guestfs_free_int_bool> after use>.\n\n"
2057        | RPVList _ ->
2058            pr "This function returns a C<struct guestfs_lvm_pv_list *>
2059 (see E<lt>guestfs-structs.hE<gt>),
2060 or NULL if there was an error.
2061 I<The caller must call C<guestfs_free_lvm_pv_list> after use>.\n\n"
2062        | RVGList _ ->
2063            pr "This function returns a C<struct guestfs_lvm_vg_list *>
2064 (see E<lt>guestfs-structs.hE<gt>),
2065 or NULL if there was an error.
2066 I<The caller must call C<guestfs_free_lvm_vg_list> after use>.\n\n"
2067        | RLVList _ ->
2068            pr "This function returns a C<struct guestfs_lvm_lv_list *>
2069 (see E<lt>guestfs-structs.hE<gt>),
2070 or NULL if there was an error.
2071 I<The caller must call C<guestfs_free_lvm_lv_list> after use>.\n\n"
2072        | RStat _ ->
2073            pr "This function returns a C<struct guestfs_stat *>
2074 (see L<stat(2)> and E<lt>guestfs-structs.hE<gt>),
2075 or NULL if there was an error.
2076 I<The caller must call C<free> after use>.\n\n"
2077        | RStatVFS _ ->
2078            pr "This function returns a C<struct guestfs_statvfs *>
2079 (see L<statvfs(2)> and E<lt>guestfs-structs.hE<gt>),
2080 or NULL if there was an error.
2081 I<The caller must call C<free> after use>.\n\n"
2082        | RHashtable _ ->
2083            pr "This function returns a NULL-terminated array of
2084 strings, or NULL if there was an error.
2085 The array of strings will always have length C<2n+1>, where
2086 C<n> keys and values alternate, followed by the trailing NULL entry.
2087 I<The caller must free the strings and the array after use>.\n\n"
2088       );
2089       if List.mem ProtocolLimitWarning flags then
2090         pr "%s\n\n" protocol_limit_warning;
2091       if List.mem DangerWillRobinson flags then
2092         pr "%s\n\n" danger_will_robinson;
2093   ) all_functions_sorted
2094
2095 and generate_structs_pod () =
2096   (* LVM structs documentation. *)
2097   List.iter (
2098     fun (typ, cols) ->
2099       pr "=head2 guestfs_lvm_%s\n" typ;
2100       pr "\n";
2101       pr " struct guestfs_lvm_%s {\n" typ;
2102       List.iter (
2103         function
2104         | name, `String -> pr "  char *%s;\n" name
2105         | name, `UUID ->
2106             pr "  /* The next field is NOT nul-terminated, be careful when printing it: */\n";
2107             pr "  char %s[32];\n" name
2108         | name, `Bytes -> pr "  uint64_t %s;\n" name
2109         | name, `Int -> pr "  int64_t %s;\n" name
2110         | name, `OptPercent ->
2111             pr "  /* The next field is [0..100] or -1 meaning 'not present': */\n";
2112             pr "  float %s;\n" name
2113       ) cols;
2114       pr " \n";
2115       pr " struct guestfs_lvm_%s_list {\n" typ;
2116       pr "   uint32_t len; /* Number of elements in list. */\n";
2117       pr "   struct guestfs_lvm_%s *val; /* Elements. */\n" typ;
2118       pr " };\n";
2119       pr " \n";
2120       pr " void guestfs_free_lvm_%s_list (struct guestfs_free_lvm_%s_list *);\n"
2121         typ typ;
2122       pr "\n"
2123   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols]
2124
2125 (* Generate the protocol (XDR) file, 'guestfs_protocol.x' and
2126  * indirectly 'guestfs_protocol.h' and 'guestfs_protocol.c'.
2127  *
2128  * We have to use an underscore instead of a dash because otherwise
2129  * rpcgen generates incorrect code.
2130  *
2131  * This header is NOT exported to clients, but see also generate_structs_h.
2132  *)
2133 and generate_xdr () =
2134   generate_header CStyle LGPLv2;
2135
2136   (* This has to be defined to get around a limitation in Sun's rpcgen. *)
2137   pr "typedef string str<>;\n";
2138   pr "\n";
2139
2140   (* LVM internal structures. *)
2141   List.iter (
2142     function
2143     | typ, cols ->
2144         pr "struct guestfs_lvm_int_%s {\n" typ;
2145         List.iter (function
2146                    | name, `String -> pr "  string %s<>;\n" name
2147                    | name, `UUID -> pr "  opaque %s[32];\n" name
2148                    | name, `Bytes -> pr "  hyper %s;\n" name
2149                    | name, `Int -> pr "  hyper %s;\n" name
2150                    | name, `OptPercent -> pr "  float %s;\n" name
2151                   ) cols;
2152         pr "};\n";
2153         pr "\n";
2154         pr "typedef struct guestfs_lvm_int_%s guestfs_lvm_int_%s_list<>;\n" typ typ;
2155         pr "\n";
2156   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols];
2157
2158   (* Stat internal structures. *)
2159   List.iter (
2160     function
2161     | typ, cols ->
2162         pr "struct guestfs_int_%s {\n" typ;
2163         List.iter (function
2164                    | name, `Int -> pr "  hyper %s;\n" name
2165                   ) cols;
2166         pr "};\n";
2167         pr "\n";
2168   ) ["stat", stat_cols; "statvfs", statvfs_cols];
2169
2170   List.iter (
2171     fun (shortname, style, _, _, _, _, _) ->
2172       let name = "guestfs_" ^ shortname in
2173
2174       (match snd style with
2175        | [] -> ()
2176        | args ->
2177            pr "struct %s_args {\n" name;
2178            List.iter (
2179              function
2180              | String n -> pr "  string %s<>;\n" n
2181              | OptString n -> pr "  str *%s;\n" n
2182              | StringList n -> pr "  str %s<>;\n" n
2183              | Bool n -> pr "  bool %s;\n" n
2184              | Int n -> pr "  int %s;\n" n
2185              | FileIn _ | FileOut _ -> ()
2186            ) args;
2187            pr "};\n\n"
2188       );
2189       (match fst style with
2190        | RErr -> ()
2191        | RInt n ->
2192            pr "struct %s_ret {\n" name;
2193            pr "  int %s;\n" n;
2194            pr "};\n\n"
2195        | RInt64 n ->
2196            pr "struct %s_ret {\n" name;
2197            pr "  hyper %s;\n" n;
2198            pr "};\n\n"
2199        | RBool n ->
2200            pr "struct %s_ret {\n" name;
2201            pr "  bool %s;\n" n;
2202            pr "};\n\n"
2203        | RConstString _ ->
2204            failwithf "RConstString cannot be returned from a daemon function"
2205        | RString n ->
2206            pr "struct %s_ret {\n" name;
2207            pr "  string %s<>;\n" n;
2208            pr "};\n\n"
2209        | RStringList n ->
2210            pr "struct %s_ret {\n" name;
2211            pr "  str %s<>;\n" n;
2212            pr "};\n\n"
2213        | RIntBool (n,m) ->
2214            pr "struct %s_ret {\n" name;
2215            pr "  int %s;\n" n;
2216            pr "  bool %s;\n" m;
2217            pr "};\n\n"
2218        | RPVList n ->
2219            pr "struct %s_ret {\n" name;
2220            pr "  guestfs_lvm_int_pv_list %s;\n" n;
2221            pr "};\n\n"
2222        | RVGList n ->
2223            pr "struct %s_ret {\n" name;
2224            pr "  guestfs_lvm_int_vg_list %s;\n" n;
2225            pr "};\n\n"
2226        | RLVList n ->
2227            pr "struct %s_ret {\n" name;
2228            pr "  guestfs_lvm_int_lv_list %s;\n" n;
2229            pr "};\n\n"
2230        | RStat n ->
2231            pr "struct %s_ret {\n" name;
2232            pr "  guestfs_int_stat %s;\n" n;
2233            pr "};\n\n"
2234        | RStatVFS n ->
2235            pr "struct %s_ret {\n" name;
2236            pr "  guestfs_int_statvfs %s;\n" n;
2237            pr "};\n\n"
2238        | RHashtable n ->
2239            pr "struct %s_ret {\n" name;
2240            pr "  str %s<>;\n" n;
2241            pr "};\n\n"
2242       );
2243   ) daemon_functions;
2244
2245   (* Table of procedure numbers. *)
2246   pr "enum guestfs_procedure {\n";
2247   List.iter (
2248     fun (shortname, _, proc_nr, _, _, _, _) ->
2249       pr "  GUESTFS_PROC_%s = %d,\n" (String.uppercase shortname) proc_nr
2250   ) daemon_functions;
2251   pr "  GUESTFS_PROC_NR_PROCS\n";
2252   pr "};\n";
2253   pr "\n";
2254
2255   (* Having to choose a maximum message size is annoying for several
2256    * reasons (it limits what we can do in the API), but it (a) makes
2257    * the protocol a lot simpler, and (b) provides a bound on the size
2258    * of the daemon which operates in limited memory space.  For large
2259    * file transfers you should use FTP.
2260    *)
2261   pr "const GUESTFS_MESSAGE_MAX = %d;\n" (4 * 1024 * 1024);
2262   pr "\n";
2263
2264   (* Message header, etc. *)
2265   pr "\
2266 /* The communication protocol is now documented in the guestfs(3)
2267  * manpage.
2268  */
2269
2270 const GUESTFS_PROGRAM = 0x2000F5F5;
2271 const GUESTFS_PROTOCOL_VERSION = 1;
2272
2273 /* These constants must be larger than any possible message length. */
2274 const GUESTFS_LAUNCH_FLAG = 0xf5f55ff5;
2275 const GUESTFS_CANCEL_FLAG = 0xffffeeee;
2276
2277 enum guestfs_message_direction {
2278   GUESTFS_DIRECTION_CALL = 0,        /* client -> daemon */
2279   GUESTFS_DIRECTION_REPLY = 1        /* daemon -> client */
2280 };
2281
2282 enum guestfs_message_status {
2283   GUESTFS_STATUS_OK = 0,
2284   GUESTFS_STATUS_ERROR = 1
2285 };
2286
2287 const GUESTFS_ERROR_LEN = 256;
2288
2289 struct guestfs_message_error {
2290   string error_message<GUESTFS_ERROR_LEN>;
2291 };
2292
2293 struct guestfs_message_header {
2294   unsigned prog;                     /* GUESTFS_PROGRAM */
2295   unsigned vers;                     /* GUESTFS_PROTOCOL_VERSION */
2296   guestfs_procedure proc;            /* GUESTFS_PROC_x */
2297   guestfs_message_direction direction;
2298   unsigned serial;                   /* message serial number */
2299   guestfs_message_status status;
2300 };
2301
2302 const GUESTFS_MAX_CHUNK_SIZE = 8192;
2303
2304 struct guestfs_chunk {
2305   int cancel;                        /* if non-zero, transfer is cancelled */
2306   /* data size is 0 bytes if the transfer has finished successfully */
2307   opaque data<GUESTFS_MAX_CHUNK_SIZE>;
2308 };
2309 "
2310
2311 (* Generate the guestfs-structs.h file. *)
2312 and generate_structs_h () =
2313   generate_header CStyle LGPLv2;
2314
2315   (* This is a public exported header file containing various
2316    * structures.  The structures are carefully written to have
2317    * exactly the same in-memory format as the XDR structures that
2318    * we use on the wire to the daemon.  The reason for creating
2319    * copies of these structures here is just so we don't have to
2320    * export the whole of guestfs_protocol.h (which includes much
2321    * unrelated and XDR-dependent stuff that we don't want to be
2322    * public, or required by clients).
2323    *
2324    * To reiterate, we will pass these structures to and from the
2325    * client with a simple assignment or memcpy, so the format
2326    * must be identical to what rpcgen / the RFC defines.
2327    *)
2328
2329   (* guestfs_int_bool structure. *)
2330   pr "struct guestfs_int_bool {\n";
2331   pr "  int32_t i;\n";
2332   pr "  int32_t b;\n";
2333   pr "};\n";
2334   pr "\n";
2335
2336   (* LVM public structures. *)
2337   List.iter (
2338     function
2339     | typ, cols ->
2340         pr "struct guestfs_lvm_%s {\n" typ;
2341         List.iter (
2342           function
2343           | name, `String -> pr "  char *%s;\n" name
2344           | name, `UUID -> pr "  char %s[32]; /* this is NOT nul-terminated, be careful when printing */\n" name
2345           | name, `Bytes -> pr "  uint64_t %s;\n" name
2346           | name, `Int -> pr "  int64_t %s;\n" name
2347           | name, `OptPercent -> pr "  float %s; /* [0..100] or -1 */\n" name
2348         ) cols;
2349         pr "};\n";
2350         pr "\n";
2351         pr "struct guestfs_lvm_%s_list {\n" typ;
2352         pr "  uint32_t len;\n";
2353         pr "  struct guestfs_lvm_%s *val;\n" typ;
2354         pr "};\n";
2355         pr "\n"
2356   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols];
2357
2358   (* Stat structures. *)
2359   List.iter (
2360     function
2361     | typ, cols ->
2362         pr "struct guestfs_%s {\n" typ;
2363         List.iter (
2364           function
2365           | name, `Int -> pr "  int64_t %s;\n" name
2366         ) cols;
2367         pr "};\n";
2368         pr "\n"
2369   ) ["stat", stat_cols; "statvfs", statvfs_cols]
2370
2371 (* Generate the guestfs-actions.h file. *)
2372 and generate_actions_h () =
2373   generate_header CStyle LGPLv2;
2374   List.iter (
2375     fun (shortname, style, _, _, _, _, _) ->
2376       let name = "guestfs_" ^ shortname in
2377       generate_prototype ~single_line:true ~newline:true ~handle:"handle"
2378         name style
2379   ) all_functions
2380
2381 (* Generate the client-side dispatch stubs. *)
2382 and generate_client_actions () =
2383   generate_header CStyle LGPLv2;
2384
2385   pr "\
2386 #include <stdio.h>
2387 #include <stdlib.h>
2388
2389 #include \"guestfs.h\"
2390 #include \"guestfs_protocol.h\"
2391
2392 #define error guestfs_error
2393 #define perrorf guestfs_perrorf
2394 #define safe_malloc guestfs_safe_malloc
2395 #define safe_realloc guestfs_safe_realloc
2396 #define safe_strdup guestfs_safe_strdup
2397 #define safe_memdup guestfs_safe_memdup
2398
2399 /* Check the return message from a call for validity. */
2400 static int
2401 check_reply_header (guestfs_h *g,
2402                     const struct guestfs_message_header *hdr,
2403                     int proc_nr, int serial)
2404 {
2405   if (hdr->prog != GUESTFS_PROGRAM) {
2406     error (g, \"wrong program (%%d/%%d)\", hdr->prog, GUESTFS_PROGRAM);
2407     return -1;
2408   }
2409   if (hdr->vers != GUESTFS_PROTOCOL_VERSION) {
2410     error (g, \"wrong protocol version (%%d/%%d)\",
2411            hdr->vers, GUESTFS_PROTOCOL_VERSION);
2412     return -1;
2413   }
2414   if (hdr->direction != GUESTFS_DIRECTION_REPLY) {
2415     error (g, \"unexpected message direction (%%d/%%d)\",
2416            hdr->direction, GUESTFS_DIRECTION_REPLY);
2417     return -1;
2418   }
2419   if (hdr->proc != proc_nr) {
2420     error (g, \"unexpected procedure number (%%d/%%d)\", hdr->proc, proc_nr);
2421     return -1;
2422   }
2423   if (hdr->serial != serial) {
2424     error (g, \"unexpected serial (%%d/%%d)\", hdr->serial, serial);
2425     return -1;
2426   }
2427
2428   return 0;
2429 }
2430
2431 /* Check we are in the right state to run a high-level action. */
2432 static int
2433 check_state (guestfs_h *g, const char *caller)
2434 {
2435   if (!guestfs_is_ready (g)) {
2436     if (guestfs_is_config (g))
2437       error (g, \"%%s: call launch() before using this function\",
2438         caller);
2439     else if (guestfs_is_launching (g))
2440       error (g, \"%%s: call wait_ready() before using this function\",
2441         caller);
2442     else
2443       error (g, \"%%s called from the wrong state, %%d != READY\",
2444         caller, guestfs_get_state (g));
2445     return -1;
2446   }
2447   return 0;
2448 }
2449
2450 ";
2451
2452   (* Client-side stubs for each function. *)
2453   List.iter (
2454     fun (shortname, style, _, _, _, _, _) ->
2455       let name = "guestfs_" ^ shortname in
2456
2457       (* Generate the context struct which stores the high-level
2458        * state between callback functions.
2459        *)
2460       pr "struct %s_ctx {\n" shortname;
2461       pr "  /* This flag is set by the callbacks, so we know we've done\n";
2462       pr "   * the callbacks as expected, and in the right sequence.\n";
2463       pr "   * 0 = not called, 1 = reply_cb called.\n";
2464       pr "   */\n";
2465       pr "  int cb_sequence;\n";
2466       pr "  struct guestfs_message_header hdr;\n";
2467       pr "  struct guestfs_message_error err;\n";
2468       (match fst style with
2469        | RErr -> ()
2470        | RConstString _ ->
2471            failwithf "RConstString cannot be returned from a daemon function"
2472        | RInt _ | RInt64 _
2473        | RBool _ | RString _ | RStringList _
2474        | RIntBool _
2475        | RPVList _ | RVGList _ | RLVList _
2476        | RStat _ | RStatVFS _
2477        | RHashtable _ ->
2478            pr "  struct %s_ret ret;\n" name
2479       );
2480       pr "};\n";
2481       pr "\n";
2482
2483       (* Generate the reply callback function. *)
2484       pr "static void %s_reply_cb (guestfs_h *g, void *data, XDR *xdr)\n" shortname;
2485       pr "{\n";
2486       pr "  guestfs_main_loop *ml = guestfs_get_main_loop (g);\n";
2487       pr "  struct %s_ctx *ctx = (struct %s_ctx *) data;\n" shortname shortname;
2488       pr "\n";
2489       pr "  /* This should definitely not happen. */\n";
2490       pr "  if (ctx->cb_sequence != 0) {\n";
2491       pr "    ctx->cb_sequence = 9999;\n";
2492       pr "    error (g, \"%%s: internal error: reply callback called twice\", \"%s\");\n" name;
2493       pr "    return;\n";
2494       pr "  }\n";
2495       pr "\n";
2496       pr "  ml->main_loop_quit (ml, g);\n";
2497       pr "\n";
2498       pr "  if (!xdr_guestfs_message_header (xdr, &ctx->hdr)) {\n";
2499       pr "    error (g, \"%%s: failed to parse reply header\", \"%s\");\n" name;
2500       pr "    return;\n";
2501       pr "  }\n";
2502       pr "  if (ctx->hdr.status == GUESTFS_STATUS_ERROR) {\n";
2503       pr "    if (!xdr_guestfs_message_error (xdr, &ctx->err)) {\n";
2504       pr "      error (g, \"%%s: failed to parse reply error\", \"%s\");\n"
2505         name;
2506       pr "      return;\n";
2507       pr "    }\n";
2508       pr "    goto done;\n";
2509       pr "  }\n";
2510
2511       (match fst style with
2512        | RErr -> ()
2513        | RConstString _ ->
2514            failwithf "RConstString cannot be returned from a daemon function"
2515        | RInt _ | RInt64 _
2516        | RBool _ | RString _ | RStringList _
2517        | RIntBool _
2518        | RPVList _ | RVGList _ | RLVList _
2519        | RStat _ | RStatVFS _
2520        | RHashtable _ ->
2521             pr "  if (!xdr_%s_ret (xdr, &ctx->ret)) {\n" name;
2522             pr "    error (g, \"%%s: failed to parse reply\", \"%s\");\n" name;
2523             pr "    return;\n";
2524             pr "  }\n";
2525       );
2526
2527       pr " done:\n";
2528       pr "  ctx->cb_sequence = 1;\n";
2529       pr "}\n\n";
2530
2531       (* Generate the action stub. *)
2532       generate_prototype ~extern:false ~semicolon:false ~newline:true
2533         ~handle:"g" name style;
2534
2535       let error_code =
2536         match fst style with
2537         | RErr | RInt _ | RInt64 _ | RBool _ -> "-1"
2538         | RConstString _ ->
2539             failwithf "RConstString cannot be returned from a daemon function"
2540         | RString _ | RStringList _ | RIntBool _
2541         | RPVList _ | RVGList _ | RLVList _
2542         | RStat _ | RStatVFS _
2543         | RHashtable _ ->
2544             "NULL" in
2545
2546       pr "{\n";
2547
2548       (match snd style with
2549        | [] -> ()
2550        | _ -> pr "  struct %s_args args;\n" name
2551       );
2552
2553       pr "  struct %s_ctx ctx;\n" shortname;
2554       pr "  guestfs_main_loop *ml = guestfs_get_main_loop (g);\n";
2555       pr "  int serial;\n";
2556       pr "\n";
2557       pr "  if (check_state (g, \"%s\") == -1) return %s;\n" name error_code;
2558       pr "  guestfs_set_busy (g);\n";
2559       pr "\n";
2560       pr "  memset (&ctx, 0, sizeof ctx);\n";
2561       pr "\n";
2562
2563       (* Send the main header and arguments. *)
2564       (match snd style with
2565        | [] ->
2566            pr "  serial = guestfs__send_sync (g, GUESTFS_PROC_%s, NULL, NULL);\n"
2567              (String.uppercase shortname)
2568        | args ->
2569            List.iter (
2570              function
2571              | String n ->
2572                  pr "  args.%s = (char *) %s;\n" n n
2573              | OptString n ->
2574                  pr "  args.%s = %s ? (char **) &%s : NULL;\n" n n n
2575              | StringList n ->
2576                  pr "  args.%s.%s_val = (char **) %s;\n" n n n;
2577                  pr "  for (args.%s.%s_len = 0; %s[args.%s.%s_len]; args.%s.%s_len++) ;\n" n n n n n n n;
2578              | Bool n ->
2579                  pr "  args.%s = %s;\n" n n
2580              | Int n ->
2581                  pr "  args.%s = %s;\n" n n
2582              | FileIn _ | FileOut _ -> ()
2583            ) args;
2584            pr "  serial = guestfs__send_sync (g, GUESTFS_PROC_%s,\n"
2585              (String.uppercase shortname);
2586            pr "        (xdrproc_t) xdr_%s_args, (char *) &args);\n"
2587              name;
2588       );
2589       pr "  if (serial == -1) {\n";
2590       pr "    guestfs_set_ready (g);\n";
2591       pr "    return %s;\n" error_code;
2592       pr "  }\n";
2593       pr "\n";
2594
2595       (* Send any additional files (FileIn) requested. *)
2596       let need_read_reply_label = ref false in
2597       List.iter (
2598         function
2599         | FileIn n ->
2600             pr "  {\n";
2601             pr "    int r;\n";
2602             pr "\n";
2603             pr "    r = guestfs__send_file_sync (g, %s);\n" n;
2604             pr "    if (r == -1) {\n";
2605             pr "      guestfs_set_ready (g);\n";
2606             pr "      return %s;\n" error_code;
2607             pr "    }\n";
2608             pr "    if (r == -2) /* daemon cancelled */\n";
2609             pr "      goto read_reply;\n";
2610             need_read_reply_label := true;
2611             pr "  }\n";
2612             pr "\n";
2613         | _ -> ()
2614       ) (snd style);
2615
2616       (* Wait for the reply from the remote end. *)
2617       if !need_read_reply_label then pr " read_reply:\n";
2618       pr "  guestfs__switch_to_receiving (g);\n";
2619       pr "  ctx.cb_sequence = 0;\n";
2620       pr "  guestfs_set_reply_callback (g, %s_reply_cb, &ctx);\n" shortname;
2621       pr "  (void) ml->main_loop_run (ml, g);\n";
2622       pr "  guestfs_set_reply_callback (g, NULL, NULL);\n";
2623       pr "  if (ctx.cb_sequence != 1) {\n";
2624       pr "    error (g, \"%%s reply failed, see earlier error messages\", \"%s\");\n" name;
2625       pr "    guestfs_set_ready (g);\n";
2626       pr "    return %s;\n" error_code;
2627       pr "  }\n";
2628       pr "\n";
2629
2630       pr "  if (check_reply_header (g, &ctx.hdr, GUESTFS_PROC_%s, serial) == -1) {\n"
2631         (String.uppercase shortname);
2632       pr "    guestfs_set_ready (g);\n";
2633       pr "    return %s;\n" error_code;
2634       pr "  }\n";
2635       pr "\n";
2636
2637       pr "  if (ctx.hdr.status == GUESTFS_STATUS_ERROR) {\n";
2638       pr "    error (g, \"%%s\", ctx.err.error_message);\n";
2639       pr "    guestfs_set_ready (g);\n";
2640       pr "    return %s;\n" error_code;
2641       pr "  }\n";
2642       pr "\n";
2643
2644       (* Expecting to receive further files (FileOut)? *)
2645       List.iter (
2646         function
2647         | FileOut n ->
2648             pr "  if (guestfs__receive_file_sync (g, %s) == -1) {\n" n;
2649             pr "    guestfs_set_ready (g);\n";
2650             pr "    return %s;\n" error_code;
2651             pr "  }\n";
2652             pr "\n";
2653         | _ -> ()
2654       ) (snd style);
2655
2656       pr "  guestfs_set_ready (g);\n";
2657
2658       (match fst style with
2659        | RErr -> pr "  return 0;\n"
2660        | RInt n | RInt64 n | RBool n ->
2661            pr "  return ctx.ret.%s;\n" n
2662        | RConstString _ ->
2663            failwithf "RConstString cannot be returned from a daemon function"
2664        | RString n ->
2665            pr "  return ctx.ret.%s; /* caller will free */\n" n
2666        | RStringList n | RHashtable n ->
2667            pr "  /* caller will free this, but we need to add a NULL entry */\n";
2668            pr "  ctx.ret.%s.%s_val =\n" n n;
2669            pr "    safe_realloc (g, ctx.ret.%s.%s_val,\n" n n;
2670            pr "                  sizeof (char *) * (ctx.ret.%s.%s_len + 1));\n"
2671              n n;
2672            pr "  ctx.ret.%s.%s_val[ctx.ret.%s.%s_len] = NULL;\n" n n n n;
2673            pr "  return ctx.ret.%s.%s_val;\n" n n
2674        | RIntBool _ ->
2675            pr "  /* caller with free this */\n";
2676            pr "  return safe_memdup (g, &ctx.ret, sizeof (ctx.ret));\n"
2677        | RPVList n | RVGList n | RLVList n
2678        | RStat n | RStatVFS n ->
2679            pr "  /* caller will free this */\n";
2680            pr "  return safe_memdup (g, &ctx.ret.%s, sizeof (ctx.ret.%s));\n" n n
2681       );
2682
2683       pr "}\n\n"
2684   ) daemon_functions
2685
2686 (* Generate daemon/actions.h. *)
2687 and generate_daemon_actions_h () =
2688   generate_header CStyle GPLv2;
2689
2690   pr "#include \"../src/guestfs_protocol.h\"\n";
2691   pr "\n";
2692
2693   List.iter (
2694     fun (name, style, _, _, _, _, _) ->
2695         generate_prototype
2696           ~single_line:true ~newline:true ~in_daemon:true ~prefix:"do_"
2697           name style;
2698   ) daemon_functions
2699
2700 (* Generate the server-side stubs. *)
2701 and generate_daemon_actions () =
2702   generate_header CStyle GPLv2;
2703
2704   pr "#include <config.h>\n";
2705   pr "\n";
2706   pr "#include <stdio.h>\n";
2707   pr "#include <stdlib.h>\n";
2708   pr "#include <string.h>\n";
2709   pr "#include <inttypes.h>\n";
2710   pr "#include <ctype.h>\n";
2711   pr "#include <rpc/types.h>\n";
2712   pr "#include <rpc/xdr.h>\n";
2713   pr "\n";
2714   pr "#include \"daemon.h\"\n";
2715   pr "#include \"../src/guestfs_protocol.h\"\n";
2716   pr "#include \"actions.h\"\n";
2717   pr "\n";
2718
2719   List.iter (
2720     fun (name, style, _, _, _, _, _) ->
2721       (* Generate server-side stubs. *)
2722       pr "static void %s_stub (XDR *xdr_in)\n" name;
2723       pr "{\n";
2724       let error_code =
2725         match fst style with
2726         | RErr | RInt _ -> pr "  int r;\n"; "-1"
2727         | RInt64 _ -> pr "  int64_t r;\n"; "-1"
2728         | RBool _ -> pr "  int r;\n"; "-1"
2729         | RConstString _ ->
2730             failwithf "RConstString cannot be returned from a daemon function"
2731         | RString _ -> pr "  char *r;\n"; "NULL"
2732         | RStringList _ | RHashtable _ -> pr "  char **r;\n"; "NULL"
2733         | RIntBool _ -> pr "  guestfs_%s_ret *r;\n" name; "NULL"
2734         | RPVList _ -> pr "  guestfs_lvm_int_pv_list *r;\n"; "NULL"
2735         | RVGList _ -> pr "  guestfs_lvm_int_vg_list *r;\n"; "NULL"
2736         | RLVList _ -> pr "  guestfs_lvm_int_lv_list *r;\n"; "NULL"
2737         | RStat _ -> pr "  guestfs_int_stat *r;\n"; "NULL"
2738         | RStatVFS _ -> pr "  guestfs_int_statvfs *r;\n"; "NULL" in
2739
2740       (match snd style with
2741        | [] -> ()
2742        | args ->
2743            pr "  struct guestfs_%s_args args;\n" name;
2744            List.iter (
2745              function
2746              | String n
2747              | OptString n -> pr "  const char *%s;\n" n
2748              | StringList n -> pr "  char **%s;\n" n
2749              | Bool n -> pr "  int %s;\n" n
2750              | Int n -> pr "  int %s;\n" n
2751              | FileIn _ | FileOut _ -> ()
2752            ) args
2753       );
2754       pr "\n";
2755
2756       (match snd style with
2757        | [] -> ()
2758        | args ->
2759            pr "  memset (&args, 0, sizeof args);\n";
2760            pr "\n";
2761            pr "  if (!xdr_guestfs_%s_args (xdr_in, &args)) {\n" name;
2762            pr "    reply_with_error (\"%%s: daemon failed to decode procedure arguments\", \"%s\");\n" name;
2763            pr "    return;\n";
2764            pr "  }\n";
2765            List.iter (
2766              function
2767              | String n -> pr "  %s = args.%s;\n" n n
2768              | OptString n -> pr "  %s = args.%s ? *args.%s : NULL;\n" n n n
2769              | StringList n ->
2770                  pr "  %s = realloc (args.%s.%s_val,\n" n n n;
2771                  pr "                sizeof (char *) * (args.%s.%s_len+1));\n" n n;
2772                  pr "  if (%s == NULL) {\n" n;
2773                  pr "    reply_with_perror (\"realloc\");\n";
2774                  pr "    goto done;\n";
2775                  pr "  }\n";
2776                  pr "  %s[args.%s.%s_len] = NULL;\n" n n n;
2777                  pr "  args.%s.%s_val = %s;\n" n n n;
2778              | Bool n -> pr "  %s = args.%s;\n" n n
2779              | Int n -> pr "  %s = args.%s;\n" n n
2780              | FileIn _ | FileOut _ -> ()
2781            ) args;
2782            pr "\n"
2783       );
2784
2785       (* Don't want to call the impl with any FileIn or FileOut
2786        * parameters, since these go "outside" the RPC protocol.
2787        *)
2788       let argsnofile =
2789         List.filter (function FileIn _ | FileOut _ -> false | _ -> true)
2790           (snd style) in
2791       pr "  r = do_%s " name;
2792       generate_call_args argsnofile;
2793       pr ";\n";
2794
2795       pr "  if (r == %s)\n" error_code;
2796       pr "    /* do_%s has already called reply_with_error */\n" name;
2797       pr "    goto done;\n";
2798       pr "\n";
2799
2800       (* If there are any FileOut parameters, then the impl must
2801        * send its own reply.
2802        *)
2803       let no_reply =
2804         List.exists (function FileOut _ -> true | _ -> false) (snd style) in
2805       if no_reply then
2806         pr "  /* do_%s has already sent a reply */\n" name
2807       else (
2808         match fst style with
2809         | RErr -> pr "  reply (NULL, NULL);\n"
2810         | RInt n | RInt64 n | RBool n ->
2811             pr "  struct guestfs_%s_ret ret;\n" name;
2812             pr "  ret.%s = r;\n" n;
2813             pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n"
2814               name
2815         | RConstString _ ->
2816             failwithf "RConstString cannot be returned from a daemon function"
2817         | RString n ->
2818             pr "  struct guestfs_%s_ret ret;\n" name;
2819             pr "  ret.%s = r;\n" n;
2820             pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n"
2821               name;
2822             pr "  free (r);\n"
2823         | RStringList n | RHashtable n ->
2824             pr "  struct guestfs_%s_ret ret;\n" name;
2825             pr "  ret.%s.%s_len = count_strings (r);\n" n n;
2826             pr "  ret.%s.%s_val = r;\n" n n;
2827             pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n"
2828               name;
2829             pr "  free_strings (r);\n"
2830         | RIntBool _ ->
2831             pr "  reply ((xdrproc_t) xdr_guestfs_%s_ret, (char *) r);\n"
2832               name;
2833             pr "  xdr_free ((xdrproc_t) xdr_guestfs_%s_ret, (char *) r);\n" name
2834         | RPVList n | RVGList n | RLVList n
2835         | RStat n | RStatVFS n ->
2836             pr "  struct guestfs_%s_ret ret;\n" name;
2837             pr "  ret.%s = *r;\n" n;
2838             pr "  reply ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n"
2839               name;
2840             pr "  xdr_free ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n"
2841               name
2842       );
2843
2844       (* Free the args. *)
2845       (match snd style with
2846        | [] ->
2847            pr "done: ;\n";
2848        | _ ->
2849            pr "done:\n";
2850            pr "  xdr_free ((xdrproc_t) xdr_guestfs_%s_args, (char *) &args);\n"
2851              name
2852       );
2853
2854       pr "}\n\n";
2855   ) daemon_functions;
2856
2857   (* Dispatch function. *)
2858   pr "void dispatch_incoming_message (XDR *xdr_in)\n";
2859   pr "{\n";
2860   pr "  switch (proc_nr) {\n";
2861
2862   List.iter (
2863     fun (name, style, _, _, _, _, _) ->
2864         pr "    case GUESTFS_PROC_%s:\n" (String.uppercase name);
2865         pr "      %s_stub (xdr_in);\n" name;
2866         pr "      break;\n"
2867   ) daemon_functions;
2868
2869   pr "    default:\n";
2870   pr "      reply_with_error (\"dispatch_incoming_message: unknown procedure number %%d\", proc_nr);\n";
2871   pr "  }\n";
2872   pr "}\n";
2873   pr "\n";
2874
2875   (* LVM columns and tokenization functions. *)
2876   (* XXX This generates crap code.  We should rethink how we
2877    * do this parsing.
2878    *)
2879   List.iter (
2880     function
2881     | typ, cols ->
2882         pr "static const char *lvm_%s_cols = \"%s\";\n"
2883           typ (String.concat "," (List.map fst cols));
2884         pr "\n";
2885
2886         pr "static int lvm_tokenize_%s (char *str, struct guestfs_lvm_int_%s *r)\n" typ typ;
2887         pr "{\n";
2888         pr "  char *tok, *p, *next;\n";
2889         pr "  int i, j;\n";
2890         pr "\n";
2891         (*
2892         pr "  fprintf (stderr, \"%%s: <<%%s>>\\n\", __func__, str);\n";
2893         pr "\n";
2894         *)
2895         pr "  if (!str) {\n";
2896         pr "    fprintf (stderr, \"%%s: failed: passed a NULL string\\n\", __func__);\n";
2897         pr "    return -1;\n";
2898         pr "  }\n";
2899         pr "  if (!*str || isspace (*str)) {\n";
2900         pr "    fprintf (stderr, \"%%s: failed: passed a empty string or one beginning with whitespace\\n\", __func__);\n";
2901         pr "    return -1;\n";
2902         pr "  }\n";
2903         pr "  tok = str;\n";
2904         List.iter (
2905           fun (name, coltype) ->
2906             pr "  if (!tok) {\n";
2907             pr "    fprintf (stderr, \"%%s: failed: string finished early, around token %%s\\n\", __func__, \"%s\");\n" name;
2908             pr "    return -1;\n";
2909             pr "  }\n";
2910             pr "  p = strchrnul (tok, ',');\n";
2911             pr "  if (*p) next = p+1; else next = NULL;\n";
2912             pr "  *p = '\\0';\n";
2913             (match coltype with
2914              | `String ->
2915                  pr "  r->%s = strdup (tok);\n" name;
2916                  pr "  if (r->%s == NULL) {\n" name;
2917                  pr "    perror (\"strdup\");\n";
2918                  pr "    return -1;\n";
2919                  pr "  }\n"
2920              | `UUID ->
2921                  pr "  for (i = j = 0; i < 32; ++j) {\n";
2922                  pr "    if (tok[j] == '\\0') {\n";
2923                  pr "      fprintf (stderr, \"%%s: failed to parse UUID from '%%s'\\n\", __func__, tok);\n";
2924                  pr "      return -1;\n";
2925                  pr "    } else if (tok[j] != '-')\n";
2926                  pr "      r->%s[i++] = tok[j];\n" name;
2927                  pr "  }\n";
2928              | `Bytes ->
2929                  pr "  if (sscanf (tok, \"%%\"SCNu64, &r->%s) != 1) {\n" name;
2930                  pr "    fprintf (stderr, \"%%s: failed to parse size '%%s' from token %%s\\n\", __func__, tok, \"%s\");\n" name;
2931                  pr "    return -1;\n";
2932                  pr "  }\n";
2933              | `Int ->
2934                  pr "  if (sscanf (tok, \"%%\"SCNi64, &r->%s) != 1) {\n" name;
2935                  pr "    fprintf (stderr, \"%%s: failed to parse int '%%s' from token %%s\\n\", __func__, tok, \"%s\");\n" name;
2936                  pr "    return -1;\n";
2937                  pr "  }\n";
2938              | `OptPercent ->
2939                  pr "  if (tok[0] == '\\0')\n";
2940                  pr "    r->%s = -1;\n" name;
2941                  pr "  else if (sscanf (tok, \"%%f\", &r->%s) != 1) {\n" name;
2942                  pr "    fprintf (stderr, \"%%s: failed to parse float '%%s' from token %%s\\n\", __func__, tok, \"%s\");\n" name;
2943                  pr "    return -1;\n";
2944                  pr "  }\n";
2945             );
2946             pr "  tok = next;\n";
2947         ) cols;
2948
2949         pr "  if (tok != NULL) {\n";
2950         pr "    fprintf (stderr, \"%%s: failed: extra tokens at end of string\\n\", __func__);\n";
2951         pr "    return -1;\n";
2952         pr "  }\n";
2953         pr "  return 0;\n";
2954         pr "}\n";
2955         pr "\n";
2956
2957         pr "guestfs_lvm_int_%s_list *\n" typ;
2958         pr "parse_command_line_%ss (void)\n" typ;
2959         pr "{\n";
2960         pr "  char *out, *err;\n";
2961         pr "  char *p, *pend;\n";
2962         pr "  int r, i;\n";
2963         pr "  guestfs_lvm_int_%s_list *ret;\n" typ;
2964         pr "  void *newp;\n";
2965         pr "\n";
2966         pr "  ret = malloc (sizeof *ret);\n";
2967         pr "  if (!ret) {\n";
2968         pr "    reply_with_perror (\"malloc\");\n";
2969         pr "    return NULL;\n";
2970         pr "  }\n";
2971         pr "\n";
2972         pr "  ret->guestfs_lvm_int_%s_list_len = 0;\n" typ;
2973         pr "  ret->guestfs_lvm_int_%s_list_val = NULL;\n" typ;
2974         pr "\n";
2975         pr "  r = command (&out, &err,\n";
2976         pr "           \"/sbin/lvm\", \"%ss\",\n" typ;
2977         pr "           \"-o\", lvm_%s_cols, \"--unbuffered\", \"--noheadings\",\n" typ;
2978         pr "           \"--nosuffix\", \"--separator\", \",\", \"--units\", \"b\", NULL);\n";
2979         pr "  if (r == -1) {\n";
2980         pr "    reply_with_error (\"%%s\", err);\n";
2981         pr "    free (out);\n";
2982         pr "    free (err);\n";
2983         pr "    free (ret);\n";
2984         pr "    return NULL;\n";
2985         pr "  }\n";
2986         pr "\n";
2987         pr "  free (err);\n";
2988         pr "\n";
2989         pr "  /* Tokenize each line of the output. */\n";
2990         pr "  p = out;\n";
2991         pr "  i = 0;\n";
2992         pr "  while (p) {\n";
2993         pr "    pend = strchr (p, '\\n');       /* Get the next line of output. */\n";
2994         pr "    if (pend) {\n";
2995         pr "      *pend = '\\0';\n";
2996         pr "      pend++;\n";
2997         pr "    }\n";
2998         pr "\n";
2999         pr "    while (*p && isspace (*p))      /* Skip any leading whitespace. */\n";
3000         pr "      p++;\n";
3001         pr "\n";
3002         pr "    if (!*p) {                      /* Empty line?  Skip it. */\n";
3003         pr "      p = pend;\n";
3004         pr "      continue;\n";
3005         pr "    }\n";
3006         pr "\n";
3007         pr "    /* Allocate some space to store this next entry. */\n";
3008         pr "    newp = realloc (ret->guestfs_lvm_int_%s_list_val,\n" typ;
3009         pr "                sizeof (guestfs_lvm_int_%s) * (i+1));\n" typ;
3010         pr "    if (newp == NULL) {\n";
3011         pr "      reply_with_perror (\"realloc\");\n";
3012         pr "      free (ret->guestfs_lvm_int_%s_list_val);\n" typ;
3013         pr "      free (ret);\n";
3014         pr "      free (out);\n";
3015         pr "      return NULL;\n";
3016         pr "    }\n";
3017         pr "    ret->guestfs_lvm_int_%s_list_val = newp;\n" typ;
3018         pr "\n";
3019         pr "    /* Tokenize the next entry. */\n";
3020         pr "    r = lvm_tokenize_%s (p, &ret->guestfs_lvm_int_%s_list_val[i]);\n" typ typ;
3021         pr "    if (r == -1) {\n";
3022         pr "      reply_with_error (\"failed to parse output of '%ss' command\");\n" typ;
3023         pr "      free (ret->guestfs_lvm_int_%s_list_val);\n" typ;
3024         pr "      free (ret);\n";
3025         pr "      free (out);\n";
3026         pr "      return NULL;\n";
3027         pr "    }\n";
3028         pr "\n";
3029         pr "    ++i;\n";
3030         pr "    p = pend;\n";
3031         pr "  }\n";
3032         pr "\n";
3033         pr "  ret->guestfs_lvm_int_%s_list_len = i;\n" typ;
3034         pr "\n";
3035         pr "  free (out);\n";
3036         pr "  return ret;\n";
3037         pr "}\n"
3038
3039   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols]
3040
3041 (* Generate the tests. *)
3042 and generate_tests () =
3043   generate_header CStyle GPLv2;
3044
3045   pr "\
3046 #include <stdio.h>
3047 #include <stdlib.h>
3048 #include <string.h>
3049 #include <unistd.h>
3050 #include <sys/types.h>
3051 #include <fcntl.h>
3052
3053 #include \"guestfs.h\"
3054
3055 static guestfs_h *g;
3056 static int suppress_error = 0;
3057
3058 static void print_error (guestfs_h *g, void *data, const char *msg)
3059 {
3060   if (!suppress_error)
3061     fprintf (stderr, \"%%s\\n\", msg);
3062 }
3063
3064 static void print_strings (char * const * const argv)
3065 {
3066   int argc;
3067
3068   for (argc = 0; argv[argc] != NULL; ++argc)
3069     printf (\"\\t%%s\\n\", argv[argc]);
3070 }
3071
3072 /*
3073 static void print_table (char * const * const argv)
3074 {
3075   int i;
3076
3077   for (i = 0; argv[i] != NULL; i += 2)
3078     printf (\"%%s: %%s\\n\", argv[i], argv[i+1]);
3079 }
3080 */
3081
3082 static void no_test_warnings (void)
3083 {
3084 ";
3085
3086   List.iter (
3087     function
3088     | name, _, _, _, [], _, _ ->
3089         pr "  fprintf (stderr, \"warning: \\\"guestfs_%s\\\" has no tests\\n\");\n" name
3090     | name, _, _, _, tests, _, _ -> ()
3091   ) all_functions;
3092
3093   pr "}\n";
3094   pr "\n";
3095
3096   (* Generate the actual tests.  Note that we generate the tests
3097    * in reverse order, deliberately, so that (in general) the
3098    * newest tests run first.  This makes it quicker and easier to
3099    * debug them.
3100    *)
3101   let test_names =
3102     List.map (
3103       fun (name, _, _, _, tests, _, _) ->
3104         mapi (generate_one_test name) tests
3105     ) (List.rev all_functions) in
3106   let test_names = List.concat test_names in
3107   let nr_tests = List.length test_names in
3108
3109   pr "\
3110 int main (int argc, char *argv[])
3111 {
3112   char c = 0;
3113   int failed = 0;
3114   const char *srcdir;
3115   const char *filename;
3116   int fd;
3117   int nr_tests, test_num = 0;
3118
3119   no_test_warnings ();
3120
3121   g = guestfs_create ();
3122   if (g == NULL) {
3123     printf (\"guestfs_create FAILED\\n\");
3124     exit (1);
3125   }
3126
3127   guestfs_set_error_handler (g, print_error, NULL);
3128
3129   srcdir = getenv (\"srcdir\");
3130   if (!srcdir) srcdir = \".\";
3131   chdir (srcdir);
3132   guestfs_set_path (g, \".\");
3133
3134   filename = \"test1.img\";
3135   fd = open (filename, O_WRONLY|O_CREAT|O_NOCTTY|O_NONBLOCK|O_TRUNC, 0666);
3136   if (fd == -1) {
3137     perror (filename);
3138     exit (1);
3139   }
3140   if (lseek (fd, %d, SEEK_SET) == -1) {
3141     perror (\"lseek\");
3142     close (fd);
3143     unlink (filename);
3144     exit (1);
3145   }
3146   if (write (fd, &c, 1) == -1) {
3147     perror (\"write\");
3148     close (fd);
3149     unlink (filename);
3150     exit (1);
3151   }
3152   if (close (fd) == -1) {
3153     perror (filename);
3154     unlink (filename);
3155     exit (1);
3156   }
3157   if (guestfs_add_drive (g, filename) == -1) {
3158     printf (\"guestfs_add_drive %%s FAILED\\n\", filename);
3159     exit (1);
3160   }
3161
3162   filename = \"test2.img\";
3163   fd = open (filename, O_WRONLY|O_CREAT|O_NOCTTY|O_NONBLOCK|O_TRUNC, 0666);
3164   if (fd == -1) {
3165     perror (filename);
3166     exit (1);
3167   }
3168   if (lseek (fd, %d, SEEK_SET) == -1) {
3169     perror (\"lseek\");
3170     close (fd);
3171     unlink (filename);
3172     exit (1);
3173   }
3174   if (write (fd, &c, 1) == -1) {
3175     perror (\"write\");
3176     close (fd);
3177     unlink (filename);
3178     exit (1);
3179   }
3180   if (close (fd) == -1) {
3181     perror (filename);
3182     unlink (filename);
3183     exit (1);
3184   }
3185   if (guestfs_add_drive (g, filename) == -1) {
3186     printf (\"guestfs_add_drive %%s FAILED\\n\", filename);
3187     exit (1);
3188   }
3189
3190   filename = \"test3.img\";
3191   fd = open (filename, O_WRONLY|O_CREAT|O_NOCTTY|O_NONBLOCK|O_TRUNC, 0666);
3192   if (fd == -1) {
3193     perror (filename);
3194     exit (1);
3195   }
3196   if (lseek (fd, %d, SEEK_SET) == -1) {
3197     perror (\"lseek\");
3198     close (fd);
3199     unlink (filename);
3200     exit (1);
3201   }
3202   if (write (fd, &c, 1) == -1) {
3203     perror (\"write\");
3204     close (fd);
3205     unlink (filename);
3206     exit (1);
3207   }
3208   if (close (fd) == -1) {
3209     perror (filename);
3210     unlink (filename);
3211     exit (1);
3212   }
3213   if (guestfs_add_drive (g, filename) == -1) {
3214     printf (\"guestfs_add_drive %%s FAILED\\n\", filename);
3215     exit (1);
3216   }
3217
3218   if (guestfs_launch (g) == -1) {
3219     printf (\"guestfs_launch FAILED\\n\");
3220     exit (1);
3221   }
3222   if (guestfs_wait_ready (g) == -1) {
3223     printf (\"guestfs_wait_ready FAILED\\n\");
3224     exit (1);
3225   }
3226
3227   nr_tests = %d;
3228
3229 " (500 * 1024 * 1024) (50 * 1024 * 1024) (10 * 1024 * 1024) nr_tests;
3230
3231   iteri (
3232     fun i test_name ->
3233       pr "  test_num++;\n";
3234       pr "  printf (\"%%3d/%%3d %s\\n\", test_num, nr_tests);\n" test_name;
3235       pr "  if (%s () == -1) {\n" test_name;
3236       pr "    printf (\"%s FAILED\\n\");\n" test_name;
3237       pr "    failed++;\n";
3238       pr "  }\n";
3239   ) test_names;
3240   pr "\n";
3241
3242   pr "  guestfs_close (g);\n";
3243   pr "  unlink (\"test1.img\");\n";
3244   pr "  unlink (\"test2.img\");\n";
3245   pr "  unlink (\"test3.img\");\n";
3246   pr "\n";
3247
3248   pr "  if (failed > 0) {\n";
3249   pr "    printf (\"***** %%d / %%d tests FAILED *****\\n\", failed, nr_tests);\n";
3250   pr "    exit (1);\n";
3251   pr "  }\n";
3252   pr "\n";
3253
3254   pr "  exit (0);\n";
3255   pr "}\n"
3256
3257 and generate_one_test name i (init, test) =
3258   let test_name = sprintf "test_%s_%d" name i in
3259
3260   pr "static int %s (void)\n" test_name;
3261   pr "{\n";
3262
3263   (match init with
3264    | InitNone -> ()
3265    | InitEmpty ->
3266        pr "  /* InitEmpty for %s (%d) */\n" name i;
3267        List.iter (generate_test_command_call test_name)
3268          [["umount_all"];
3269           ["lvm_remove_all"]]
3270    | InitBasicFS ->
3271        pr "  /* InitBasicFS for %s (%d): create ext2 on /dev/sda1 */\n" name i;
3272        List.iter (generate_test_command_call test_name)
3273          [["umount_all"];
3274           ["lvm_remove_all"];
3275           ["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ","];
3276           ["mkfs"; "ext2"; "/dev/sda1"];
3277           ["mount"; "/dev/sda1"; "/"]]
3278    | InitBasicFSonLVM ->
3279        pr "  /* InitBasicFSonLVM for %s (%d): create ext2 on /dev/VG/LV */\n"
3280          name i;
3281        List.iter (generate_test_command_call test_name)
3282          [["umount_all"];
3283           ["lvm_remove_all"];
3284           ["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ","];
3285           ["pvcreate"; "/dev/sda1"];
3286           ["vgcreate"; "VG"; "/dev/sda1"];
3287           ["lvcreate"; "LV"; "VG"; "8"];
3288           ["mkfs"; "ext2"; "/dev/VG/LV"];
3289           ["mount"; "/dev/VG/LV"; "/"]]
3290   );
3291
3292   let get_seq_last = function
3293     | [] ->
3294         failwithf "%s: you cannot use [] (empty list) when expecting a command"
3295           test_name
3296     | seq ->
3297         let seq = List.rev seq in
3298         List.rev (List.tl seq), List.hd seq
3299   in
3300
3301   (match test with
3302    | TestRun seq ->
3303        pr "  /* TestRun for %s (%d) */\n" name i;
3304        List.iter (generate_test_command_call test_name) seq
3305    | TestOutput (seq, expected) ->
3306        pr "  /* TestOutput for %s (%d) */\n" name i;
3307        let seq, last = get_seq_last seq in
3308        let test () =
3309          pr "    if (strcmp (r, \"%s\") != 0) {\n" (c_quote expected);
3310          pr "      fprintf (stderr, \"%s: expected \\\"%s\\\" but got \\\"%%s\\\"\\n\", r);\n" test_name (c_quote expected);
3311          pr "      return -1;\n";
3312          pr "    }\n"
3313        in
3314        List.iter (generate_test_command_call test_name) seq;
3315        generate_test_command_call ~test test_name last
3316    | TestOutputList (seq, expected) ->
3317        pr "  /* TestOutputList for %s (%d) */\n" name i;
3318        let seq, last = get_seq_last seq in
3319        let test () =
3320          iteri (
3321            fun i str ->
3322              pr "    if (!r[%d]) {\n" i;
3323              pr "      fprintf (stderr, \"%s: short list returned from command\\n\");\n" test_name;
3324              pr "      print_strings (r);\n";
3325              pr "      return -1;\n";
3326              pr "    }\n";
3327              pr "    if (strcmp (r[%d], \"%s\") != 0) {\n" i (c_quote str);
3328              pr "      fprintf (stderr, \"%s: expected \\\"%s\\\" but got \\\"%%s\\\"\\n\", r[%d]);\n" test_name (c_quote str) i;
3329              pr "      return -1;\n";
3330              pr "    }\n"
3331          ) expected;
3332          pr "    if (r[%d] != NULL) {\n" (List.length expected);
3333          pr "      fprintf (stderr, \"%s: extra elements returned from command\\n\");\n"
3334            test_name;
3335          pr "      print_strings (r);\n";
3336          pr "      return -1;\n";
3337          pr "    }\n"
3338        in
3339        List.iter (generate_test_command_call test_name) seq;
3340        generate_test_command_call ~test test_name last
3341    | TestOutputInt (seq, expected) ->
3342        pr "  /* TestOutputInt for %s (%d) */\n" name i;
3343        let seq, last = get_seq_last seq in
3344        let test () =
3345          pr "    if (r != %d) {\n" expected;
3346          pr "      fprintf (stderr, \"%s: expected %d but got %%d\\n\","
3347            test_name expected;
3348          pr "               (int) r);\n";
3349          pr "      return -1;\n";
3350          pr "    }\n"
3351        in
3352        List.iter (generate_test_command_call test_name) seq;
3353        generate_test_command_call ~test test_name last
3354    | TestOutputTrue seq ->
3355        pr "  /* TestOutputTrue for %s (%d) */\n" name i;
3356        let seq, last = get_seq_last seq in
3357        let test () =
3358          pr "    if (!r) {\n";
3359          pr "      fprintf (stderr, \"%s: expected true, got false\\n\");\n"
3360            test_name;
3361          pr "      return -1;\n";
3362          pr "    }\n"
3363        in
3364        List.iter (generate_test_command_call test_name) seq;
3365        generate_test_command_call ~test test_name last
3366    | TestOutputFalse seq ->
3367        pr "  /* TestOutputFalse for %s (%d) */\n" name i;
3368        let seq, last = get_seq_last seq in
3369        let test () =
3370          pr "    if (r) {\n";
3371          pr "      fprintf (stderr, \"%s: expected false, got true\\n\");\n"
3372            test_name;
3373          pr "      return -1;\n";
3374          pr "    }\n"
3375        in
3376        List.iter (generate_test_command_call test_name) seq;
3377        generate_test_command_call ~test test_name last
3378    | TestOutputLength (seq, expected) ->
3379        pr "  /* TestOutputLength for %s (%d) */\n" name i;
3380        let seq, last = get_seq_last seq in
3381        let test () =
3382          pr "    int j;\n";
3383          pr "    for (j = 0; j < %d; ++j)\n" expected;
3384          pr "      if (r[j] == NULL) {\n";
3385          pr "        fprintf (stderr, \"%s: short list returned\\n\");\n"
3386            test_name;
3387          pr "        print_strings (r);\n";
3388          pr "        return -1;\n";
3389          pr "      }\n";
3390          pr "    if (r[j] != NULL) {\n";
3391          pr "      fprintf (stderr, \"%s: long list returned\\n\");\n"
3392            test_name;
3393          pr "      print_strings (r);\n";
3394          pr "      return -1;\n";
3395          pr "    }\n"
3396        in
3397        List.iter (generate_test_command_call test_name) seq;
3398        generate_test_command_call ~test test_name last
3399    | TestOutputStruct (seq, checks) ->
3400        pr "  /* TestOutputStruct for %s (%d) */\n" name i;
3401        let seq, last = get_seq_last seq in
3402        let test () =
3403          List.iter (
3404            function
3405            | CompareWithInt (field, expected) ->
3406                pr "    if (r->%s != %d) {\n" field expected;
3407                pr "      fprintf (stderr, \"%s: %s was %%d, expected %d\\n\",\n"
3408                  test_name field expected;
3409                pr "               (int) r->%s);\n" field;
3410                pr "      return -1;\n";
3411                pr "    }\n"
3412            | CompareWithString (field, expected) ->
3413                pr "    if (strcmp (r->%s, \"%s\") != 0) {\n" field expected;
3414                pr "      fprintf (stderr, \"%s: %s was \"%%s\", expected \"%s\"\\n\",\n"
3415                  test_name field expected;
3416                pr "               r->%s);\n" field;
3417                pr "      return -1;\n";
3418                pr "    }\n"
3419            | CompareFieldsIntEq (field1, field2) ->
3420                pr "    if (r->%s != r->%s) {\n" field1 field2;
3421                pr "      fprintf (stderr, \"%s: %s (%%d) <> %s (%%d)\\n\",\n"
3422                  test_name field1 field2;
3423                pr "               (int) r->%s, (int) r->%s);\n" field1 field2;
3424                pr "      return -1;\n";
3425                pr "    }\n"
3426            | CompareFieldsStrEq (field1, field2) ->
3427                pr "    if (strcmp (r->%s, r->%s) != 0) {\n" field1 field2;
3428                pr "      fprintf (stderr, \"%s: %s (\"%%s\") <> %s (\"%%s\")\\n\",\n"
3429                  test_name field1 field2;
3430                pr "               r->%s, r->%s);\n" field1 field2;
3431                pr "      return -1;\n";
3432                pr "    }\n"
3433          ) checks
3434        in
3435        List.iter (generate_test_command_call test_name) seq;
3436        generate_test_command_call ~test test_name last
3437    | TestLastFail seq ->
3438        pr "  /* TestLastFail for %s (%d) */\n" name i;
3439        let seq, last = get_seq_last seq in
3440        List.iter (generate_test_command_call test_name) seq;
3441        generate_test_command_call test_name ~expect_error:true last
3442   );
3443
3444   pr "  return 0;\n";
3445   pr "}\n";
3446   pr "\n";
3447   test_name
3448
3449 (* Generate the code to run a command, leaving the result in 'r'.
3450  * If you expect to get an error then you should set expect_error:true.
3451  *)
3452 and generate_test_command_call ?(expect_error = false) ?test test_name cmd =
3453   match cmd with
3454   | [] -> assert false
3455   | name :: args ->
3456       (* Look up the command to find out what args/ret it has. *)
3457       let style =
3458         try
3459           let _, style, _, _, _, _, _ =
3460             List.find (fun (n, _, _, _, _, _, _) -> n = name) all_functions in
3461           style
3462         with Not_found ->
3463           failwithf "%s: in test, command %s was not found" test_name name in
3464
3465       if List.length (snd style) <> List.length args then
3466         failwithf "%s: in test, wrong number of args given to %s"
3467           test_name name;
3468
3469       pr "  {\n";
3470
3471       List.iter (
3472         function
3473         | String _, _
3474         | OptString _, _
3475         | Int _, _
3476         | Bool _, _ -> ()
3477         | FileIn _, _ | FileOut _, _ -> ()
3478         | StringList n, arg ->
3479             pr "    char *%s[] = {\n" n;
3480             let strs = string_split " " arg in
3481             List.iter (
3482               fun str -> pr "      \"%s\",\n" (c_quote str)
3483             ) strs;
3484             pr "      NULL\n";
3485             pr "    };\n";
3486       ) (List.combine (snd style) args);
3487
3488       let error_code =
3489         match fst style with
3490         | RErr | RInt _ | RBool _ -> pr "    int r;\n"; "-1"
3491         | RInt64 _ -> pr "    int64_t r;\n"; "-1"
3492         | RConstString _ -> pr "    const char *r;\n"; "NULL"
3493         | RString _ -> pr "    char *r;\n"; "NULL"
3494         | RStringList _ | RHashtable _ ->
3495             pr "    char **r;\n";
3496             pr "    int i;\n";
3497             "NULL"
3498         | RIntBool _ ->
3499             pr "    struct guestfs_int_bool *r;\n"; "NULL"
3500         | RPVList _ ->
3501             pr "    struct guestfs_lvm_pv_list *r;\n"; "NULL"
3502         | RVGList _ ->
3503             pr "    struct guestfs_lvm_vg_list *r;\n"; "NULL"
3504         | RLVList _ ->
3505             pr "    struct guestfs_lvm_lv_list *r;\n"; "NULL"
3506         | RStat _ ->
3507             pr "    struct guestfs_stat *r;\n"; "NULL"
3508         | RStatVFS _ ->
3509             pr "    struct guestfs_statvfs *r;\n"; "NULL" in
3510
3511       pr "    suppress_error = %d;\n" (if expect_error then 1 else 0);
3512       pr "    r = guestfs_%s (g" name;
3513
3514       (* Generate the parameters. *)
3515       List.iter (
3516         function
3517         | String _, arg
3518         | FileIn _, arg | FileOut _, arg ->
3519             pr ", \"%s\"" (c_quote arg)
3520         | OptString _, arg ->
3521             if arg = "NULL" then pr ", NULL" else pr ", \"%s\"" (c_quote arg)
3522         | StringList n, _ ->
3523             pr ", %s" n
3524         | Int _, arg ->
3525             let i =
3526               try int_of_string arg
3527               with Failure "int_of_string" ->
3528                 failwithf "%s: expecting an int, but got '%s'" test_name arg in
3529             pr ", %d" i
3530         | Bool _, arg ->
3531             let b = bool_of_string arg in pr ", %d" (if b then 1 else 0)
3532       ) (List.combine (snd style) args);
3533
3534       pr ");\n";
3535       if not expect_error then
3536         pr "    if (r == %s)\n" error_code
3537       else
3538         pr "    if (r != %s)\n" error_code;
3539       pr "      return -1;\n";
3540
3541       (* Insert the test code. *)
3542       (match test with
3543        | None -> ()
3544        | Some f -> f ()
3545       );
3546
3547       (match fst style with
3548        | RErr | RInt _ | RInt64 _ | RBool _ | RConstString _ -> ()
3549        | RString _ -> pr "    free (r);\n"
3550        | RStringList _ | RHashtable _ ->
3551            pr "    for (i = 0; r[i] != NULL; ++i)\n";
3552            pr "      free (r[i]);\n";
3553            pr "    free (r);\n"
3554        | RIntBool _ ->
3555            pr "    guestfs_free_int_bool (r);\n"
3556        | RPVList _ ->
3557            pr "    guestfs_free_lvm_pv_list (r);\n"
3558        | RVGList _ ->
3559            pr "    guestfs_free_lvm_vg_list (r);\n"
3560        | RLVList _ ->
3561            pr "    guestfs_free_lvm_lv_list (r);\n"
3562        | RStat _ | RStatVFS _ ->
3563            pr "    free (r);\n"
3564       );
3565
3566       pr "  }\n"
3567
3568 and c_quote str =
3569   let str = replace_str str "\r" "\\r" in
3570   let str = replace_str str "\n" "\\n" in
3571   let str = replace_str str "\t" "\\t" in
3572   str
3573
3574 (* Generate a lot of different functions for guestfish. *)
3575 and generate_fish_cmds () =
3576   generate_header CStyle GPLv2;
3577
3578   let all_functions =
3579     List.filter (
3580       fun (_, _, _, flags, _, _, _) -> not (List.mem NotInFish flags)
3581     ) all_functions in
3582   let all_functions_sorted =
3583     List.filter (
3584       fun (_, _, _, flags, _, _, _) -> not (List.mem NotInFish flags)
3585     ) all_functions_sorted in
3586
3587   pr "#include <stdio.h>\n";
3588   pr "#include <stdlib.h>\n";
3589   pr "#include <string.h>\n";
3590   pr "#include <inttypes.h>\n";
3591   pr "\n";
3592   pr "#include <guestfs.h>\n";
3593   pr "#include \"fish.h\"\n";
3594   pr "\n";
3595
3596   (* list_commands function, which implements guestfish -h *)
3597   pr "void list_commands (void)\n";
3598   pr "{\n";
3599   pr "  printf (\"    %%-16s     %%s\\n\", \"Command\", \"Description\");\n";
3600   pr "  list_builtin_commands ();\n";
3601   List.iter (
3602     fun (name, _, _, flags, _, shortdesc, _) ->
3603       let name = replace_char name '_' '-' in
3604       pr "  printf (\"%%-20s %%s\\n\", \"%s\", \"%s\");\n"
3605         name shortdesc
3606   ) all_functions_sorted;
3607   pr "  printf (\"    Use -h <cmd> / help <cmd> to show detailed help for a command.\\n\");\n";
3608   pr "}\n";
3609   pr "\n";
3610
3611   (* display_command function, which implements guestfish -h cmd *)
3612   pr "void display_command (const char *cmd)\n";
3613   pr "{\n";
3614   List.iter (
3615     fun (name, style, _, flags, _, shortdesc, longdesc) ->
3616       let name2 = replace_char name '_' '-' in
3617       let alias =
3618         try find_map (function FishAlias n -> Some n | _ -> None) flags
3619         with Not_found -> name in
3620       let longdesc = replace_str longdesc "C<guestfs_" "C<" in
3621       let synopsis =
3622         match snd style with
3623         | [] -> name2
3624         | args ->
3625             sprintf "%s <%s>"
3626               name2 (String.concat "> <" (List.map name_of_argt args)) in
3627
3628       let warnings =
3629         if List.mem ProtocolLimitWarning flags then
3630           ("\n\n" ^ protocol_limit_warning)
3631         else "" in
3632
3633       (* For DangerWillRobinson commands, we should probably have
3634        * guestfish prompt before allowing you to use them (especially
3635        * in interactive mode). XXX
3636        *)
3637       let warnings =
3638         warnings ^
3639           if List.mem DangerWillRobinson flags then
3640             ("\n\n" ^ danger_will_robinson)
3641           else "" in
3642
3643       let describe_alias =
3644         if name <> alias then
3645           sprintf "\n\nYou can use '%s' as an alias for this command." alias
3646         else "" in
3647
3648       pr "  if (";
3649       pr "strcasecmp (cmd, \"%s\") == 0" name;
3650       if name <> name2 then
3651         pr " || strcasecmp (cmd, \"%s\") == 0" name2;
3652       if name <> alias then
3653         pr " || strcasecmp (cmd, \"%s\") == 0" alias;
3654       pr ")\n";
3655       pr "    pod2text (\"%s - %s\", %S);\n"
3656         name2 shortdesc
3657         (" " ^ synopsis ^ "\n\n" ^ longdesc ^ warnings ^ describe_alias);
3658       pr "  else\n"
3659   ) all_functions;
3660   pr "    display_builtin_command (cmd);\n";
3661   pr "}\n";
3662   pr "\n";
3663
3664   (* print_{pv,vg,lv}_list functions *)
3665   List.iter (
3666     function
3667     | typ, cols ->
3668         pr "static void print_%s (struct guestfs_lvm_%s *%s)\n" typ typ typ;
3669         pr "{\n";
3670         pr "  int i;\n";
3671         pr "\n";
3672         List.iter (
3673           function
3674           | name, `String ->
3675               pr "  printf (\"%s: %%s\\n\", %s->%s);\n" name typ name
3676           | name, `UUID ->
3677               pr "  printf (\"%s: \");\n" name;
3678               pr "  for (i = 0; i < 32; ++i)\n";
3679               pr "    printf (\"%%c\", %s->%s[i]);\n" typ name;
3680               pr "  printf (\"\\n\");\n"
3681           | name, `Bytes ->
3682               pr "  printf (\"%s: %%\" PRIu64 \"\\n\", %s->%s);\n" name typ name
3683           | name, `Int ->
3684               pr "  printf (\"%s: %%\" PRIi64 \"\\n\", %s->%s);\n" name typ name
3685           | name, `OptPercent ->
3686               pr "  if (%s->%s >= 0) printf (\"%s: %%g %%%%\\n\", %s->%s);\n"
3687                 typ name name typ name;
3688               pr "  else printf (\"%s: \\n\");\n" name
3689         ) cols;
3690         pr "}\n";
3691         pr "\n";
3692         pr "static void print_%s_list (struct guestfs_lvm_%s_list *%ss)\n"
3693           typ typ typ;
3694         pr "{\n";
3695         pr "  int i;\n";
3696         pr "\n";
3697         pr "  for (i = 0; i < %ss->len; ++i)\n" typ;
3698         pr "    print_%s (&%ss->val[i]);\n" typ typ;
3699         pr "}\n";
3700         pr "\n";
3701   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols];
3702
3703   (* print_{stat,statvfs} functions *)
3704   List.iter (
3705     function
3706     | typ, cols ->
3707         pr "static void print_%s (struct guestfs_%s *%s)\n" typ typ typ;
3708         pr "{\n";
3709         List.iter (
3710           function
3711           | name, `Int ->
3712               pr "  printf (\"%s: %%\" PRIi64 \"\\n\", %s->%s);\n" name typ name
3713         ) cols;
3714         pr "}\n";
3715         pr "\n";
3716   ) ["stat", stat_cols; "statvfs", statvfs_cols];
3717
3718   (* run_<action> actions *)
3719   List.iter (
3720     fun (name, style, _, flags, _, _, _) ->
3721       pr "static int run_%s (const char *cmd, int argc, char *argv[])\n" name;
3722       pr "{\n";
3723       (match fst style with
3724        | RErr
3725        | RInt _
3726        | RBool _ -> pr "  int r;\n"
3727        | RInt64 _ -> pr "  int64_t r;\n"
3728        | RConstString _ -> pr "  const char *r;\n"
3729        | RString _ -> pr "  char *r;\n"
3730        | RStringList _ | RHashtable _ -> pr "  char **r;\n"
3731        | RIntBool _ -> pr "  struct guestfs_int_bool *r;\n"
3732        | RPVList _ -> pr "  struct guestfs_lvm_pv_list *r;\n"
3733        | RVGList _ -> pr "  struct guestfs_lvm_vg_list *r;\n"
3734        | RLVList _ -> pr "  struct guestfs_lvm_lv_list *r;\n"
3735        | RStat _ -> pr "  struct guestfs_stat *r;\n"
3736        | RStatVFS _ -> pr "  struct guestfs_statvfs *r;\n"
3737       );
3738       List.iter (
3739         function
3740         | String n
3741         | OptString n
3742         | FileIn n
3743         | FileOut n -> pr "  const char *%s;\n" n
3744         | StringList n -> pr "  char **%s;\n" n
3745         | Bool n -> pr "  int %s;\n" n
3746         | Int n -> pr "  int %s;\n" n
3747       ) (snd style);
3748
3749       (* Check and convert parameters. *)
3750       let argc_expected = List.length (snd style) in
3751       pr "  if (argc != %d) {\n" argc_expected;
3752       pr "    fprintf (stderr, \"%%s should have %d parameter(s)\\n\", cmd);\n"
3753         argc_expected;
3754       pr "    fprintf (stderr, \"type 'help %%s' for help on %%s\\n\", cmd, cmd);\n";
3755       pr "    return -1;\n";
3756       pr "  }\n";
3757       iteri (
3758         fun i ->
3759           function
3760           | String name -> pr "  %s = argv[%d];\n" name i
3761           | OptString name ->
3762               pr "  %s = strcmp (argv[%d], \"\") != 0 ? argv[%d] : NULL;\n"
3763                 name i i
3764           | FileIn name ->
3765               pr "  %s = strcmp (argv[%d], \"-\") != 0 ? argv[%d] : \"/dev/stdin\";\n"
3766                 name i i
3767           | FileOut name ->
3768               pr "  %s = strcmp (argv[%d], \"-\") != 0 ? argv[%d] : \"/dev/stdout\";\n"
3769                 name i i
3770           | StringList name ->
3771               pr "  %s = parse_string_list (argv[%d]);\n" name i
3772           | Bool name ->
3773               pr "  %s = is_true (argv[%d]) ? 1 : 0;\n" name i
3774           | Int name ->
3775               pr "  %s = atoi (argv[%d]);\n" name i
3776       ) (snd style);
3777
3778       (* Call C API function. *)
3779       let fn =
3780         try find_map (function FishAction n -> Some n | _ -> None) flags
3781         with Not_found -> sprintf "guestfs_%s" name in
3782       pr "  r = %s " fn;
3783       generate_call_args ~handle:"g" (snd style);
3784       pr ";\n";
3785
3786       (* Check return value for errors and display command results. *)
3787       (match fst style with
3788        | RErr -> pr "  return r;\n"
3789        | RInt _ ->
3790            pr "  if (r == -1) return -1;\n";
3791            pr "  printf (\"%%d\\n\", r);\n";
3792            pr "  return 0;\n"
3793        | RInt64 _ ->
3794            pr "  if (r == -1) return -1;\n";
3795            pr "  printf (\"%%\" PRIi64 \"\\n\", r);\n";
3796            pr "  return 0;\n"
3797        | RBool _ ->
3798            pr "  if (r == -1) return -1;\n";
3799            pr "  if (r) printf (\"true\\n\"); else printf (\"false\\n\");\n";
3800            pr "  return 0;\n"
3801        | RConstString _ ->
3802            pr "  if (r == NULL) return -1;\n";
3803            pr "  printf (\"%%s\\n\", r);\n";
3804            pr "  return 0;\n"
3805        | RString _ ->
3806            pr "  if (r == NULL) return -1;\n";
3807            pr "  printf (\"%%s\\n\", r);\n";
3808            pr "  free (r);\n";
3809            pr "  return 0;\n"
3810        | RStringList _ ->
3811            pr "  if (r == NULL) return -1;\n";
3812            pr "  print_strings (r);\n";
3813            pr "  free_strings (r);\n";
3814            pr "  return 0;\n"
3815        | RIntBool _ ->
3816            pr "  if (r == NULL) return -1;\n";
3817            pr "  printf (\"%%d, %%s\\n\", r->i,\n";
3818            pr "    r->b ? \"true\" : \"false\");\n";
3819            pr "  guestfs_free_int_bool (r);\n";
3820            pr "  return 0;\n"
3821        | RPVList _ ->
3822            pr "  if (r == NULL) return -1;\n";
3823            pr "  print_pv_list (r);\n";
3824            pr "  guestfs_free_lvm_pv_list (r);\n";
3825            pr "  return 0;\n"
3826        | RVGList _ ->
3827            pr "  if (r == NULL) return -1;\n";
3828            pr "  print_vg_list (r);\n";
3829            pr "  guestfs_free_lvm_vg_list (r);\n";
3830            pr "  return 0;\n"
3831        | RLVList _ ->
3832            pr "  if (r == NULL) return -1;\n";
3833            pr "  print_lv_list (r);\n";
3834            pr "  guestfs_free_lvm_lv_list (r);\n";
3835            pr "  return 0;\n"
3836        | RStat _ ->
3837            pr "  if (r == NULL) return -1;\n";
3838            pr "  print_stat (r);\n";
3839            pr "  free (r);\n";
3840            pr "  return 0;\n"
3841        | RStatVFS _ ->
3842            pr "  if (r == NULL) return -1;\n";
3843            pr "  print_statvfs (r);\n";
3844            pr "  free (r);\n";
3845            pr "  return 0;\n"
3846        | RHashtable _ ->
3847            pr "  if (r == NULL) return -1;\n";
3848            pr "  print_table (r);\n";
3849            pr "  free_strings (r);\n";
3850            pr "  return 0;\n"
3851       );
3852       pr "}\n";
3853       pr "\n"
3854   ) all_functions;
3855
3856   (* run_action function *)
3857   pr "int run_action (const char *cmd, int argc, char *argv[])\n";
3858   pr "{\n";
3859   List.iter (
3860     fun (name, _, _, flags, _, _, _) ->
3861       let name2 = replace_char name '_' '-' in
3862       let alias =
3863         try find_map (function FishAlias n -> Some n | _ -> None) flags
3864         with Not_found -> name in
3865       pr "  if (";
3866       pr "strcasecmp (cmd, \"%s\") == 0" name;
3867       if name <> name2 then
3868         pr " || strcasecmp (cmd, \"%s\") == 0" name2;
3869       if name <> alias then
3870         pr " || strcasecmp (cmd, \"%s\") == 0" alias;
3871       pr ")\n";
3872       pr "    return run_%s (cmd, argc, argv);\n" name;
3873       pr "  else\n";
3874   ) all_functions;
3875   pr "    {\n";
3876   pr "      fprintf (stderr, \"%%s: unknown command\\n\", cmd);\n";
3877   pr "      return -1;\n";
3878   pr "    }\n";
3879   pr "  return 0;\n";
3880   pr "}\n";
3881   pr "\n"
3882
3883 (* Readline completion for guestfish. *)
3884 and generate_fish_completion () =
3885   generate_header CStyle GPLv2;
3886
3887   let all_functions =
3888     List.filter (
3889       fun (_, _, _, flags, _, _, _) -> not (List.mem NotInFish flags)
3890     ) all_functions in
3891
3892   pr "\
3893 #include <config.h>
3894
3895 #include <stdio.h>
3896 #include <stdlib.h>
3897 #include <string.h>
3898
3899 #ifdef HAVE_LIBREADLINE
3900 #include <readline/readline.h>
3901 #endif
3902
3903 #include \"fish.h\"
3904
3905 #ifdef HAVE_LIBREADLINE
3906
3907 static const char *commands[] = {
3908 ";
3909
3910   (* Get the commands and sort them, including the aliases. *)
3911   let commands =
3912     List.map (
3913       fun (name, _, _, flags, _, _, _) ->
3914         let name2 = replace_char name '_' '-' in
3915         let alias =
3916           try find_map (function FishAlias n -> Some n | _ -> None) flags
3917           with Not_found -> name in
3918
3919         if name <> alias then [name2; alias] else [name2]
3920     ) all_functions in
3921   let commands = List.flatten commands in
3922   let commands = List.sort compare commands in
3923
3924   List.iter (pr "  \"%s\",\n") commands;
3925
3926   pr "  NULL
3927 };
3928
3929 static char *
3930 generator (const char *text, int state)
3931 {
3932   static int index, len;
3933   const char *name;
3934
3935   if (!state) {
3936     index = 0;
3937     len = strlen (text);
3938   }
3939
3940   while ((name = commands[index]) != NULL) {
3941     index++;
3942     if (strncasecmp (name, text, len) == 0)
3943       return strdup (name);
3944   }
3945
3946   return NULL;
3947 }
3948
3949 #endif /* HAVE_LIBREADLINE */
3950
3951 char **do_completion (const char *text, int start, int end)
3952 {
3953   char **matches = NULL;
3954
3955 #ifdef HAVE_LIBREADLINE
3956   if (start == 0)
3957     matches = rl_completion_matches (text, generator);
3958 #endif
3959
3960   return matches;
3961 }
3962 ";
3963
3964 (* Generate the POD documentation for guestfish. *)
3965 and generate_fish_actions_pod () =
3966   let all_functions_sorted =
3967     List.filter (
3968       fun (_, _, _, flags, _, _, _) -> not (List.mem NotInFish flags)
3969     ) all_functions_sorted in
3970
3971   let rex = Str.regexp "C<guestfs_\\([^>]+\\)>" in
3972
3973   List.iter (
3974     fun (name, style, _, flags, _, _, longdesc) ->
3975       let longdesc =
3976         Str.global_substitute rex (
3977           fun s ->
3978             let sub =
3979               try Str.matched_group 1 s
3980               with Not_found ->
3981                 failwithf "error substituting C<guestfs_...> in longdesc of function %s" name in
3982             "C<" ^ replace_char sub '_' '-' ^ ">"
3983         ) longdesc in
3984       let name = replace_char name '_' '-' in
3985       let alias =
3986         try find_map (function FishAlias n -> Some n | _ -> None) flags
3987         with Not_found -> name in
3988
3989       pr "=head2 %s" name;
3990       if name <> alias then
3991         pr " | %s" alias;
3992       pr "\n";
3993       pr "\n";
3994       pr " %s" name;
3995       List.iter (
3996         function
3997         | String n -> pr " %s" n
3998         | OptString n -> pr " %s" n
3999         | StringList n -> pr " '%s ...'" n
4000         | Bool _ -> pr " true|false"
4001         | Int n -> pr " %s" n
4002         | FileIn n | FileOut n -> pr " (%s|-)" n
4003       ) (snd style);
4004       pr "\n";
4005       pr "\n";
4006       pr "%s\n\n" longdesc;
4007
4008       if List.exists (function FileIn _ | FileOut _ -> true
4009                       | _ -> false) (snd style) then
4010         pr "Use C<-> instead of a filename to read/write from stdin/stdout.\n\n";
4011
4012       if List.mem ProtocolLimitWarning flags then
4013         pr "%s\n\n" protocol_limit_warning;
4014
4015       if List.mem DangerWillRobinson flags then
4016         pr "%s\n\n" danger_will_robinson
4017   ) all_functions_sorted
4018
4019 (* Generate a C function prototype. *)
4020 and generate_prototype ?(extern = true) ?(static = false) ?(semicolon = true)
4021     ?(single_line = false) ?(newline = false) ?(in_daemon = false)
4022     ?(prefix = "")
4023     ?handle name style =
4024   if extern then pr "extern ";
4025   if static then pr "static ";
4026   (match fst style with
4027    | RErr -> pr "int "
4028    | RInt _ -> pr "int "
4029    | RInt64 _ -> pr "int64_t "
4030    | RBool _ -> pr "int "
4031    | RConstString _ -> pr "const char *"
4032    | RString _ -> pr "char *"
4033    | RStringList _ | RHashtable _ -> pr "char **"
4034    | RIntBool _ ->
4035        if not in_daemon then pr "struct guestfs_int_bool *"
4036        else pr "guestfs_%s_ret *" name
4037    | RPVList _ ->
4038        if not in_daemon then pr "struct guestfs_lvm_pv_list *"
4039        else pr "guestfs_lvm_int_pv_list *"
4040    | RVGList _ ->
4041        if not in_daemon then pr "struct guestfs_lvm_vg_list *"
4042        else pr "guestfs_lvm_int_vg_list *"
4043    | RLVList _ ->
4044        if not in_daemon then pr "struct guestfs_lvm_lv_list *"
4045        else pr "guestfs_lvm_int_lv_list *"
4046    | RStat _ ->
4047        if not in_daemon then pr "struct guestfs_stat *"
4048        else pr "guestfs_int_stat *"
4049    | RStatVFS _ ->
4050        if not in_daemon then pr "struct guestfs_statvfs *"
4051        else pr "guestfs_int_statvfs *"
4052   );
4053   pr "%s%s (" prefix name;
4054   if handle = None && List.length (snd style) = 0 then
4055     pr "void"
4056   else (
4057     let comma = ref false in
4058     (match handle with
4059      | None -> ()
4060      | Some handle -> pr "guestfs_h *%s" handle; comma := true
4061     );
4062     let next () =
4063       if !comma then (
4064         if single_line then pr ", " else pr ",\n\t\t"
4065       );
4066       comma := true
4067     in
4068     List.iter (
4069       function
4070       | String n
4071       | OptString n -> next (); pr "const char *%s" n
4072       | StringList n -> next (); pr "char * const* const %s" n
4073       | Bool n -> next (); pr "int %s" n
4074       | Int n -> next (); pr "int %s" n
4075       | FileIn n
4076       | FileOut n ->
4077           if not in_daemon then (next (); pr "const char *%s" n)
4078     ) (snd style);
4079   );
4080   pr ")";
4081   if semicolon then pr ";";
4082   if newline then pr "\n"
4083
4084 (* Generate C call arguments, eg "(handle, foo, bar)" *)
4085 and generate_call_args ?handle args =
4086   pr "(";
4087   let comma = ref false in
4088   (match handle with
4089    | None -> ()
4090    | Some handle -> pr "%s" handle; comma := true
4091   );
4092   List.iter (
4093     fun arg ->
4094       if !comma then pr ", ";
4095       comma := true;
4096       pr "%s" (name_of_argt arg)
4097   ) args;
4098   pr ")"
4099
4100 (* Generate the OCaml bindings interface. *)
4101 and generate_ocaml_mli () =
4102   generate_header OCamlStyle LGPLv2;
4103
4104   pr "\
4105 (** For API documentation you should refer to the C API
4106     in the guestfs(3) manual page.  The OCaml API uses almost
4107     exactly the same calls. *)
4108
4109 type t
4110 (** A [guestfs_h] handle. *)
4111
4112 exception Error of string
4113 (** This exception is raised when there is an error. *)
4114
4115 val create : unit -> t
4116
4117 val close : t -> unit
4118 (** Handles are closed by the garbage collector when they become
4119     unreferenced, but callers can also call this in order to
4120     provide predictable cleanup. *)
4121
4122 ";
4123   generate_ocaml_lvm_structure_decls ();
4124
4125   generate_ocaml_stat_structure_decls ();
4126
4127   (* The actions. *)
4128   List.iter (
4129     fun (name, style, _, _, _, shortdesc, _) ->
4130       generate_ocaml_prototype name style;
4131       pr "(** %s *)\n" shortdesc;
4132       pr "\n"
4133   ) all_functions
4134
4135 (* Generate the OCaml bindings implementation. *)
4136 and generate_ocaml_ml () =
4137   generate_header OCamlStyle LGPLv2;
4138
4139   pr "\
4140 type t
4141 exception Error of string
4142 external create : unit -> t = \"ocaml_guestfs_create\"
4143 external close : t -> unit = \"ocaml_guestfs_close\"
4144
4145 let () =
4146   Callback.register_exception \"ocaml_guestfs_error\" (Error \"\")
4147
4148 ";
4149
4150   generate_ocaml_lvm_structure_decls ();
4151
4152   generate_ocaml_stat_structure_decls ();
4153
4154   (* The actions. *)
4155   List.iter (
4156     fun (name, style, _, _, _, shortdesc, _) ->
4157       generate_ocaml_prototype ~is_external:true name style;
4158   ) all_functions
4159
4160 (* Generate the OCaml bindings C implementation. *)
4161 and generate_ocaml_c () =
4162   generate_header CStyle LGPLv2;
4163
4164   pr "\
4165 #include <stdio.h>
4166 #include <stdlib.h>
4167 #include <string.h>
4168
4169 #include <caml/config.h>
4170 #include <caml/alloc.h>
4171 #include <caml/callback.h>
4172 #include <caml/fail.h>
4173 #include <caml/memory.h>
4174 #include <caml/mlvalues.h>
4175 #include <caml/signals.h>
4176
4177 #include <guestfs.h>
4178
4179 #include \"guestfs_c.h\"
4180
4181 /* Copy a hashtable of string pairs into an assoc-list.  We return
4182  * the list in reverse order, but hashtables aren't supposed to be
4183  * ordered anyway.
4184  */
4185 static CAMLprim value
4186 copy_table (char * const * argv)
4187 {
4188   CAMLparam0 ();
4189   CAMLlocal5 (rv, pairv, kv, vv, cons);
4190   int i;
4191
4192   rv = Val_int (0);
4193   for (i = 0; argv[i] != NULL; i += 2) {
4194     kv = caml_copy_string (argv[i]);
4195     vv = caml_copy_string (argv[i+1]);
4196     pairv = caml_alloc (2, 0);
4197     Store_field (pairv, 0, kv);
4198     Store_field (pairv, 1, vv);
4199     cons = caml_alloc (2, 0);
4200     Store_field (cons, 1, rv);
4201     rv = cons;
4202     Store_field (cons, 0, pairv);
4203   }
4204
4205   CAMLreturn (rv);
4206 }
4207
4208 ";
4209
4210   (* LVM struct copy functions. *)
4211   List.iter (
4212     fun (typ, cols) ->
4213       let has_optpercent_col =
4214         List.exists (function (_, `OptPercent) -> true | _ -> false) cols in
4215
4216       pr "static CAMLprim value\n";
4217       pr "copy_lvm_%s (const struct guestfs_lvm_%s *%s)\n" typ typ typ;
4218       pr "{\n";
4219       pr "  CAMLparam0 ();\n";
4220       if has_optpercent_col then
4221         pr "  CAMLlocal3 (rv, v, v2);\n"
4222       else
4223         pr "  CAMLlocal2 (rv, v);\n";
4224       pr "\n";
4225       pr "  rv = caml_alloc (%d, 0);\n" (List.length cols);
4226       iteri (
4227         fun i col ->
4228           (match col with
4229            | name, `String ->
4230                pr "  v = caml_copy_string (%s->%s);\n" typ name
4231            | name, `UUID ->
4232                pr "  v = caml_alloc_string (32);\n";
4233                pr "  memcpy (String_val (v), %s->%s, 32);\n" typ name
4234            | name, `Bytes
4235            | name, `Int ->
4236                pr "  v = caml_copy_int64 (%s->%s);\n" typ name
4237            | name, `OptPercent ->
4238                pr "  if (%s->%s >= 0) { /* Some %s */\n" typ name name;
4239                pr "    v2 = caml_copy_double (%s->%s);\n" typ name;
4240                pr "    v = caml_alloc (1, 0);\n";
4241                pr "    Store_field (v, 0, v2);\n";
4242                pr "  } else /* None */\n";
4243                pr "    v = Val_int (0);\n";
4244           );
4245           pr "  Store_field (rv, %d, v);\n" i
4246       ) cols;
4247       pr "  CAMLreturn (rv);\n";
4248       pr "}\n";
4249       pr "\n";
4250
4251       pr "static CAMLprim value\n";
4252       pr "copy_lvm_%s_list (const struct guestfs_lvm_%s_list *%ss)\n"
4253         typ typ typ;
4254       pr "{\n";
4255       pr "  CAMLparam0 ();\n";
4256       pr "  CAMLlocal2 (rv, v);\n";
4257       pr "  int i;\n";
4258       pr "\n";
4259       pr "  if (%ss->len == 0)\n" typ;
4260       pr "    CAMLreturn (Atom (0));\n";
4261       pr "  else {\n";
4262       pr "    rv = caml_alloc (%ss->len, 0);\n" typ;
4263       pr "    for (i = 0; i < %ss->len; ++i) {\n" typ;
4264       pr "      v = copy_lvm_%s (&%ss->val[i]);\n" typ typ;
4265       pr "      caml_modify (&Field (rv, i), v);\n";
4266       pr "    }\n";
4267       pr "    CAMLreturn (rv);\n";
4268       pr "  }\n";
4269       pr "}\n";
4270       pr "\n";
4271   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols];
4272
4273   (* Stat copy functions. *)
4274   List.iter (
4275     fun (typ, cols) ->
4276       pr "static CAMLprim value\n";
4277       pr "copy_%s (const struct guestfs_%s *%s)\n" typ typ typ;
4278       pr "{\n";
4279       pr "  CAMLparam0 ();\n";
4280       pr "  CAMLlocal2 (rv, v);\n";
4281       pr "\n";
4282       pr "  rv = caml_alloc (%d, 0);\n" (List.length cols);
4283       iteri (
4284         fun i col ->
4285           (match col with
4286            | name, `Int ->
4287                pr "  v = caml_copy_int64 (%s->%s);\n" typ name
4288           );
4289           pr "  Store_field (rv, %d, v);\n" i
4290       ) cols;
4291       pr "  CAMLreturn (rv);\n";
4292       pr "}\n";
4293       pr "\n";
4294   ) ["stat", stat_cols; "statvfs", statvfs_cols];
4295
4296   (* The wrappers. *)