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