Added tune2fs-l command and RHashtable return type.
[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 (* Check function names etc. for consistency. *)
1262 let check_functions () =
1263   let contains_uppercase str =
1264     let len = String.length str in
1265     let rec loop i =
1266       if i >= len then false
1267       else (
1268         let c = str.[i] in
1269         if c >= 'A' && c <= 'Z' then true
1270         else loop (i+1)
1271       )
1272     in
1273     loop 0
1274   in
1275
1276   (* Check function names. *)
1277   List.iter (
1278     fun (name, _, _, _, _, _, _) ->
1279       if String.length name >= 7 && String.sub name 0 7 = "guestfs" then
1280         failwithf "function name %s does not need 'guestfs' prefix" name;
1281       if contains_uppercase name then
1282         failwithf "function name %s should not contain uppercase chars" name;
1283       if String.contains name '-' then
1284         failwithf "function name %s should not contain '-', use '_' instead."
1285           name
1286   ) all_functions;
1287
1288   (* Check function parameter/return names. *)
1289   List.iter (
1290     fun (name, style, _, _, _, _, _) ->
1291       let check_arg_ret_name n =
1292         if contains_uppercase n then
1293           failwithf "%s param/ret %s should not contain uppercase chars"
1294             name n;
1295         if String.contains n '-' || String.contains n '_' then
1296           failwithf "%s param/ret %s should not contain '-' or '_'"
1297             name n;
1298         if n = "value" then
1299           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;
1300         if n = "argv" || n = "args" then
1301           failwithf "%s has a param/ret called 'argv' or 'args', which will cause some conflicts in the generated code" n
1302       in
1303
1304       (match fst style with
1305        | RErr -> ()
1306        | RInt n | RBool n | RConstString n | RString n
1307        | RStringList n | RPVList n | RVGList n | RLVList n
1308        | RStat n | RStatVFS n
1309        | RHashtable n ->
1310            check_arg_ret_name n
1311        | RIntBool (n,m) ->
1312            check_arg_ret_name n;
1313            check_arg_ret_name m
1314       );
1315       List.iter (fun arg -> check_arg_ret_name (name_of_argt arg)) (snd style)
1316   ) all_functions;
1317
1318   (* Check short descriptions. *)
1319   List.iter (
1320     fun (name, _, _, _, _, shortdesc, _) ->
1321       if shortdesc.[0] <> Char.lowercase shortdesc.[0] then
1322         failwithf "short description of %s should begin with lowercase." name;
1323       let c = shortdesc.[String.length shortdesc-1] in
1324       if c = '\n' || c = '.' then
1325         failwithf "short description of %s should not end with . or \\n." name
1326   ) all_functions;
1327
1328   (* Check long dscriptions. *)
1329   List.iter (
1330     fun (name, _, _, _, _, _, longdesc) ->
1331       if longdesc.[String.length longdesc-1] = '\n' then
1332         failwithf "long description of %s should not end with \\n." name
1333   ) all_functions;
1334
1335   (* Check proc_nrs. *)
1336   List.iter (
1337     fun (name, _, proc_nr, _, _, _, _) ->
1338       if proc_nr <= 0 then
1339         failwithf "daemon function %s should have proc_nr > 0" name
1340   ) daemon_functions;
1341
1342   List.iter (
1343     fun (name, _, proc_nr, _, _, _, _) ->
1344       if proc_nr <> -1 then
1345         failwithf "non-daemon function %s should have proc_nr -1" name
1346   ) non_daemon_functions;
1347
1348   let proc_nrs =
1349     List.map (fun (name, _, proc_nr, _, _, _, _) -> name, proc_nr)
1350       daemon_functions in
1351   let proc_nrs =
1352     List.sort (fun (_,nr1) (_,nr2) -> compare nr1 nr2) proc_nrs in
1353   let rec loop = function
1354     | [] -> ()
1355     | [_] -> ()
1356     | (name1,nr1) :: ((name2,nr2) :: _ as rest) when nr1 < nr2 ->
1357         loop rest
1358     | (name1,nr1) :: (name2,nr2) :: _ ->
1359         failwithf "%s and %s have conflicting procedure numbers (%d, %d)"
1360           name1 name2 nr1 nr2
1361   in
1362   loop proc_nrs
1363
1364 (* 'pr' prints to the current output file. *)
1365 let chan = ref stdout
1366 let pr fs = ksprintf (output_string !chan) fs
1367
1368 (* Generate a header block in a number of standard styles. *)
1369 type comment_style = CStyle | HashStyle | OCamlStyle
1370 type license = GPLv2 | LGPLv2
1371
1372 let generate_header comment license =
1373   let c = match comment with
1374     | CStyle ->     pr "/* "; " *"
1375     | HashStyle ->  pr "# ";  "#"
1376     | OCamlStyle -> pr "(* "; " *" in
1377   pr "libguestfs generated file\n";
1378   pr "%s WARNING: THIS FILE IS GENERATED BY 'src/generator.ml'.\n" c;
1379   pr "%s ANY CHANGES YOU MAKE TO THIS FILE WILL BE LOST.\n" c;
1380   pr "%s\n" c;
1381   pr "%s Copyright (C) 2009 Red Hat Inc.\n" c;
1382   pr "%s\n" c;
1383   (match license with
1384    | GPLv2 ->
1385        pr "%s This program is free software; you can redistribute it and/or modify\n" c;
1386        pr "%s it under the terms of the GNU General Public License as published by\n" c;
1387        pr "%s the Free Software Foundation; either version 2 of the License, or\n" c;
1388        pr "%s (at your option) any later version.\n" c;
1389        pr "%s\n" c;
1390        pr "%s This program is distributed in the hope that it will be useful,\n" c;
1391        pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
1392        pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the\n" c;
1393        pr "%s GNU General Public License for more details.\n" c;
1394        pr "%s\n" c;
1395        pr "%s You should have received a copy of the GNU General Public License along\n" c;
1396        pr "%s with this program; if not, write to the Free Software Foundation, Inc.,\n" c;
1397        pr "%s 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n" c;
1398
1399    | LGPLv2 ->
1400        pr "%s This library is free software; you can redistribute it and/or\n" c;
1401        pr "%s modify it under the terms of the GNU Lesser General Public\n" c;
1402        pr "%s License as published by the Free Software Foundation; either\n" c;
1403        pr "%s version 2 of the License, or (at your option) any later version.\n" c;
1404        pr "%s\n" c;
1405        pr "%s This library is distributed in the hope that it will be useful,\n" c;
1406        pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
1407        pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU\n" c;
1408        pr "%s Lesser General Public License for more details.\n" c;
1409        pr "%s\n" c;
1410        pr "%s You should have received a copy of the GNU Lesser General Public\n" c;
1411        pr "%s License along with this library; if not, write to the Free Software\n" c;
1412        pr "%s Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA\n" c;
1413   );
1414   (match comment with
1415    | CStyle -> pr " */\n"
1416    | HashStyle -> ()
1417    | OCamlStyle -> pr " *)\n"
1418   );
1419   pr "\n"
1420
1421 (* Start of main code generation functions below this line. *)
1422
1423 (* Generate the pod documentation for the C API. *)
1424 let rec generate_actions_pod () =
1425   List.iter (
1426     fun (shortname, style, _, flags, _, _, longdesc) ->
1427       let name = "guestfs_" ^ shortname in
1428       pr "=head2 %s\n\n" name;
1429       pr " ";
1430       generate_prototype ~extern:false ~handle:"handle" name style;
1431       pr "\n\n";
1432       pr "%s\n\n" longdesc;
1433       (match fst style with
1434        | RErr ->
1435            pr "This function returns 0 on success or -1 on error.\n\n"
1436        | RInt _ ->
1437            pr "On error this function returns -1.\n\n"
1438        | RBool _ ->
1439            pr "This function returns a C truth value on success or -1 on error.\n\n"
1440        | RConstString _ ->
1441            pr "This function returns a string, or NULL on error.
1442 The string is owned by the guest handle and must I<not> be freed.\n\n"
1443        | RString _ ->
1444            pr "This function returns a string, or NULL on error.
1445 I<The caller must free the returned string after use>.\n\n"
1446        | RStringList _ ->
1447            pr "This function returns a NULL-terminated array of strings
1448 (like L<environ(3)>), or NULL if there was an error.
1449 I<The caller must free the strings and the array after use>.\n\n"
1450        | RIntBool _ ->
1451            pr "This function returns a C<struct guestfs_int_bool *>,
1452 or NULL if there was an error.
1453 I<The caller must call C<guestfs_free_int_bool> after use>.\n\n"
1454        | RPVList _ ->
1455            pr "This function returns a C<struct guestfs_lvm_pv_list *>
1456 (see E<lt>guestfs-structs.hE<gt>),
1457 or NULL if there was an error.
1458 I<The caller must call C<guestfs_free_lvm_pv_list> after use>.\n\n"
1459        | RVGList _ ->
1460            pr "This function returns a C<struct guestfs_lvm_vg_list *>
1461 (see E<lt>guestfs-structs.hE<gt>),
1462 or NULL if there was an error.
1463 I<The caller must call C<guestfs_free_lvm_vg_list> after use>.\n\n"
1464        | RLVList _ ->
1465            pr "This function returns a C<struct guestfs_lvm_lv_list *>
1466 (see E<lt>guestfs-structs.hE<gt>),
1467 or NULL if there was an error.
1468 I<The caller must call C<guestfs_free_lvm_lv_list> after use>.\n\n"
1469        | RStat _ ->
1470            pr "This function returns a C<struct guestfs_stat *>
1471 (see L<stat(2)> and E<lt>guestfs-structs.hE<gt>),
1472 or NULL if there was an error.
1473 I<The caller must call C<free> after use>.\n\n"
1474        | RStatVFS _ ->
1475            pr "This function returns a C<struct guestfs_statvfs *>
1476 (see L<statvfs(2)> and E<lt>guestfs-structs.hE<gt>),
1477 or NULL if there was an error.
1478 I<The caller must call C<free> after use>.\n\n"
1479        | RHashtable _ ->
1480            pr "This function returns a NULL-terminated array of
1481 strings, or NULL if there was an error.
1482 The array of strings will always have length C<2n+1>, where
1483 C<n> keys and values alternate, followed by the trailing NULL entry.
1484 I<The caller must free the strings and the array after use>.\n\n"
1485       );
1486       if List.mem ProtocolLimitWarning flags then
1487         pr "%s\n\n" protocol_limit_warning;
1488       if List.mem DangerWillRobinson flags then
1489         pr "%s\n\n" danger_will_robinson;
1490   ) all_functions_sorted
1491
1492 and generate_structs_pod () =
1493   (* LVM structs documentation. *)
1494   List.iter (
1495     fun (typ, cols) ->
1496       pr "=head2 guestfs_lvm_%s\n" typ;
1497       pr "\n";
1498       pr " struct guestfs_lvm_%s {\n" typ;
1499       List.iter (
1500         function
1501         | name, `String -> pr "  char *%s;\n" name
1502         | name, `UUID ->
1503             pr "  /* The next field is NOT nul-terminated, be careful when printing it: */\n";
1504             pr "  char %s[32];\n" name
1505         | name, `Bytes -> pr "  uint64_t %s;\n" name
1506         | name, `Int -> pr "  int64_t %s;\n" name
1507         | name, `OptPercent ->
1508             pr "  /* The next field is [0..100] or -1 meaning 'not present': */\n";
1509             pr "  float %s;\n" name
1510       ) cols;
1511       pr " \n";
1512       pr " struct guestfs_lvm_%s_list {\n" typ;
1513       pr "   uint32_t len; /* Number of elements in list. */\n";
1514       pr "   struct guestfs_lvm_%s *val; /* Elements. */\n" typ;
1515       pr " };\n";
1516       pr " \n";
1517       pr " void guestfs_free_lvm_%s_list (struct guestfs_free_lvm_%s_list *);\n"
1518         typ typ;
1519       pr "\n"
1520   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols]
1521
1522 (* Generate the protocol (XDR) file, 'guestfs_protocol.x' and
1523  * indirectly 'guestfs_protocol.h' and 'guestfs_protocol.c'.
1524  *
1525  * We have to use an underscore instead of a dash because otherwise
1526  * rpcgen generates incorrect code.
1527  *
1528  * This header is NOT exported to clients, but see also generate_structs_h.
1529  *)
1530 and generate_xdr () =
1531   generate_header CStyle LGPLv2;
1532
1533   (* This has to be defined to get around a limitation in Sun's rpcgen. *)
1534   pr "typedef string str<>;\n";
1535   pr "\n";
1536
1537   (* LVM internal structures. *)
1538   List.iter (
1539     function
1540     | typ, cols ->
1541         pr "struct guestfs_lvm_int_%s {\n" typ;
1542         List.iter (function
1543                    | name, `String -> pr "  string %s<>;\n" name
1544                    | name, `UUID -> pr "  opaque %s[32];\n" name
1545                    | name, `Bytes -> pr "  hyper %s;\n" name
1546                    | name, `Int -> pr "  hyper %s;\n" name
1547                    | name, `OptPercent -> pr "  float %s;\n" name
1548                   ) cols;
1549         pr "};\n";
1550         pr "\n";
1551         pr "typedef struct guestfs_lvm_int_%s guestfs_lvm_int_%s_list<>;\n" typ typ;
1552         pr "\n";
1553   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols];
1554
1555   (* Stat internal structures. *)
1556   List.iter (
1557     function
1558     | typ, cols ->
1559         pr "struct guestfs_int_%s {\n" typ;
1560         List.iter (function
1561                    | name, `Int -> pr "  hyper %s;\n" name
1562                   ) cols;
1563         pr "};\n";
1564         pr "\n";
1565   ) ["stat", stat_cols; "statvfs", statvfs_cols];
1566
1567   List.iter (
1568     fun (shortname, style, _, _, _, _, _) ->
1569       let name = "guestfs_" ^ shortname in
1570
1571       (match snd style with
1572        | [] -> ()
1573        | args ->
1574            pr "struct %s_args {\n" name;
1575            List.iter (
1576              function
1577              | String n -> pr "  string %s<>;\n" n
1578              | OptString n -> pr "  str *%s;\n" n
1579              | StringList n -> pr "  str %s<>;\n" n
1580              | Bool n -> pr "  bool %s;\n" n
1581              | Int n -> pr "  int %s;\n" n
1582            ) args;
1583            pr "};\n\n"
1584       );
1585       (match fst style with
1586        | RErr -> ()
1587        | RInt n ->
1588            pr "struct %s_ret {\n" name;
1589            pr "  int %s;\n" n;
1590            pr "};\n\n"
1591        | RBool n ->
1592            pr "struct %s_ret {\n" name;
1593            pr "  bool %s;\n" n;
1594            pr "};\n\n"
1595        | RConstString _ ->
1596            failwithf "RConstString cannot be returned from a daemon function"
1597        | RString n ->
1598            pr "struct %s_ret {\n" name;
1599            pr "  string %s<>;\n" n;
1600            pr "};\n\n"
1601        | RStringList n ->
1602            pr "struct %s_ret {\n" name;
1603            pr "  str %s<>;\n" n;
1604            pr "};\n\n"
1605        | RIntBool (n,m) ->
1606            pr "struct %s_ret {\n" name;
1607            pr "  int %s;\n" n;
1608            pr "  bool %s;\n" m;
1609            pr "};\n\n"
1610        | RPVList n ->
1611            pr "struct %s_ret {\n" name;
1612            pr "  guestfs_lvm_int_pv_list %s;\n" n;
1613            pr "};\n\n"
1614        | RVGList n ->
1615            pr "struct %s_ret {\n" name;
1616            pr "  guestfs_lvm_int_vg_list %s;\n" n;
1617            pr "};\n\n"
1618        | RLVList n ->
1619            pr "struct %s_ret {\n" name;
1620            pr "  guestfs_lvm_int_lv_list %s;\n" n;
1621            pr "};\n\n"
1622        | RStat n ->
1623            pr "struct %s_ret {\n" name;
1624            pr "  guestfs_int_stat %s;\n" n;
1625            pr "};\n\n"
1626        | RStatVFS n ->
1627            pr "struct %s_ret {\n" name;
1628            pr "  guestfs_int_statvfs %s;\n" n;
1629            pr "};\n\n"
1630        | RHashtable n ->
1631            pr "struct %s_ret {\n" name;
1632            pr "  str %s<>;\n" n;
1633            pr "};\n\n"
1634       );
1635   ) daemon_functions;
1636
1637   (* Table of procedure numbers. *)
1638   pr "enum guestfs_procedure {\n";
1639   List.iter (
1640     fun (shortname, _, proc_nr, _, _, _, _) ->
1641       pr "  GUESTFS_PROC_%s = %d,\n" (String.uppercase shortname) proc_nr
1642   ) daemon_functions;
1643   pr "  GUESTFS_PROC_dummy\n"; (* so we don't have a "hanging comma" *)
1644   pr "};\n";
1645   pr "\n";
1646
1647   (* Having to choose a maximum message size is annoying for several
1648    * reasons (it limits what we can do in the API), but it (a) makes
1649    * the protocol a lot simpler, and (b) provides a bound on the size
1650    * of the daemon which operates in limited memory space.  For large
1651    * file transfers you should use FTP.
1652    *)
1653   pr "const GUESTFS_MESSAGE_MAX = %d;\n" (4 * 1024 * 1024);
1654   pr "\n";
1655
1656   (* Message header, etc. *)
1657   pr "\
1658 const GUESTFS_PROGRAM = 0x2000F5F5;
1659 const GUESTFS_PROTOCOL_VERSION = 1;
1660
1661 enum guestfs_message_direction {
1662   GUESTFS_DIRECTION_CALL = 0,        /* client -> daemon */
1663   GUESTFS_DIRECTION_REPLY = 1        /* daemon -> client */
1664 };
1665
1666 enum guestfs_message_status {
1667   GUESTFS_STATUS_OK = 0,
1668   GUESTFS_STATUS_ERROR = 1
1669 };
1670
1671 const GUESTFS_ERROR_LEN = 256;
1672
1673 struct guestfs_message_error {
1674   string error<GUESTFS_ERROR_LEN>;   /* error message */
1675 };
1676
1677 struct guestfs_message_header {
1678   unsigned prog;                     /* GUESTFS_PROGRAM */
1679   unsigned vers;                     /* GUESTFS_PROTOCOL_VERSION */
1680   guestfs_procedure proc;            /* GUESTFS_PROC_x */
1681   guestfs_message_direction direction;
1682   unsigned serial;                   /* message serial number */
1683   guestfs_message_status status;
1684 };
1685 "
1686
1687 (* Generate the guestfs-structs.h file. *)
1688 and generate_structs_h () =
1689   generate_header CStyle LGPLv2;
1690
1691   (* This is a public exported header file containing various
1692    * structures.  The structures are carefully written to have
1693    * exactly the same in-memory format as the XDR structures that
1694    * we use on the wire to the daemon.  The reason for creating
1695    * copies of these structures here is just so we don't have to
1696    * export the whole of guestfs_protocol.h (which includes much
1697    * unrelated and XDR-dependent stuff that we don't want to be
1698    * public, or required by clients).
1699    *
1700    * To reiterate, we will pass these structures to and from the
1701    * client with a simple assignment or memcpy, so the format
1702    * must be identical to what rpcgen / the RFC defines.
1703    *)
1704
1705   (* guestfs_int_bool structure. *)
1706   pr "struct guestfs_int_bool {\n";
1707   pr "  int32_t i;\n";
1708   pr "  int32_t b;\n";
1709   pr "};\n";
1710   pr "\n";
1711
1712   (* LVM public structures. *)
1713   List.iter (
1714     function
1715     | typ, cols ->
1716         pr "struct guestfs_lvm_%s {\n" typ;
1717         List.iter (
1718           function
1719           | name, `String -> pr "  char *%s;\n" name
1720           | name, `UUID -> pr "  char %s[32]; /* this is NOT nul-terminated, be careful when printing */\n" name
1721           | name, `Bytes -> pr "  uint64_t %s;\n" name
1722           | name, `Int -> pr "  int64_t %s;\n" name
1723           | name, `OptPercent -> pr "  float %s; /* [0..100] or -1 */\n" name
1724         ) cols;
1725         pr "};\n";
1726         pr "\n";
1727         pr "struct guestfs_lvm_%s_list {\n" typ;
1728         pr "  uint32_t len;\n";
1729         pr "  struct guestfs_lvm_%s *val;\n" typ;
1730         pr "};\n";
1731         pr "\n"
1732   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols];
1733
1734   (* Stat structures. *)
1735   List.iter (
1736     function
1737     | typ, cols ->
1738         pr "struct guestfs_%s {\n" typ;
1739         List.iter (
1740           function
1741           | name, `Int -> pr "  int64_t %s;\n" name
1742         ) cols;
1743         pr "};\n";
1744         pr "\n"
1745   ) ["stat", stat_cols; "statvfs", statvfs_cols]
1746
1747 (* Generate the guestfs-actions.h file. *)
1748 and generate_actions_h () =
1749   generate_header CStyle LGPLv2;
1750   List.iter (
1751     fun (shortname, style, _, _, _, _, _) ->
1752       let name = "guestfs_" ^ shortname in
1753       generate_prototype ~single_line:true ~newline:true ~handle:"handle"
1754         name style
1755   ) all_functions
1756
1757 (* Generate the client-side dispatch stubs. *)
1758 and generate_client_actions () =
1759   generate_header CStyle LGPLv2;
1760
1761   (* Client-side stubs for each function. *)
1762   List.iter (
1763     fun (shortname, style, _, _, _, _, _) ->
1764       let name = "guestfs_" ^ shortname in
1765
1766       (* Generate the return value struct. *)
1767       pr "struct %s_rv {\n" shortname;
1768       pr "  int cb_done;  /* flag to indicate callback was called */\n";
1769       pr "  struct guestfs_message_header hdr;\n";
1770       pr "  struct guestfs_message_error err;\n";
1771       (match fst style with
1772        | RErr -> ()
1773        | RConstString _ ->
1774            failwithf "RConstString cannot be returned from a daemon function"
1775        | RInt _
1776        | RBool _ | RString _ | RStringList _
1777        | RIntBool _
1778        | RPVList _ | RVGList _ | RLVList _
1779        | RStat _ | RStatVFS _
1780        | RHashtable _ ->
1781            pr "  struct %s_ret ret;\n" name
1782       );
1783       pr "};\n\n";
1784
1785       (* Generate the callback function. *)
1786       pr "static void %s_cb (guestfs_h *g, void *data, XDR *xdr)\n" shortname;
1787       pr "{\n";
1788       pr "  struct %s_rv *rv = (struct %s_rv *) data;\n" shortname shortname;
1789       pr "\n";
1790       pr "  if (!xdr_guestfs_message_header (xdr, &rv->hdr)) {\n";
1791       pr "    error (g, \"%s: failed to parse reply header\");\n" name;
1792       pr "    return;\n";
1793       pr "  }\n";
1794       pr "  if (rv->hdr.status == GUESTFS_STATUS_ERROR) {\n";
1795       pr "    if (!xdr_guestfs_message_error (xdr, &rv->err)) {\n";
1796       pr "      error (g, \"%s: failed to parse reply error\");\n" name;
1797       pr "      return;\n";
1798       pr "    }\n";
1799       pr "    goto done;\n";
1800       pr "  }\n";
1801
1802       (match fst style with
1803        | RErr -> ()
1804        | RConstString _ ->
1805            failwithf "RConstString cannot be returned from a daemon function"
1806        | RInt _
1807        | RBool _ | RString _ | RStringList _
1808        | RIntBool _
1809        | RPVList _ | RVGList _ | RLVList _
1810        | RStat _ | RStatVFS _
1811        | RHashtable _ ->
1812             pr "  if (!xdr_%s_ret (xdr, &rv->ret)) {\n" name;
1813             pr "    error (g, \"%s: failed to parse reply\");\n" name;
1814             pr "    return;\n";
1815             pr "  }\n";
1816       );
1817
1818       pr " done:\n";
1819       pr "  rv->cb_done = 1;\n";
1820       pr "  main_loop.main_loop_quit (g);\n";
1821       pr "}\n\n";
1822
1823       (* Generate the action stub. *)
1824       generate_prototype ~extern:false ~semicolon:false ~newline:true
1825         ~handle:"g" name style;
1826
1827       let error_code =
1828         match fst style with
1829         | RErr | RInt _ | RBool _ -> "-1"
1830         | RConstString _ ->
1831             failwithf "RConstString cannot be returned from a daemon function"
1832         | RString _ | RStringList _ | RIntBool _
1833         | RPVList _ | RVGList _ | RLVList _
1834         | RStat _ | RStatVFS _
1835         | RHashtable _ ->
1836             "NULL" in
1837
1838       pr "{\n";
1839
1840       (match snd style with
1841        | [] -> ()
1842        | _ -> pr "  struct %s_args args;\n" name
1843       );
1844
1845       pr "  struct %s_rv rv;\n" shortname;
1846       pr "  int serial;\n";
1847       pr "\n";
1848       pr "  if (g->state != READY) {\n";
1849       pr "    error (g, \"%s called from the wrong state, %%d != READY\",\n"
1850         name;
1851       pr "      g->state);\n";
1852       pr "    return %s;\n" error_code;
1853       pr "  }\n";
1854       pr "\n";
1855       pr "  memset (&rv, 0, sizeof rv);\n";
1856       pr "\n";
1857
1858       (match snd style with
1859        | [] ->
1860            pr "  serial = dispatch (g, GUESTFS_PROC_%s, NULL, NULL);\n"
1861              (String.uppercase shortname)
1862        | args ->
1863            List.iter (
1864              function
1865              | String n ->
1866                  pr "  args.%s = (char *) %s;\n" n n
1867              | OptString n ->
1868                  pr "  args.%s = %s ? (char **) &%s : NULL;\n" n n n
1869              | StringList n ->
1870                  pr "  args.%s.%s_val = (char **) %s;\n" n n n;
1871                  pr "  for (args.%s.%s_len = 0; %s[args.%s.%s_len]; args.%s.%s_len++) ;\n" n n n n n n n;
1872              | Bool n ->
1873                  pr "  args.%s = %s;\n" n n
1874              | Int n ->
1875                  pr "  args.%s = %s;\n" n n
1876            ) args;
1877            pr "  serial = dispatch (g, GUESTFS_PROC_%s,\n"
1878              (String.uppercase shortname);
1879            pr "                     (xdrproc_t) xdr_%s_args, (char *) &args);\n"
1880              name;
1881       );
1882       pr "  if (serial == -1)\n";
1883       pr "    return %s;\n" error_code;
1884       pr "\n";
1885
1886       pr "  rv.cb_done = 0;\n";
1887       pr "  g->reply_cb_internal = %s_cb;\n" shortname;
1888       pr "  g->reply_cb_internal_data = &rv;\n";
1889       pr "  main_loop.main_loop_run (g);\n";
1890       pr "  g->reply_cb_internal = NULL;\n";
1891       pr "  g->reply_cb_internal_data = NULL;\n";
1892       pr "  if (!rv.cb_done) {\n";
1893       pr "    error (g, \"%s failed, see earlier error messages\");\n" name;
1894       pr "    return %s;\n" error_code;
1895       pr "  }\n";
1896       pr "\n";
1897
1898       pr "  if (check_reply_header (g, &rv.hdr, GUESTFS_PROC_%s, serial) == -1)\n"
1899         (String.uppercase shortname);
1900       pr "    return %s;\n" error_code;
1901       pr "\n";
1902
1903       pr "  if (rv.hdr.status == GUESTFS_STATUS_ERROR) {\n";
1904       pr "    error (g, \"%%s\", rv.err.error);\n";
1905       pr "    return %s;\n" error_code;
1906       pr "  }\n";
1907       pr "\n";
1908
1909       (match fst style with
1910        | RErr -> pr "  return 0;\n"
1911        | RInt n
1912        | RBool n -> pr "  return rv.ret.%s;\n" n
1913        | RConstString _ ->
1914            failwithf "RConstString cannot be returned from a daemon function"
1915        | RString n ->
1916            pr "  return rv.ret.%s; /* caller will free */\n" n
1917        | RStringList n | RHashtable n ->
1918            pr "  /* caller will free this, but we need to add a NULL entry */\n";
1919            pr "  rv.ret.%s.%s_val =" n n;
1920            pr "    safe_realloc (g, rv.ret.%s.%s_val,\n" n n;
1921            pr "                  sizeof (char *) * (rv.ret.%s.%s_len + 1));\n"
1922              n n;
1923            pr "  rv.ret.%s.%s_val[rv.ret.%s.%s_len] = NULL;\n" n n n n;
1924            pr "  return rv.ret.%s.%s_val;\n" n n
1925        | RIntBool _ ->
1926            pr "  /* caller with free this */\n";
1927            pr "  return safe_memdup (g, &rv.ret, sizeof (rv.ret));\n"
1928        | RPVList n | RVGList n | RLVList n
1929        | RStat n | RStatVFS n ->
1930            pr "  /* caller will free this */\n";
1931            pr "  return safe_memdup (g, &rv.ret.%s, sizeof (rv.ret.%s));\n" n n
1932       );
1933
1934       pr "}\n\n"
1935   ) daemon_functions
1936
1937 (* Generate daemon/actions.h. *)
1938 and generate_daemon_actions_h () =
1939   generate_header CStyle GPLv2;
1940
1941   pr "#include \"../src/guestfs_protocol.h\"\n";
1942   pr "\n";
1943
1944   List.iter (
1945     fun (name, style, _, _, _, _, _) ->
1946         generate_prototype
1947           ~single_line:true ~newline:true ~in_daemon:true ~prefix:"do_"
1948           name style;
1949   ) daemon_functions
1950
1951 (* Generate the server-side stubs. *)
1952 and generate_daemon_actions () =
1953   generate_header CStyle GPLv2;
1954
1955   pr "#define _GNU_SOURCE // for strchrnul\n";
1956   pr "\n";
1957   pr "#include <stdio.h>\n";
1958   pr "#include <stdlib.h>\n";
1959   pr "#include <string.h>\n";
1960   pr "#include <inttypes.h>\n";
1961   pr "#include <ctype.h>\n";
1962   pr "#include <rpc/types.h>\n";
1963   pr "#include <rpc/xdr.h>\n";
1964   pr "\n";
1965   pr "#include \"daemon.h\"\n";
1966   pr "#include \"../src/guestfs_protocol.h\"\n";
1967   pr "#include \"actions.h\"\n";
1968   pr "\n";
1969
1970   List.iter (
1971     fun (name, style, _, _, _, _, _) ->
1972       (* Generate server-side stubs. *)
1973       pr "static void %s_stub (XDR *xdr_in)\n" name;
1974       pr "{\n";
1975       let error_code =
1976         match fst style with
1977         | RErr | RInt _ -> pr "  int r;\n"; "-1"
1978         | RBool _ -> pr "  int r;\n"; "-1"
1979         | RConstString _ ->
1980             failwithf "RConstString cannot be returned from a daemon function"
1981         | RString _ -> pr "  char *r;\n"; "NULL"
1982         | RStringList _ | RHashtable _ -> pr "  char **r;\n"; "NULL"
1983         | RIntBool _ -> pr "  guestfs_%s_ret *r;\n" name; "NULL"
1984         | RPVList _ -> pr "  guestfs_lvm_int_pv_list *r;\n"; "NULL"
1985         | RVGList _ -> pr "  guestfs_lvm_int_vg_list *r;\n"; "NULL"
1986         | RLVList _ -> pr "  guestfs_lvm_int_lv_list *r;\n"; "NULL"
1987         | RStat _ -> pr "  guestfs_int_stat *r;\n"; "NULL"
1988         | RStatVFS _ -> pr "  guestfs_int_statvfs *r;\n"; "NULL" in
1989
1990       (match snd style with
1991        | [] -> ()
1992        | args ->
1993            pr "  struct guestfs_%s_args args;\n" name;
1994            List.iter (
1995              function
1996              | String n
1997              | OptString n -> pr "  const char *%s;\n" n
1998              | StringList n -> pr "  char **%s;\n" n
1999              | Bool n -> pr "  int %s;\n" n
2000              | Int n -> pr "  int %s;\n" n
2001            ) args
2002       );
2003       pr "\n";
2004
2005       (match snd style with
2006        | [] -> ()
2007        | args ->
2008            pr "  memset (&args, 0, sizeof args);\n";
2009            pr "\n";
2010            pr "  if (!xdr_guestfs_%s_args (xdr_in, &args)) {\n" name;
2011            pr "    reply_with_error (\"%%s: daemon failed to decode procedure arguments\", \"%s\");\n" name;
2012            pr "    return;\n";
2013            pr "  }\n";
2014            List.iter (
2015              function
2016              | String n -> pr "  %s = args.%s;\n" n n
2017              | OptString n -> pr "  %s = args.%s ? *args.%s : NULL;\n" n n n
2018              | StringList n ->
2019                  pr "  args.%s.%s_val = realloc (args.%s.%s_val, sizeof (char *) * (args.%s.%s_len+1));\n" n n n n n n;
2020                  pr "  args.%s.%s_val[args.%s.%s_len] = NULL;\n" n n n n;
2021                  pr "  %s = args.%s.%s_val;\n" n n n
2022              | Bool n -> pr "  %s = args.%s;\n" n n
2023              | Int n -> pr "  %s = args.%s;\n" n n
2024            ) args;
2025            pr "\n"
2026       );
2027
2028       pr "  r = do_%s " name;
2029       generate_call_args style;
2030       pr ";\n";
2031
2032       pr "  if (r == %s)\n" error_code;
2033       pr "    /* do_%s has already called reply_with_error */\n" name;
2034       pr "    goto done;\n";
2035       pr "\n";
2036
2037       (match fst style with
2038        | RErr -> pr "  reply (NULL, NULL);\n"
2039        | RInt n ->
2040            pr "  struct guestfs_%s_ret ret;\n" name;
2041            pr "  ret.%s = r;\n" n;
2042            pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name
2043        | RBool n ->
2044            pr "  struct guestfs_%s_ret ret;\n" name;
2045            pr "  ret.%s = r;\n" n;
2046            pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name
2047        | RConstString _ ->
2048            failwithf "RConstString cannot be returned from a daemon function"
2049        | RString n ->
2050            pr "  struct guestfs_%s_ret ret;\n" name;
2051            pr "  ret.%s = r;\n" n;
2052            pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name;
2053            pr "  free (r);\n"
2054        | RStringList n | RHashtable n ->
2055            pr "  struct guestfs_%s_ret ret;\n" name;
2056            pr "  ret.%s.%s_len = count_strings (r);\n" n n;
2057            pr "  ret.%s.%s_val = r;\n" n n;
2058            pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name;
2059            pr "  free_strings (r);\n"
2060        | RIntBool _ ->
2061            pr "  reply ((xdrproc_t) xdr_guestfs_%s_ret, (char *) r);\n" name;
2062            pr "  xdr_free ((xdrproc_t) xdr_guestfs_%s_ret, (char *) r);\n" name
2063        | RPVList n | RVGList n | RLVList n
2064        | RStat n | RStatVFS n ->
2065            pr "  struct guestfs_%s_ret ret;\n" name;
2066            pr "  ret.%s = *r;\n" n;
2067            pr "  reply ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n" name;
2068            pr "  xdr_free ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n" name
2069       );
2070
2071       (* Free the args. *)
2072       (match snd style with
2073        | [] ->
2074            pr "done: ;\n";
2075        | _ ->
2076            pr "done:\n";
2077            pr "  xdr_free ((xdrproc_t) xdr_guestfs_%s_args, (char *) &args);\n"
2078              name
2079       );
2080
2081       pr "}\n\n";
2082   ) daemon_functions;
2083
2084   (* Dispatch function. *)
2085   pr "void dispatch_incoming_message (XDR *xdr_in)\n";
2086   pr "{\n";
2087   pr "  switch (proc_nr) {\n";
2088
2089   List.iter (
2090     fun (name, style, _, _, _, _, _) ->
2091         pr "    case GUESTFS_PROC_%s:\n" (String.uppercase name);
2092         pr "      %s_stub (xdr_in);\n" name;
2093         pr "      break;\n"
2094   ) daemon_functions;
2095
2096   pr "    default:\n";
2097   pr "      reply_with_error (\"dispatch_incoming_message: unknown procedure number %%d\", proc_nr);\n";
2098   pr "  }\n";
2099   pr "}\n";
2100   pr "\n";
2101
2102   (* LVM columns and tokenization functions. *)
2103   (* XXX This generates crap code.  We should rethink how we
2104    * do this parsing.
2105    *)
2106   List.iter (
2107     function
2108     | typ, cols ->
2109         pr "static const char *lvm_%s_cols = \"%s\";\n"
2110           typ (String.concat "," (List.map fst cols));
2111         pr "\n";
2112
2113         pr "static int lvm_tokenize_%s (char *str, struct guestfs_lvm_int_%s *r)\n" typ typ;
2114         pr "{\n";
2115         pr "  char *tok, *p, *next;\n";
2116         pr "  int i, j;\n";
2117         pr "\n";
2118         (*
2119         pr "  fprintf (stderr, \"%%s: <<%%s>>\\n\", __func__, str);\n";
2120         pr "\n";
2121         *)
2122         pr "  if (!str) {\n";
2123         pr "    fprintf (stderr, \"%%s: failed: passed a NULL string\\n\", __func__);\n";
2124         pr "    return -1;\n";
2125         pr "  }\n";
2126         pr "  if (!*str || isspace (*str)) {\n";
2127         pr "    fprintf (stderr, \"%%s: failed: passed a empty string or one beginning with whitespace\\n\", __func__);\n";
2128         pr "    return -1;\n";
2129         pr "  }\n";
2130         pr "  tok = str;\n";
2131         List.iter (
2132           fun (name, coltype) ->
2133             pr "  if (!tok) {\n";
2134             pr "    fprintf (stderr, \"%%s: failed: string finished early, around token %%s\\n\", __func__, \"%s\");\n" name;
2135             pr "    return -1;\n";
2136             pr "  }\n";
2137             pr "  p = strchrnul (tok, ',');\n";
2138             pr "  if (*p) next = p+1; else next = NULL;\n";
2139             pr "  *p = '\\0';\n";
2140             (match coltype with
2141              | `String ->
2142                  pr "  r->%s = strdup (tok);\n" name;
2143                  pr "  if (r->%s == NULL) {\n" name;
2144                  pr "    perror (\"strdup\");\n";
2145                  pr "    return -1;\n";
2146                  pr "  }\n"
2147              | `UUID ->
2148                  pr "  for (i = j = 0; i < 32; ++j) {\n";
2149                  pr "    if (tok[j] == '\\0') {\n";
2150                  pr "      fprintf (stderr, \"%%s: failed to parse UUID from '%%s'\\n\", __func__, tok);\n";
2151                  pr "      return -1;\n";
2152                  pr "    } else if (tok[j] != '-')\n";
2153                  pr "      r->%s[i++] = tok[j];\n" name;
2154                  pr "  }\n";
2155              | `Bytes ->
2156                  pr "  if (sscanf (tok, \"%%\"SCNu64, &r->%s) != 1) {\n" name;
2157                  pr "    fprintf (stderr, \"%%s: failed to parse size '%%s' from token %%s\\n\", __func__, tok, \"%s\");\n" name;
2158                  pr "    return -1;\n";
2159                  pr "  }\n";
2160              | `Int ->
2161                  pr "  if (sscanf (tok, \"%%\"SCNi64, &r->%s) != 1) {\n" name;
2162                  pr "    fprintf (stderr, \"%%s: failed to parse int '%%s' from token %%s\\n\", __func__, tok, \"%s\");\n" name;
2163                  pr "    return -1;\n";
2164                  pr "  }\n";
2165              | `OptPercent ->
2166                  pr "  if (tok[0] == '\\0')\n";
2167                  pr "    r->%s = -1;\n" name;
2168                  pr "  else if (sscanf (tok, \"%%f\", &r->%s) != 1) {\n" name;
2169                  pr "    fprintf (stderr, \"%%s: failed to parse float '%%s' from token %%s\\n\", __func__, tok, \"%s\");\n" name;
2170                  pr "    return -1;\n";
2171                  pr "  }\n";
2172             );
2173             pr "  tok = next;\n";
2174         ) cols;
2175
2176         pr "  if (tok != NULL) {\n";
2177         pr "    fprintf (stderr, \"%%s: failed: extra tokens at end of string\\n\", __func__);\n";
2178         pr "    return -1;\n";
2179         pr "  }\n";
2180         pr "  return 0;\n";
2181         pr "}\n";
2182         pr "\n";
2183
2184         pr "guestfs_lvm_int_%s_list *\n" typ;
2185         pr "parse_command_line_%ss (void)\n" typ;
2186         pr "{\n";
2187         pr "  char *out, *err;\n";
2188         pr "  char *p, *pend;\n";
2189         pr "  int r, i;\n";
2190         pr "  guestfs_lvm_int_%s_list *ret;\n" typ;
2191         pr "  void *newp;\n";
2192         pr "\n";
2193         pr "  ret = malloc (sizeof *ret);\n";
2194         pr "  if (!ret) {\n";
2195         pr "    reply_with_perror (\"malloc\");\n";
2196         pr "    return NULL;\n";
2197         pr "  }\n";
2198         pr "\n";
2199         pr "  ret->guestfs_lvm_int_%s_list_len = 0;\n" typ;
2200         pr "  ret->guestfs_lvm_int_%s_list_val = NULL;\n" typ;
2201         pr "\n";
2202         pr "  r = command (&out, &err,\n";
2203         pr "           \"/sbin/lvm\", \"%ss\",\n" typ;
2204         pr "           \"-o\", lvm_%s_cols, \"--unbuffered\", \"--noheadings\",\n" typ;
2205         pr "           \"--nosuffix\", \"--separator\", \",\", \"--units\", \"b\", NULL);\n";
2206         pr "  if (r == -1) {\n";
2207         pr "    reply_with_error (\"%%s\", err);\n";
2208         pr "    free (out);\n";
2209         pr "    free (err);\n";
2210         pr "    return NULL;\n";
2211         pr "  }\n";
2212         pr "\n";
2213         pr "  free (err);\n";
2214         pr "\n";
2215         pr "  /* Tokenize each line of the output. */\n";
2216         pr "  p = out;\n";
2217         pr "  i = 0;\n";
2218         pr "  while (p) {\n";
2219         pr "    pend = strchr (p, '\\n');       /* Get the next line of output. */\n";
2220         pr "    if (pend) {\n";
2221         pr "      *pend = '\\0';\n";
2222         pr "      pend++;\n";
2223         pr "    }\n";
2224         pr "\n";
2225         pr "    while (*p && isspace (*p))      /* Skip any leading whitespace. */\n";
2226         pr "      p++;\n";
2227         pr "\n";
2228         pr "    if (!*p) {                      /* Empty line?  Skip it. */\n";
2229         pr "      p = pend;\n";
2230         pr "      continue;\n";
2231         pr "    }\n";
2232         pr "\n";
2233         pr "    /* Allocate some space to store this next entry. */\n";
2234         pr "    newp = realloc (ret->guestfs_lvm_int_%s_list_val,\n" typ;
2235         pr "                sizeof (guestfs_lvm_int_%s) * (i+1));\n" typ;
2236         pr "    if (newp == NULL) {\n";
2237         pr "      reply_with_perror (\"realloc\");\n";
2238         pr "      free (ret->guestfs_lvm_int_%s_list_val);\n" typ;
2239         pr "      free (ret);\n";
2240         pr "      free (out);\n";
2241         pr "      return NULL;\n";
2242         pr "    }\n";
2243         pr "    ret->guestfs_lvm_int_%s_list_val = newp;\n" typ;
2244         pr "\n";
2245         pr "    /* Tokenize the next entry. */\n";
2246         pr "    r = lvm_tokenize_%s (p, &ret->guestfs_lvm_int_%s_list_val[i]);\n" typ typ;
2247         pr "    if (r == -1) {\n";
2248         pr "      reply_with_error (\"failed to parse output of '%ss' command\");\n" typ;
2249         pr "      free (ret->guestfs_lvm_int_%s_list_val);\n" typ;
2250         pr "      free (ret);\n";
2251         pr "      free (out);\n";
2252         pr "      return NULL;\n";
2253         pr "    }\n";
2254         pr "\n";
2255         pr "    ++i;\n";
2256         pr "    p = pend;\n";
2257         pr "  }\n";
2258         pr "\n";
2259         pr "  ret->guestfs_lvm_int_%s_list_len = i;\n" typ;
2260         pr "\n";
2261         pr "  free (out);\n";
2262         pr "  return ret;\n";
2263         pr "}\n"
2264
2265   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols]
2266
2267 (* Generate the tests. *)
2268 and generate_tests () =
2269   generate_header CStyle GPLv2;
2270
2271   pr "\
2272 #include <stdio.h>
2273 #include <stdlib.h>
2274 #include <string.h>
2275 #include <unistd.h>
2276 #include <sys/types.h>
2277 #include <fcntl.h>
2278
2279 #include \"guestfs.h\"
2280
2281 static guestfs_h *g;
2282 static int suppress_error = 0;
2283
2284 static void print_error (guestfs_h *g, void *data, const char *msg)
2285 {
2286   if (!suppress_error)
2287     fprintf (stderr, \"%%s\\n\", msg);
2288 }
2289
2290 static void print_strings (char * const * const argv)
2291 {
2292   int argc;
2293
2294   for (argc = 0; argv[argc] != NULL; ++argc)
2295     printf (\"\\t%%s\\n\", argv[argc]);
2296 }
2297
2298 static void print_table (char * const * const argv)
2299 {
2300   int i;
2301
2302   for (i = 0; argv[i] != NULL; i += 2)
2303     printf (\"%%s: %%s\\n\", argv[i], argv[i+1]);
2304 }
2305
2306 ";
2307
2308   let test_names =
2309     List.map (
2310       fun (name, _, _, _, tests, _, _) ->
2311         mapi (generate_one_test name) tests
2312     ) all_functions in
2313   let test_names = List.concat test_names in
2314   let nr_tests = List.length test_names in
2315
2316   pr "\
2317 int main (int argc, char *argv[])
2318 {
2319   char c = 0;
2320   int failed = 0;
2321   const char *srcdir;
2322   int fd;
2323   char buf[256];
2324   int nr_tests;
2325
2326   g = guestfs_create ();
2327   if (g == NULL) {
2328     printf (\"guestfs_create FAILED\\n\");
2329     exit (1);
2330   }
2331
2332   guestfs_set_error_handler (g, print_error, NULL);
2333
2334   srcdir = getenv (\"srcdir\");
2335   if (!srcdir) srcdir = \".\";
2336   guestfs_set_path (g, srcdir);
2337
2338   snprintf (buf, sizeof buf, \"%%s/test1.img\", srcdir);
2339   fd = open (buf, O_WRONLY|O_CREAT|O_NOCTTY|O_NONBLOCK|O_TRUNC, 0666);
2340   if (fd == -1) {
2341     perror (buf);
2342     exit (1);
2343   }
2344   if (lseek (fd, %d, SEEK_SET) == -1) {
2345     perror (\"lseek\");
2346     close (fd);
2347     unlink (buf);
2348     exit (1);
2349   }
2350   if (write (fd, &c, 1) == -1) {
2351     perror (\"write\");
2352     close (fd);
2353     unlink (buf);
2354     exit (1);
2355   }
2356   if (close (fd) == -1) {
2357     perror (buf);
2358     unlink (buf);
2359     exit (1);
2360   }
2361   if (guestfs_add_drive (g, buf) == -1) {
2362     printf (\"guestfs_add_drive %%s FAILED\\n\", buf);
2363     exit (1);
2364   }
2365
2366   snprintf (buf, sizeof buf, \"%%s/test2.img\", srcdir);
2367   fd = open (buf, O_WRONLY|O_CREAT|O_NOCTTY|O_NONBLOCK|O_TRUNC, 0666);
2368   if (fd == -1) {
2369     perror (buf);
2370     exit (1);
2371   }
2372   if (lseek (fd, %d, SEEK_SET) == -1) {
2373     perror (\"lseek\");
2374     close (fd);
2375     unlink (buf);
2376     exit (1);
2377   }
2378   if (write (fd, &c, 1) == -1) {
2379     perror (\"write\");
2380     close (fd);
2381     unlink (buf);
2382     exit (1);
2383   }
2384   if (close (fd) == -1) {
2385     perror (buf);
2386     unlink (buf);
2387     exit (1);
2388   }
2389   if (guestfs_add_drive (g, buf) == -1) {
2390     printf (\"guestfs_add_drive %%s FAILED\\n\", buf);
2391     exit (1);
2392   }
2393
2394   snprintf (buf, sizeof buf, \"%%s/test3.img\", srcdir);
2395   fd = open (buf, O_WRONLY|O_CREAT|O_NOCTTY|O_NONBLOCK|O_TRUNC, 0666);
2396   if (fd == -1) {
2397     perror (buf);
2398     exit (1);
2399   }
2400   if (lseek (fd, %d, SEEK_SET) == -1) {
2401     perror (\"lseek\");
2402     close (fd);
2403     unlink (buf);
2404     exit (1);
2405   }
2406   if (write (fd, &c, 1) == -1) {
2407     perror (\"write\");
2408     close (fd);
2409     unlink (buf);
2410     exit (1);
2411   }
2412   if (close (fd) == -1) {
2413     perror (buf);
2414     unlink (buf);
2415     exit (1);
2416   }
2417   if (guestfs_add_drive (g, buf) == -1) {
2418     printf (\"guestfs_add_drive %%s FAILED\\n\", buf);
2419     exit (1);
2420   }
2421
2422   if (guestfs_launch (g) == -1) {
2423     printf (\"guestfs_launch FAILED\\n\");
2424     exit (1);
2425   }
2426   if (guestfs_wait_ready (g) == -1) {
2427     printf (\"guestfs_wait_ready FAILED\\n\");
2428     exit (1);
2429   }
2430
2431   nr_tests = %d;
2432 " (500 * 1024 * 1024) (50 * 1024 * 1024) (10 * 1024 * 1024) nr_tests;
2433
2434   iteri (
2435     fun i test_name ->
2436       pr "  printf (\"%3d/%%3d %s\\n\", nr_tests);\n" (i+1) test_name;
2437       pr "  if (%s () == -1) {\n" test_name;
2438       pr "    printf (\"%s FAILED\\n\");\n" test_name;
2439       pr "    failed++;\n";
2440       pr "  }\n";
2441   ) test_names;
2442   pr "\n";
2443
2444   pr "  guestfs_close (g);\n";
2445   pr "  snprintf (buf, sizeof buf, \"%%s/test1.img\", srcdir);\n";
2446   pr "  unlink (buf);\n";
2447   pr "  snprintf (buf, sizeof buf, \"%%s/test2.img\", srcdir);\n";
2448   pr "  unlink (buf);\n";
2449   pr "  snprintf (buf, sizeof buf, \"%%s/test3.img\", srcdir);\n";
2450   pr "  unlink (buf);\n";
2451   pr "\n";
2452
2453   pr "  if (failed > 0) {\n";
2454   pr "    printf (\"***** %%d / %%d tests FAILED *****\\n\", failed, nr_tests);\n";
2455   pr "    exit (1);\n";
2456   pr "  }\n";
2457   pr "\n";
2458
2459   pr "  exit (0);\n";
2460   pr "}\n"
2461
2462 and generate_one_test name i (init, test) =
2463   let test_name = sprintf "test_%s_%d" name i in
2464
2465   pr "static int %s (void)\n" test_name;
2466   pr "{\n";
2467
2468   (match init with
2469    | InitNone -> ()
2470    | InitEmpty ->
2471        pr "  /* InitEmpty for %s (%d) */\n" name i;
2472        List.iter (generate_test_command_call test_name)
2473          [["umount_all"];
2474           ["lvm_remove_all"]]
2475    | InitBasicFS ->
2476        pr "  /* InitBasicFS for %s (%d): create ext2 on /dev/sda1 */\n" name i;
2477        List.iter (generate_test_command_call test_name)
2478          [["umount_all"];
2479           ["lvm_remove_all"];
2480           ["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ","];
2481           ["mkfs"; "ext2"; "/dev/sda1"];
2482           ["mount"; "/dev/sda1"; "/"]]
2483    | InitBasicFSonLVM ->
2484        pr "  /* InitBasicFSonLVM for %s (%d): create ext2 on /dev/VG/LV */\n"
2485          name i;
2486        List.iter (generate_test_command_call test_name)
2487          [["umount_all"];
2488           ["lvm_remove_all"];
2489           ["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ","];
2490           ["pvcreate"; "/dev/sda1"];
2491           ["vgcreate"; "VG"; "/dev/sda1"];
2492           ["lvcreate"; "LV"; "VG"; "8"];
2493           ["mkfs"; "ext2"; "/dev/VG/LV"];
2494           ["mount"; "/dev/VG/LV"; "/"]]
2495   );
2496
2497   let get_seq_last = function
2498     | [] ->
2499         failwithf "%s: you cannot use [] (empty list) when expecting a command"
2500           test_name
2501     | seq ->
2502         let seq = List.rev seq in
2503         List.rev (List.tl seq), List.hd seq
2504   in
2505
2506   (match test with
2507    | TestRun seq ->
2508        pr "  /* TestRun for %s (%d) */\n" name i;
2509        List.iter (generate_test_command_call test_name) seq
2510    | TestOutput (seq, expected) ->
2511        pr "  /* TestOutput for %s (%d) */\n" name i;
2512        let seq, last = get_seq_last seq in
2513        let test () =
2514          pr "    if (strcmp (r, \"%s\") != 0) {\n" (c_quote expected);
2515          pr "      fprintf (stderr, \"%s: expected \\\"%s\\\" but got \\\"%%s\\\"\\n\", r);\n" test_name (c_quote expected);
2516          pr "      return -1;\n";
2517          pr "    }\n"
2518        in
2519        List.iter (generate_test_command_call test_name) seq;
2520        generate_test_command_call ~test test_name last
2521    | TestOutputList (seq, expected) ->
2522        pr "  /* TestOutputList for %s (%d) */\n" name i;
2523        let seq, last = get_seq_last seq in
2524        let test () =
2525          iteri (
2526            fun i str ->
2527              pr "    if (!r[%d]) {\n" i;
2528              pr "      fprintf (stderr, \"%s: short list returned from command\\n\");\n" test_name;
2529              pr "      print_strings (r);\n";
2530              pr "      return -1;\n";
2531              pr "    }\n";
2532              pr "    if (strcmp (r[%d], \"%s\") != 0) {\n" i (c_quote str);
2533              pr "      fprintf (stderr, \"%s: expected \\\"%s\\\" but got \\\"%%s\\\"\\n\", r[%d]);\n" test_name (c_quote str) i;
2534              pr "      return -1;\n";
2535              pr "    }\n"
2536          ) expected;
2537          pr "    if (r[%d] != NULL) {\n" (List.length expected);
2538          pr "      fprintf (stderr, \"%s: extra elements returned from command\\n\");\n"
2539            test_name;
2540          pr "      print_strings (r);\n";
2541          pr "      return -1;\n";
2542          pr "    }\n"
2543        in
2544        List.iter (generate_test_command_call test_name) seq;
2545        generate_test_command_call ~test test_name last
2546    | TestOutputInt (seq, expected) ->
2547        pr "  /* TestOutputInt for %s (%d) */\n" name i;
2548        let seq, last = get_seq_last seq in
2549        let test () =
2550          pr "    if (r != %d) {\n" expected;
2551          pr "      fprintf (stderr, \"%s: expected %d but got %%d\\n\", r);\n"
2552            test_name expected;
2553          pr "      return -1;\n";
2554          pr "    }\n"
2555        in
2556        List.iter (generate_test_command_call test_name) seq;
2557        generate_test_command_call ~test test_name last
2558    | TestOutputTrue seq ->
2559        pr "  /* TestOutputTrue for %s (%d) */\n" name i;
2560        let seq, last = get_seq_last seq in
2561        let test () =
2562          pr "    if (!r) {\n";
2563          pr "      fprintf (stderr, \"%s: expected true, got false\\n\");\n"
2564            test_name;
2565          pr "      return -1;\n";
2566          pr "    }\n"
2567        in
2568        List.iter (generate_test_command_call test_name) seq;
2569        generate_test_command_call ~test test_name last
2570    | TestOutputFalse seq ->
2571        pr "  /* TestOutputFalse for %s (%d) */\n" name i;
2572        let seq, last = get_seq_last seq in
2573        let test () =
2574          pr "    if (r) {\n";
2575          pr "      fprintf (stderr, \"%s: expected false, got true\\n\");\n"
2576            test_name;
2577          pr "      return -1;\n";
2578          pr "    }\n"
2579        in
2580        List.iter (generate_test_command_call test_name) seq;
2581        generate_test_command_call ~test test_name last
2582    | TestOutputLength (seq, expected) ->
2583        pr "  /* TestOutputLength for %s (%d) */\n" name i;
2584        let seq, last = get_seq_last seq in
2585        let test () =
2586          pr "    int j;\n";
2587          pr "    for (j = 0; j < %d; ++j)\n" expected;
2588          pr "      if (r[j] == NULL) {\n";
2589          pr "        fprintf (stderr, \"%s: short list returned\\n\");\n"
2590            test_name;
2591          pr "        print_strings (r);\n";
2592          pr "        return -1;\n";
2593          pr "      }\n";
2594          pr "    if (r[j] != NULL) {\n";
2595          pr "      fprintf (stderr, \"%s: long list returned\\n\");\n"
2596            test_name;
2597          pr "      print_strings (r);\n";
2598          pr "      return -1;\n";
2599          pr "    }\n"
2600        in
2601        List.iter (generate_test_command_call test_name) seq;
2602        generate_test_command_call ~test test_name last
2603    | TestOutputStruct (seq, checks) ->
2604        pr "  /* TestOutputStruct for %s (%d) */\n" name i;
2605        let seq, last = get_seq_last seq in
2606        let test () =
2607          List.iter (
2608            function
2609            | CompareWithInt (field, expected) ->
2610                pr "    if (r->%s != %d) {\n" field expected;
2611                pr "      fprintf (stderr, \"%s: %s was %%d, expected %d\\n\",\n"
2612                  test_name field expected;
2613                pr "               (int) r->%s);\n" field;
2614                pr "      return -1;\n";
2615                pr "    }\n"
2616            | CompareWithString (field, expected) ->
2617                pr "    if (strcmp (r->%s, \"%s\") != 0) {\n" field expected;
2618                pr "      fprintf (stderr, \"%s: %s was \"%%s\", expected \"%s\"\\n\",\n"
2619                  test_name field expected;
2620                pr "               r->%s);\n" field;
2621                pr "      return -1;\n";
2622                pr "    }\n"
2623            | CompareFieldsIntEq (field1, field2) ->
2624                pr "    if (r->%s != r->%s) {\n" field1 field2;
2625                pr "      fprintf (stderr, \"%s: %s (%%d) <> %s (%%d)\\n\",\n"
2626                  test_name field1 field2;
2627                pr "               (int) r->%s, (int) r->%s);\n" field1 field2;
2628                pr "      return -1;\n";
2629                pr "    }\n"
2630            | CompareFieldsStrEq (field1, field2) ->
2631                pr "    if (strcmp (r->%s, r->%s) != 0) {\n" field1 field2;
2632                pr "      fprintf (stderr, \"%s: %s (\"%%s\") <> %s (\"%%s\")\\n\",\n"
2633                  test_name field1 field2;
2634                pr "               r->%s, r->%s);\n" field1 field2;
2635                pr "      return -1;\n";
2636                pr "    }\n"
2637          ) checks
2638        in
2639        List.iter (generate_test_command_call test_name) seq;
2640        generate_test_command_call ~test test_name last
2641    | TestLastFail seq ->
2642        pr "  /* TestLastFail for %s (%d) */\n" name i;
2643        let seq, last = get_seq_last seq in
2644        List.iter (generate_test_command_call test_name) seq;
2645        generate_test_command_call test_name ~expect_error:true last
2646   );
2647
2648   pr "  return 0;\n";
2649   pr "}\n";
2650   pr "\n";
2651   test_name
2652
2653 (* Generate the code to run a command, leaving the result in 'r'.
2654  * If you expect to get an error then you should set expect_error:true.
2655  *)
2656 and generate_test_command_call ?(expect_error = false) ?test test_name cmd =
2657   match cmd with
2658   | [] -> assert false
2659   | name :: args ->
2660       (* Look up the command to find out what args/ret it has. *)
2661       let style =
2662         try
2663           let _, style, _, _, _, _, _ =
2664             List.find (fun (n, _, _, _, _, _, _) -> n = name) all_functions in
2665           style
2666         with Not_found ->
2667           failwithf "%s: in test, command %s was not found" test_name name in
2668
2669       if List.length (snd style) <> List.length args then
2670         failwithf "%s: in test, wrong number of args given to %s"
2671           test_name name;
2672
2673       pr "  {\n";
2674
2675       List.iter (
2676         function
2677         | String _, _
2678         | OptString _, _
2679         | Int _, _
2680         | Bool _, _ -> ()
2681         | StringList n, arg ->
2682             pr "    char *%s[] = {\n" n;
2683             let strs = string_split " " arg in
2684             List.iter (
2685               fun str -> pr "      \"%s\",\n" (c_quote str)
2686             ) strs;
2687             pr "      NULL\n";
2688             pr "    };\n";
2689       ) (List.combine (snd style) args);
2690
2691       let error_code =
2692         match fst style with
2693         | RErr | RInt _ | RBool _ -> pr "    int r;\n"; "-1"
2694         | RConstString _ -> pr "    const char *r;\n"; "NULL"
2695         | RString _ -> pr "    char *r;\n"; "NULL"
2696         | RStringList _ | RHashtable _ ->
2697             pr "    char **r;\n";
2698             pr "    int i;\n";
2699             "NULL"
2700         | RIntBool _ ->
2701             pr "    struct guestfs_int_bool *r;\n"; "NULL"
2702         | RPVList _ ->
2703             pr "    struct guestfs_lvm_pv_list *r;\n"; "NULL"
2704         | RVGList _ ->
2705             pr "    struct guestfs_lvm_vg_list *r;\n"; "NULL"
2706         | RLVList _ ->
2707             pr "    struct guestfs_lvm_lv_list *r;\n"; "NULL"
2708         | RStat _ ->
2709             pr "    struct guestfs_stat *r;\n"; "NULL"
2710         | RStatVFS _ ->
2711             pr "    struct guestfs_statvfs *r;\n"; "NULL" in
2712
2713       pr "    suppress_error = %d;\n" (if expect_error then 1 else 0);
2714       pr "    r = guestfs_%s (g" name;
2715
2716       (* Generate the parameters. *)
2717       List.iter (
2718         function
2719         | String _, arg -> pr ", \"%s\"" (c_quote arg)
2720         | OptString _, arg ->
2721             if arg = "NULL" then pr ", NULL" else pr ", \"%s\"" (c_quote arg)
2722         | StringList n, _ ->
2723             pr ", %s" n
2724         | Int _, arg ->
2725             let i =
2726               try int_of_string arg
2727               with Failure "int_of_string" ->
2728                 failwithf "%s: expecting an int, but got '%s'" test_name arg in
2729             pr ", %d" i
2730         | Bool _, arg ->
2731             let b = bool_of_string arg in pr ", %d" (if b then 1 else 0)
2732       ) (List.combine (snd style) args);
2733
2734       pr ");\n";
2735       if not expect_error then
2736         pr "    if (r == %s)\n" error_code
2737       else
2738         pr "    if (r != %s)\n" error_code;
2739       pr "      return -1;\n";
2740
2741       (* Insert the test code. *)
2742       (match test with
2743        | None -> ()
2744        | Some f -> f ()
2745       );
2746
2747       (match fst style with
2748        | RErr | RInt _ | RBool _ | RConstString _ -> ()
2749        | RString _ -> pr "    free (r);\n"
2750        | RStringList _ | RHashtable _ ->
2751            pr "    for (i = 0; r[i] != NULL; ++i)\n";
2752            pr "      free (r[i]);\n";
2753            pr "    free (r);\n"
2754        | RIntBool _ ->
2755            pr "    guestfs_free_int_bool (r);\n"
2756        | RPVList _ ->
2757            pr "    guestfs_free_lvm_pv_list (r);\n"
2758        | RVGList _ ->
2759            pr "    guestfs_free_lvm_vg_list (r);\n"
2760        | RLVList _ ->
2761            pr "    guestfs_free_lvm_lv_list (r);\n"
2762        | RStat _ | RStatVFS _ ->
2763            pr "    free (r);\n"
2764       );
2765
2766       pr "  }\n"
2767
2768 and c_quote str =
2769   let str = replace_str str "\r" "\\r" in
2770   let str = replace_str str "\n" "\\n" in
2771   let str = replace_str str "\t" "\\t" in
2772   str
2773
2774 (* Generate a lot of different functions for guestfish. *)
2775 and generate_fish_cmds () =
2776   generate_header CStyle GPLv2;
2777
2778   let all_functions =
2779     List.filter (
2780       fun (_, _, _, flags, _, _, _) -> not (List.mem NotInFish flags)
2781     ) all_functions in
2782   let all_functions_sorted =
2783     List.filter (
2784       fun (_, _, _, flags, _, _, _) -> not (List.mem NotInFish flags)
2785     ) all_functions_sorted in
2786
2787   pr "#include <stdio.h>\n";
2788   pr "#include <stdlib.h>\n";
2789   pr "#include <string.h>\n";
2790   pr "#include <inttypes.h>\n";
2791   pr "\n";
2792   pr "#include <guestfs.h>\n";
2793   pr "#include \"fish.h\"\n";
2794   pr "\n";
2795
2796   (* list_commands function, which implements guestfish -h *)
2797   pr "void list_commands (void)\n";
2798   pr "{\n";
2799   pr "  printf (\"    %%-16s     %%s\\n\", \"Command\", \"Description\");\n";
2800   pr "  list_builtin_commands ();\n";
2801   List.iter (
2802     fun (name, _, _, flags, _, shortdesc, _) ->
2803       let name = replace_char name '_' '-' in
2804       pr "  printf (\"%%-20s %%s\\n\", \"%s\", \"%s\");\n"
2805         name shortdesc
2806   ) all_functions_sorted;
2807   pr "  printf (\"    Use -h <cmd> / help <cmd> to show detailed help for a command.\\n\");\n";
2808   pr "}\n";
2809   pr "\n";
2810
2811   (* display_command function, which implements guestfish -h cmd *)
2812   pr "void display_command (const char *cmd)\n";
2813   pr "{\n";
2814   List.iter (
2815     fun (name, style, _, flags, _, shortdesc, longdesc) ->
2816       let name2 = replace_char name '_' '-' in
2817       let alias =
2818         try find_map (function FishAlias n -> Some n | _ -> None) flags
2819         with Not_found -> name in
2820       let longdesc = replace_str longdesc "C<guestfs_" "C<" in
2821       let synopsis =
2822         match snd style with
2823         | [] -> name2
2824         | args ->
2825             sprintf "%s <%s>"
2826               name2 (String.concat "> <" (List.map name_of_argt args)) in
2827
2828       let warnings =
2829         if List.mem ProtocolLimitWarning flags then
2830           ("\n\n" ^ protocol_limit_warning)
2831         else "" in
2832
2833       (* For DangerWillRobinson commands, we should probably have
2834        * guestfish prompt before allowing you to use them (especially
2835        * in interactive mode). XXX
2836        *)
2837       let warnings =
2838         warnings ^
2839           if List.mem DangerWillRobinson flags then
2840             ("\n\n" ^ danger_will_robinson)
2841           else "" in
2842
2843       let describe_alias =
2844         if name <> alias then
2845           sprintf "\n\nYou can use '%s' as an alias for this command." alias
2846         else "" in
2847
2848       pr "  if (";
2849       pr "strcasecmp (cmd, \"%s\") == 0" name;
2850       if name <> name2 then
2851         pr " || strcasecmp (cmd, \"%s\") == 0" name2;
2852       if name <> alias then
2853         pr " || strcasecmp (cmd, \"%s\") == 0" alias;
2854       pr ")\n";
2855       pr "    pod2text (\"%s - %s\", %S);\n"
2856         name2 shortdesc
2857         (" " ^ synopsis ^ "\n\n" ^ longdesc ^ warnings ^ describe_alias);
2858       pr "  else\n"
2859   ) all_functions;
2860   pr "    display_builtin_command (cmd);\n";
2861   pr "}\n";
2862   pr "\n";
2863
2864   (* print_{pv,vg,lv}_list functions *)
2865   List.iter (
2866     function
2867     | typ, cols ->
2868         pr "static void print_%s (struct guestfs_lvm_%s *%s)\n" typ typ typ;
2869         pr "{\n";
2870         pr "  int i;\n";
2871         pr "\n";
2872         List.iter (
2873           function
2874           | name, `String ->
2875               pr "  printf (\"%s: %%s\\n\", %s->%s);\n" name typ name
2876           | name, `UUID ->
2877               pr "  printf (\"%s: \");\n" name;
2878               pr "  for (i = 0; i < 32; ++i)\n";
2879               pr "    printf (\"%%c\", %s->%s[i]);\n" typ name;
2880               pr "  printf (\"\\n\");\n"
2881           | name, `Bytes ->
2882               pr "  printf (\"%s: %%\" PRIu64 \"\\n\", %s->%s);\n" name typ name
2883           | name, `Int ->
2884               pr "  printf (\"%s: %%\" PRIi64 \"\\n\", %s->%s);\n" name typ name
2885           | name, `OptPercent ->
2886               pr "  if (%s->%s >= 0) printf (\"%s: %%g %%%%\\n\", %s->%s);\n"
2887                 typ name name typ name;
2888               pr "  else printf (\"%s: \\n\");\n" name
2889         ) cols;
2890         pr "}\n";
2891         pr "\n";
2892         pr "static void print_%s_list (struct guestfs_lvm_%s_list *%ss)\n"
2893           typ typ typ;
2894         pr "{\n";
2895         pr "  int i;\n";
2896         pr "\n";
2897         pr "  for (i = 0; i < %ss->len; ++i)\n" typ;
2898         pr "    print_%s (&%ss->val[i]);\n" typ typ;
2899         pr "}\n";
2900         pr "\n";
2901   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols];
2902
2903   (* print_{stat,statvfs} functions *)
2904   List.iter (
2905     function
2906     | typ, cols ->
2907         pr "static void print_%s (struct guestfs_%s *%s)\n" typ typ typ;
2908         pr "{\n";
2909         List.iter (
2910           function
2911           | name, `Int ->
2912               pr "  printf (\"%s: %%\" PRIi64 \"\\n\", %s->%s);\n" name typ name
2913         ) cols;
2914         pr "}\n";
2915         pr "\n";
2916   ) ["stat", stat_cols; "statvfs", statvfs_cols];
2917
2918   (* run_<action> actions *)
2919   List.iter (
2920     fun (name, style, _, flags, _, _, _) ->
2921       pr "static int run_%s (const char *cmd, int argc, char *argv[])\n" name;
2922       pr "{\n";
2923       (match fst style with
2924        | RErr
2925        | RInt _
2926        | RBool _ -> pr "  int r;\n"
2927        | RConstString _ -> pr "  const char *r;\n"
2928        | RString _ -> pr "  char *r;\n"
2929        | RStringList _ | RHashtable _ -> pr "  char **r;\n"
2930        | RIntBool _ -> pr "  struct guestfs_int_bool *r;\n"
2931        | RPVList _ -> pr "  struct guestfs_lvm_pv_list *r;\n"
2932        | RVGList _ -> pr "  struct guestfs_lvm_vg_list *r;\n"
2933        | RLVList _ -> pr "  struct guestfs_lvm_lv_list *r;\n"
2934        | RStat _ -> pr "  struct guestfs_stat *r;\n"
2935        | RStatVFS _ -> pr "  struct guestfs_statvfs *r;\n"
2936       );
2937       List.iter (
2938         function
2939         | String n
2940         | OptString n -> pr "  const char *%s;\n" n
2941         | StringList n -> pr "  char **%s;\n" n
2942         | Bool n -> pr "  int %s;\n" n
2943         | Int n -> pr "  int %s;\n" n
2944       ) (snd style);
2945
2946       (* Check and convert parameters. *)
2947       let argc_expected = List.length (snd style) in
2948       pr "  if (argc != %d) {\n" argc_expected;
2949       pr "    fprintf (stderr, \"%%s should have %d parameter(s)\\n\", cmd);\n"
2950         argc_expected;
2951       pr "    fprintf (stderr, \"type 'help %%s' for help on %%s\\n\", cmd, cmd);\n";
2952       pr "    return -1;\n";
2953       pr "  }\n";
2954       iteri (
2955         fun i ->
2956           function
2957           | String name -> pr "  %s = argv[%d];\n" name i
2958           | OptString name ->
2959               pr "  %s = strcmp (argv[%d], \"\") != 0 ? argv[%d] : NULL;\n"
2960                 name i i
2961           | StringList name ->
2962               pr "  %s = parse_string_list (argv[%d]);\n" name i
2963           | Bool name ->
2964               pr "  %s = is_true (argv[%d]) ? 1 : 0;\n" name i
2965           | Int name ->
2966               pr "  %s = atoi (argv[%d]);\n" name i
2967       ) (snd style);
2968
2969       (* Call C API function. *)
2970       let fn =
2971         try find_map (function FishAction n -> Some n | _ -> None) flags
2972         with Not_found -> sprintf "guestfs_%s" name in
2973       pr "  r = %s " fn;
2974       generate_call_args ~handle:"g" style;
2975       pr ";\n";
2976
2977       (* Check return value for errors and display command results. *)
2978       (match fst style with
2979        | RErr -> pr "  return r;\n"
2980        | RInt _ ->
2981            pr "  if (r == -1) return -1;\n";
2982            pr "  if (r) printf (\"%%d\\n\", r);\n";
2983            pr "  return 0;\n"
2984        | RBool _ ->
2985            pr "  if (r == -1) return -1;\n";
2986            pr "  if (r) printf (\"true\\n\"); else printf (\"false\\n\");\n";
2987            pr "  return 0;\n"
2988        | RConstString _ ->
2989            pr "  if (r == NULL) return -1;\n";
2990            pr "  printf (\"%%s\\n\", r);\n";
2991            pr "  return 0;\n"
2992        | RString _ ->
2993            pr "  if (r == NULL) return -1;\n";
2994            pr "  printf (\"%%s\\n\", r);\n";
2995            pr "  free (r);\n";
2996            pr "  return 0;\n"
2997        | RStringList _ ->
2998            pr "  if (r == NULL) return -1;\n";
2999            pr "  print_strings (r);\n";
3000            pr "  free_strings (r);\n";
3001            pr "  return 0;\n"
3002        | RIntBool _ ->
3003            pr "  if (r == NULL) return -1;\n";
3004            pr "  printf (\"%%d, %%s\\n\", r->i,\n";
3005            pr "    r->b ? \"true\" : \"false\");\n";
3006            pr "  guestfs_free_int_bool (r);\n";
3007            pr "  return 0;\n"
3008        | RPVList _ ->
3009            pr "  if (r == NULL) return -1;\n";
3010            pr "  print_pv_list (r);\n";
3011            pr "  guestfs_free_lvm_pv_list (r);\n";
3012            pr "  return 0;\n"
3013        | RVGList _ ->
3014            pr "  if (r == NULL) return -1;\n";
3015            pr "  print_vg_list (r);\n";
3016            pr "  guestfs_free_lvm_vg_list (r);\n";
3017            pr "  return 0;\n"
3018        | RLVList _ ->
3019            pr "  if (r == NULL) return -1;\n";
3020            pr "  print_lv_list (r);\n";
3021            pr "  guestfs_free_lvm_lv_list (r);\n";
3022            pr "  return 0;\n"
3023        | RStat _ ->
3024            pr "  if (r == NULL) return -1;\n";
3025            pr "  print_stat (r);\n";
3026            pr "  free (r);\n";
3027            pr "  return 0;\n"
3028        | RStatVFS _ ->
3029            pr "  if (r == NULL) return -1;\n";
3030            pr "  print_statvfs (r);\n";
3031            pr "  free (r);\n";
3032            pr "  return 0;\n"
3033        | RHashtable _ ->
3034            pr "  if (r == NULL) return -1;\n";
3035            pr "  print_table (r);\n";
3036            pr "  free_strings (r);\n";
3037            pr "  return 0;\n"
3038       );
3039       pr "}\n";
3040       pr "\n"
3041   ) all_functions;
3042
3043   (* run_action function *)
3044   pr "int run_action (const char *cmd, int argc, char *argv[])\n";
3045   pr "{\n";
3046   List.iter (
3047     fun (name, _, _, flags, _, _, _) ->
3048       let name2 = replace_char name '_' '-' in
3049       let alias =
3050         try find_map (function FishAlias n -> Some n | _ -> None) flags
3051         with Not_found -> name in
3052       pr "  if (";
3053       pr "strcasecmp (cmd, \"%s\") == 0" name;
3054       if name <> name2 then
3055         pr " || strcasecmp (cmd, \"%s\") == 0" name2;
3056       if name <> alias then
3057         pr " || strcasecmp (cmd, \"%s\") == 0" alias;
3058       pr ")\n";
3059       pr "    return run_%s (cmd, argc, argv);\n" name;
3060       pr "  else\n";
3061   ) all_functions;
3062   pr "    {\n";
3063   pr "      fprintf (stderr, \"%%s: unknown command\\n\", cmd);\n";
3064   pr "      return -1;\n";
3065   pr "    }\n";
3066   pr "  return 0;\n";
3067   pr "}\n";
3068   pr "\n"
3069
3070 (* Readline completion for guestfish. *)
3071 and generate_fish_completion () =
3072   generate_header CStyle GPLv2;
3073
3074   let all_functions =
3075     List.filter (
3076       fun (_, _, _, flags, _, _, _) -> not (List.mem NotInFish flags)
3077     ) all_functions in
3078
3079   pr "\
3080 #include <config.h>
3081
3082 #include <stdio.h>
3083 #include <stdlib.h>
3084 #include <string.h>
3085
3086 #ifdef HAVE_LIBREADLINE
3087 #include <readline/readline.h>
3088 #endif
3089
3090 #include \"fish.h\"
3091
3092 #ifdef HAVE_LIBREADLINE
3093
3094 static const char *commands[] = {
3095 ";
3096
3097   (* Get the commands and sort them, including the aliases. *)
3098   let commands =
3099     List.map (
3100       fun (name, _, _, flags, _, _, _) ->
3101         let name2 = replace_char name '_' '-' in
3102         let alias =
3103           try find_map (function FishAlias n -> Some n | _ -> None) flags
3104           with Not_found -> name in
3105
3106         if name <> alias then [name2; alias] else [name2]
3107     ) all_functions in
3108   let commands = List.flatten commands in
3109   let commands = List.sort compare commands in
3110
3111   List.iter (pr "  \"%s\",\n") commands;
3112
3113   pr "  NULL
3114 };
3115
3116 static char *
3117 generator (const char *text, int state)
3118 {
3119   static int index, len;
3120   const char *name;
3121
3122   if (!state) {
3123     index = 0;
3124     len = strlen (text);
3125   }
3126
3127   while ((name = commands[index]) != NULL) {
3128     index++;
3129     if (strncasecmp (name, text, len) == 0)
3130       return strdup (name);
3131   }
3132
3133   return NULL;
3134 }
3135
3136 #endif /* HAVE_LIBREADLINE */
3137
3138 char **do_completion (const char *text, int start, int end)
3139 {
3140   char **matches = NULL;
3141
3142 #ifdef HAVE_LIBREADLINE
3143   if (start == 0)
3144     matches = rl_completion_matches (text, generator);
3145 #endif
3146
3147   return matches;
3148 }
3149 ";
3150
3151 (* Generate the POD documentation for guestfish. *)
3152 and generate_fish_actions_pod () =
3153   let all_functions_sorted =
3154     List.filter (
3155       fun (_, _, _, flags, _, _, _) -> not (List.mem NotInFish flags)
3156     ) all_functions_sorted in
3157
3158   List.iter (
3159     fun (name, style, _, flags, _, _, longdesc) ->
3160       let longdesc = replace_str longdesc "C<guestfs_" "C<" in
3161       let name = replace_char name '_' '-' in
3162       let alias =
3163         try find_map (function FishAlias n -> Some n | _ -> None) flags
3164         with Not_found -> name in
3165
3166       pr "=head2 %s" name;
3167       if name <> alias then
3168         pr " | %s" alias;
3169       pr "\n";
3170       pr "\n";
3171       pr " %s" name;
3172       List.iter (
3173         function
3174         | String n -> pr " %s" n
3175         | OptString n -> pr " %s" n
3176         | StringList n -> pr " %s,..." n
3177         | Bool _ -> pr " true|false"
3178         | Int n -> pr " %s" n
3179       ) (snd style);
3180       pr "\n";
3181       pr "\n";
3182       pr "%s\n\n" longdesc;
3183
3184       if List.mem ProtocolLimitWarning flags then
3185         pr "%s\n\n" protocol_limit_warning;
3186
3187       if List.mem DangerWillRobinson flags then
3188         pr "%s\n\n" danger_will_robinson
3189   ) all_functions_sorted
3190
3191 (* Generate a C function prototype. *)
3192 and generate_prototype ?(extern = true) ?(static = false) ?(semicolon = true)
3193     ?(single_line = false) ?(newline = false) ?(in_daemon = false)
3194     ?(prefix = "")
3195     ?handle name style =
3196   if extern then pr "extern ";
3197   if static then pr "static ";
3198   (match fst style with
3199    | RErr -> pr "int "
3200    | RInt _ -> pr "int "
3201    | RBool _ -> pr "int "
3202    | RConstString _ -> pr "const char *"
3203    | RString _ -> pr "char *"
3204    | RStringList _ | RHashtable _ -> pr "char **"
3205    | RIntBool _ ->
3206        if not in_daemon then pr "struct guestfs_int_bool *"
3207        else pr "guestfs_%s_ret *" name
3208    | RPVList _ ->
3209        if not in_daemon then pr "struct guestfs_lvm_pv_list *"
3210        else pr "guestfs_lvm_int_pv_list *"
3211    | RVGList _ ->
3212        if not in_daemon then pr "struct guestfs_lvm_vg_list *"
3213        else pr "guestfs_lvm_int_vg_list *"
3214    | RLVList _ ->
3215        if not in_daemon then pr "struct guestfs_lvm_lv_list *"
3216        else pr "guestfs_lvm_int_lv_list *"
3217    | RStat _ ->
3218        if not in_daemon then pr "struct guestfs_stat *"
3219        else pr "guestfs_int_stat *"
3220    | RStatVFS _ ->
3221        if not in_daemon then pr "struct guestfs_statvfs *"
3222        else pr "guestfs_int_statvfs *"
3223   );
3224   pr "%s%s (" prefix name;
3225   if handle = None && List.length (snd style) = 0 then
3226     pr "void"
3227   else (
3228     let comma = ref false in
3229     (match handle with
3230      | None -> ()
3231      | Some handle -> pr "guestfs_h *%s" handle; comma := true
3232     );
3233     let next () =
3234       if !comma then (
3235         if single_line then pr ", " else pr ",\n\t\t"
3236       );
3237       comma := true
3238     in
3239     List.iter (
3240       function
3241       | String n -> next (); pr "const char *%s" n
3242       | OptString n -> next (); pr "const char *%s" n
3243       | StringList n -> next (); pr "char * const* const %s" n
3244       | Bool n -> next (); pr "int %s" n
3245       | Int n -> next (); pr "int %s" n
3246     ) (snd style);
3247   );
3248   pr ")";
3249   if semicolon then pr ";";
3250   if newline then pr "\n"
3251
3252 (* Generate C call arguments, eg "(handle, foo, bar)" *)
3253 and generate_call_args ?handle style =
3254   pr "(";
3255   let comma = ref false in
3256   (match handle with
3257    | None -> ()
3258    | Some handle -> pr "%s" handle; comma := true
3259   );
3260   List.iter (
3261     fun arg ->
3262       if !comma then pr ", ";
3263       comma := true;
3264       match arg with
3265       | String n
3266       | OptString n
3267       | StringList n
3268       | Bool n
3269       | Int n -> pr "%s" n
3270   ) (snd style);
3271   pr ")"
3272
3273 (* Generate the OCaml bindings interface. *)
3274 and generate_ocaml_mli () =
3275   generate_header OCamlStyle LGPLv2;
3276
3277   pr "\
3278 (** For API documentation you should refer to the C API
3279     in the guestfs(3) manual page.  The OCaml API uses almost
3280     exactly the same calls. *)
3281
3282 type t
3283 (** A [guestfs_h] handle. *)
3284
3285 exception Error of string
3286 (** This exception is raised when there is an error. *)
3287
3288 val create : unit -> t
3289
3290 val close : t -> unit
3291 (** Handles are closed by the garbage collector when they become
3292     unreferenced, but callers can also call this in order to
3293     provide predictable cleanup. *)
3294
3295 ";
3296   generate_ocaml_lvm_structure_decls ();
3297
3298   generate_ocaml_stat_structure_decls ();
3299
3300   (* The actions. *)
3301   List.iter (
3302     fun (name, style, _, _, _, shortdesc, _) ->
3303       generate_ocaml_prototype name style;
3304       pr "(** %s *)\n" shortdesc;
3305       pr "\n"
3306   ) all_functions
3307
3308 (* Generate the OCaml bindings implementation. *)
3309 and generate_ocaml_ml () =
3310   generate_header OCamlStyle LGPLv2;
3311
3312   pr "\
3313 type t
3314 exception Error of string
3315 external create : unit -> t = \"ocaml_guestfs_create\"
3316 external close : t -> unit = \"ocaml_guestfs_close\"
3317
3318 let () =
3319   Callback.register_exception \"ocaml_guestfs_error\" (Error \"\")
3320
3321 ";
3322
3323   generate_ocaml_lvm_structure_decls ();
3324
3325   generate_ocaml_stat_structure_decls ();
3326
3327   (* The actions. *)
3328   List.iter (
3329     fun (name, style, _, _, _, shortdesc, _) ->
3330       generate_ocaml_prototype ~is_external:true name style;
3331   ) all_functions
3332
3333 (* Generate the OCaml bindings C implementation. *)
3334 and generate_ocaml_c () =
3335   generate_header CStyle LGPLv2;
3336
3337   pr "\
3338 #include <stdio.h>
3339 #include <stdlib.h>
3340 #include <string.h>
3341
3342 #include <caml/config.h>
3343 #include <caml/alloc.h>
3344 #include <caml/callback.h>
3345 #include <caml/fail.h>
3346 #include <caml/memory.h>
3347 #include <caml/mlvalues.h>
3348 #include <caml/signals.h>
3349
3350 #include <guestfs.h>
3351
3352 #include \"guestfs_c.h\"
3353
3354 /* Copy a hashtable of string pairs into an assoc-list.  We return
3355  * the list in reverse order, but hashtables aren't supposed to be
3356  * ordered anyway.
3357  */
3358 static CAMLprim value
3359 copy_table (char * const * argv)
3360 {
3361   CAMLparam0 ();
3362   CAMLlocal5 (rv, pairv, kv, vv, cons);
3363   int i;
3364
3365   rv = Val_int (0);
3366   for (i = 0; argv[i] != NULL; i += 2) {
3367     kv = caml_copy_string (argv[i]);
3368     vv = caml_copy_string (argv[i+1]);
3369     pairv = caml_alloc (2, 0);
3370     Store_field (pairv, 0, kv);
3371     Store_field (pairv, 1, vv);
3372     cons = caml_alloc (2, 0);
3373     Store_field (cons, 1, rv);
3374     rv = cons;
3375     Store_field (cons, 0, pairv);
3376   }
3377
3378   CAMLreturn (rv);
3379 }
3380
3381 ";
3382
3383   (* LVM struct copy functions. *)
3384   List.iter (
3385     fun (typ, cols) ->
3386       let has_optpercent_col =
3387         List.exists (function (_, `OptPercent) -> true | _ -> false) cols in
3388
3389       pr "static CAMLprim value\n";
3390       pr "copy_lvm_%s (const struct guestfs_lvm_%s *%s)\n" typ typ typ;
3391       pr "{\n";
3392       pr "  CAMLparam0 ();\n";
3393       if has_optpercent_col then
3394         pr "  CAMLlocal3 (rv, v, v2);\n"
3395       else
3396         pr "  CAMLlocal2 (rv, v);\n";
3397       pr "\n";
3398       pr "  rv = caml_alloc (%d, 0);\n" (List.length cols);
3399       iteri (
3400         fun i col ->
3401           (match col with
3402            | name, `String ->
3403                pr "  v = caml_copy_string (%s->%s);\n" typ name
3404            | name, `UUID ->
3405                pr "  v = caml_alloc_string (32);\n";
3406                pr "  memcpy (String_val (v), %s->%s, 32);\n" typ name
3407            | name, `Bytes
3408            | name, `Int ->
3409                pr "  v = caml_copy_int64 (%s->%s);\n" typ name
3410            | name, `OptPercent ->
3411                pr "  if (%s->%s >= 0) { /* Some %s */\n" typ name name;
3412                pr "    v2 = caml_copy_double (%s->%s);\n" typ name;
3413                pr "    v = caml_alloc (1, 0);\n";
3414                pr "    Store_field (v, 0, v2);\n";
3415                pr "  } else /* None */\n";
3416                pr "    v = Val_int (0);\n";
3417           );
3418           pr "  Store_field (rv, %d, v);\n" i
3419       ) cols;
3420       pr "  CAMLreturn (rv);\n";
3421       pr "}\n";
3422       pr "\n";
3423
3424       pr "static CAMLprim value\n";
3425       pr "copy_lvm_%s_list (const struct guestfs_lvm_%s_list *%ss)\n"
3426         typ typ typ;
3427       pr "{\n";
3428       pr "  CAMLparam0 ();\n";
3429       pr "  CAMLlocal2 (rv, v);\n";
3430       pr "  int i;\n";
3431       pr "\n";
3432       pr "  if (%ss->len == 0)\n" typ;
3433       pr "    CAMLreturn (Atom (0));\n";
3434       pr "  else {\n";
3435       pr "    rv = caml_alloc (%ss->len, 0);\n" typ;
3436       pr "    for (i = 0; i < %ss->len; ++i) {\n" typ;
3437       pr "      v = copy_lvm_%s (&%ss->val[i]);\n" typ typ;
3438       pr "      caml_modify (&Field (rv, i), v);\n";
3439       pr "    }\n";
3440       pr "    CAMLreturn (rv);\n";
3441       pr "  }\n";
3442       pr "}\n";
3443       pr "\n";
3444   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols];
3445
3446   (* Stat copy functions. *)
3447   List.iter (
3448     fun (typ, cols) ->
3449       pr "static CAMLprim value\n";
3450       pr "copy_%s (const struct guestfs_%s *%s)\n" typ typ typ;
3451       pr "{\n";
3452       pr "  CAMLparam0 ();\n";
3453       pr "  CAMLlocal2 (rv, v);\n";
3454       pr "\n";
3455       pr "  rv = caml_alloc (%d, 0);\n" (List.length cols);
3456       iteri (
3457         fun i col ->
3458           (match col with
3459            | name, `Int ->
3460                pr "  v = caml_copy_int64 (%s->%s);\n" typ name
3461           );
3462           pr "  Store_field (rv, %d, v);\n" i
3463       ) cols;
3464       pr "  CAMLreturn (rv);\n";
3465       pr "}\n";
3466       pr "\n";
3467   ) ["stat", stat_cols; "statvfs", statvfs_cols];
3468
3469   (* The wrappers. *)
3470   List.iter (
3471     fun (name, style, _, _, _, _, _) ->
3472       let params =
3473         "gv" :: List.map (fun arg -> name_of_argt arg ^ "v") (snd style) in
3474
3475       pr "CAMLprim value\n";
3476       pr "ocaml_guestfs_%s (value %s" name (List.hd params);
3477       List.iter (pr ", value %s") (List.tl params);
3478       pr ")\n";
3479       pr "{\n";
3480
3481       (match params with
3482        | p1 :: p2 :: p3 :: p4 :: p5 :: rest ->
3483            pr "  CAMLparam5 (%s);\n" (String.concat ", " [p1; p2; p3; p4; p5]);
3484            pr "  CAMLxparam%d (%s);\n"
3485              (List.length rest) (String.concat ", " rest)
3486        | ps ->
3487            pr "  CAMLparam%d (%s);\n" (List.length ps) (String.concat ", " ps)
3488       );
3489       pr "  CAMLlocal1 (rv);\n";
3490       pr "\n";
3491
3492       pr "  guestfs_h *g = Guestfs_val (gv);\n";
3493       pr "  if (g == NULL)\n";
3494       pr "    caml_failwith (\"%s: used handle after closing it\");\n" name;
3495       pr "\n";
3496
3497       List.iter (
3498         function
3499         | String n ->
3500             pr "  const char *%s = String_val (%sv);\n" n n
3501         | OptString n ->
3502             pr "  const char *%s =\n" n;
3503             pr "    %sv != Val_int (0) ? String_val (Field (%sv, 0)) : NULL;\n"
3504               n n
3505         | StringList n ->
3506             pr "  char **%s = ocaml_guestfs_strings_val (%sv);\n" n n
3507         | Bool n ->
3508             pr "  int %s = Bool_val (%sv);\n" n n
3509         | Int n ->
3510             pr "  int %s = Int_val (%sv);\n" n n
3511       ) (snd style);
3512       let error_code =
3513         match fst style with
3514         | RErr -> pr "  int r;\n"; "-1"
3515         | RInt _ -> pr "  int r;\n"; "-1"
3516         | RBool _ -> pr "  int r;\n"; "-1"
3517         | RConstString _ -> pr "  const char *r;\n"; "NULL"
3518         | RString _ -> pr "  char *r;\n"; "NULL"
3519         | RStringList _ ->
3520             pr "  int i;\n";
3521             pr "  char **r;\n";
3522             "NULL"
3523         | RIntBool _ ->
3524             pr "  struct guestfs_int_bool *r;\n"; "NULL"
3525         | RPVList _ ->
3526             pr "  struct guestfs_lvm_pv_list *r;\n"; "NULL"
3527         | RVGList _ ->
3528             pr "  struct guestfs_lvm_vg_list *r;\n"; "NULL"
3529         | RLVList _ ->
3530             pr "  struct guestfs_lvm_lv_list *r;\n"; "NULL"
3531         | RStat _ ->
3532             pr "  struct guestfs_stat *r;\n"; "NULL"
3533         | RStatVFS _ ->
3534             pr "  struct guestfs_statvfs *r;\n"; "NULL"
3535         | RHashtable _ ->
3536             pr "  char **r;\n";
3537             "NULL" in
3538       pr "\n";
3539
3540       pr "  caml_enter_blocking_section ();\n";
3541       pr "  r = guestfs_%s " name;
3542       generate_call_args ~handle:"g" style;
3543       pr ";\n";
3544       pr "  caml_leave_blocking_section ();\n";
3545
3546       List.iter (
3547         function
3548         | StringList n ->
3549             pr "  ocaml_guestfs_free_strings (%s);\n" n;
3550         | String _ | OptString _ | Bool _ | Int _ -> ()
3551       ) (snd style);
3552
3553       pr "  if (r == %s)\n" error_code;
3554       pr "    ocaml_guestfs_raise_error (g, \"%s\");\n" name;
3555       pr "\n";
3556
3557       (match fst style with
3558        | RErr -> pr "  rv = Val_unit;\n"
3559        | RInt _ -> pr "  rv = Val_int (r);\n"
3560        | RBool _ -> pr "  rv = Val_bool (r);\n"
3561        | RConstString _ -> pr "  rv = caml_copy_string (r);\n"
3562        | RString _ ->
3563            pr "  rv = caml_copy_string (r);\n";
3564            pr "  free (r);\n"
3565        | RStringList _ ->
3566            pr "  rv = caml_copy_string_array ((const char **) r);\n";
3567            pr "  for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
3568            pr "  free (r);\n"
3569        | RIntBool _ ->
3570            pr "  rv = caml_alloc (2, 0);\n";
3571            pr "  Store_field (rv, 0, Val_int (r->i));\n";
3572            pr "  Store_field (rv, 1, Val_bool (r->b));\n";
3573            pr "  guestfs_free_int_bool (r);\n";
3574        | RPVList _ ->
3575            pr "  rv = copy_lvm_pv_list (r);\n";
3576            pr "  guestfs_free_lvm_pv_list (r);\n";
3577        | RVGList _ ->
3578            pr "  rv = copy_lvm_vg_list (r);\n";
3579            pr "  guestfs_free_lvm_vg_list (r);\n";
3580        | RLVList _ ->
3581            pr "  rv = copy_lvm_lv_list (r);\n";
3582            pr "  guestfs_free_lvm_lv_list (r);\n";
3583        | RStat _ ->
3584            pr "  rv = copy_stat (r);\n";
3585            pr "  free (r);\n";
3586        | RStatVFS _ ->
3587            pr "  rv = copy_statvfs (r);\n";
3588            pr "  free (r);\n";
3589        | RHashtable _ ->
3590            pr "  rv = copy_table (r);\n";
3591            pr "  free (r);\n";
3592       );
3593
3594       pr "  CAMLreturn (rv);\n";
3595       pr "}\n";
3596       pr "\n";
3597
3598       if List.length params > 5 then (
3599         pr "CAMLprim value\n";
3600         pr "ocaml_guestfs_%s_byte (value *argv, int argn)\n" name;
3601         pr "{\n";
3602         pr "  return ocaml_guestfs_%s (argv[0]" name;
3603         iteri (fun i _ -> pr ", argv[%d]" i) (List.tl params);
3604         pr ");\n";
3605         pr "}\n";
3606         pr "\n"
3607       )
3608   ) all_functions
3609
3610 and generate_ocaml_lvm_structure_decls () =
3611   List.iter (
3612     fun (typ, cols) ->
3613       pr "type lvm_%s = {\n" typ;
3614       List.iter (
3615         function
3616         | name, `String -> pr "  %s : string;\n" name
3617         | name, `UUID -> pr "  %s : string;\n" name
3618         | name, `Bytes -> pr "  %s : int64;\n" name
3619         | name, `Int -> pr "  %s : int64;\n" name
3620         | name, `OptPercent -> pr "  %s : float option;\n" name
3621       ) cols;
3622       pr "}\n";
3623       pr "\n"
3624   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols]
3625
3626 and generate_ocaml_stat_structure_decls () =
3627   List.iter (
3628     fun (typ, cols) ->
3629       pr "type %s = {\n" typ;
3630       List.iter (
3631         function
3632         | name, `Int -> pr "  %s : int64;\n" name
3633       ) cols;
3634       pr "}\n";
3635       pr "\n"
3636   ) ["stat", stat_cols; "statvfs", statvfs_cols]
3637
3638 and generate_ocaml_prototype ?(is_external = false) name style =
3639   if is_external then pr "external " else pr "val ";
3640   pr "%s : t -> " name;
3641   List.iter (
3642     function
3643     | String _ -> pr "string -> "
3644     | OptString _ -> pr "string option -> "
3645     | StringList _ -> pr "string array -> "
3646     | Bool _ -> pr "bool -> "
3647     | Int _ -> pr "int -> "
3648   ) (snd style);
3649   (match fst style with
3650    | RErr -> pr "unit" (* all errors are turned into exceptions *)
3651    | RInt _ -> pr "int"
3652    | RBool _ -> pr "bool"
3653    | RConstString _ -> pr "string"
3654    | RString _ -> pr "string"
3655    | RStringList _ -> pr "string array"
3656    | RIntBool _ -> pr "int * bool"
3657    | RPVList _ -> pr "lvm_pv array"
3658    | RVGList _ -> pr "lvm_vg array"
3659    | RLVList _ -> pr "lvm_lv array"
3660    | RStat _ -> pr "stat"
3661    | RStatVFS _ -> pr "statvfs"
3662    | RHashtable _ -> pr "(string * string) list"
3663   );
3664   if is_external then (
3665     pr " = ";
3666     if List.length (snd style) + 1 > 5 then
3667       pr "\"ocaml_guestfs_%s_byte\" " name;
3668     pr "\"ocaml_guestfs_%s\"" name
3669   );
3670   pr "\n"
3671
3672 (* Generate Perl xs code, a sort of crazy variation of C with macros. *)
3673 and generate_perl_xs () =
3674   generate_header CStyle LGPLv2;
3675
3676   pr "\
3677 #include \"EXTERN.h\"
3678 #include \"perl.h\"
3679 #include \"XSUB.h\"
3680
3681 #include <guestfs.h>
3682
3683 #ifndef PRId64
3684 #define PRId64 \"lld\"
3685 #endif
3686
3687 static SV *
3688 my_newSVll(long long val) {
3689 #ifdef USE_64_BIT_ALL
3690   return newSViv(val);
3691 #else
3692   char buf[100];
3693   int len;
3694   len = snprintf(buf, 100, \"%%\" PRId64, val);
3695   return newSVpv(buf, len);
3696 #endif
3697 }
3698
3699 #ifndef PRIu64
3700 #define PRIu64 \"llu\"
3701 #endif
3702
3703 static SV *
3704 my_newSVull(unsigned long long val) {
3705 #ifdef USE_64_BIT_ALL
3706   return newSVuv(val);
3707 #else
3708   char buf[100];
3709   int len;
3710   len = snprintf(buf, 100, \"%%\" PRIu64, val);
3711   return newSVpv(buf, len);
3712 #endif
3713 }
3714
3715 /* http://www.perlmonks.org/?node_id=680842 */
3716 static char **
3717 XS_unpack_charPtrPtr (SV *arg) {
3718   char **ret;
3719   AV *av;
3720   I32 i;
3721
3722   if (!arg || !SvOK (arg) || !SvROK (arg) || SvTYPE (SvRV (arg)) != SVt_PVAV) {
3723     croak (\"array reference expected\");
3724   }
3725
3726   av = (AV *)SvRV (arg);
3727   ret = (char **)malloc (av_len (av) + 1 + 1);
3728
3729   for (i = 0; i <= av_len (av); i++) {
3730     SV **elem = av_fetch (av, i, 0);
3731
3732     if (!elem || !*elem)
3733       croak (\"missing element in list\");
3734
3735     ret[i] = SvPV_nolen (*elem);
3736   }
3737
3738   ret[i] = NULL;
3739
3740   return ret;
3741 }
3742
3743 MODULE = Sys::Guestfs  PACKAGE = Sys::Guestfs
3744
3745 guestfs_h *
3746 _create ()
3747    CODE:
3748       RETVAL = guestfs_create ();
3749       if (!RETVAL)
3750         croak (\"could not create guestfs handle\");
3751       guestfs_set_error_handler (RETVAL, NULL, NULL);
3752  OUTPUT:
3753       RETVAL
3754
3755 void
3756 DESTROY (g)
3757       guestfs_h *g;
3758  PPCODE:
3759       guestfs_close (g);
3760
3761 ";
3762
3763   List.iter (
3764     fun (name, style, _, _, _, _, _) ->
3765       (match fst style with
3766        | RErr -> pr "void\n"
3767        | RInt _ -> pr "SV *\n"
3768        | RBool _ -> pr "SV *\n"
3769        | RConstString _ -> pr "SV *\n"
3770        | RString _ -> pr "SV *\n"
3771        | RStringList _
3772        | RIntBool _
3773        | RPVList _ | RVGList _ | RLVList _
3774        | RStat _ | RStatVFS _
3775        | RHashtable _ ->
3776            pr "void\n" (* all lists returned implictly on the stack *)
3777       );
3778       (* Call and arguments. *)
3779       pr "%s " name;
3780       generate_call_args ~handle:"g" style;
3781       pr "\n";
3782       pr "      guestfs_h *g;\n";
3783       List.iter (
3784         function
3785         | String n -> pr "      char *%s;\n" n
3786         | OptString n -> pr "      char *%s;\n" n
3787         | StringList n -> pr "      char **%s;\n" n
3788         | Bool n -> pr "      int %s;\n" n
3789         | Int n -> pr "      int %s;\n" n
3790       ) (snd style);
3791
3792       let do_cleanups () =
3793         List.iter (
3794           function
3795           | String _
3796           | OptString _
3797           | Bool _
3798           | Int _ -> ()
3799           | StringList n -> pr "      free (%s);\n" n
3800         ) (snd style)
3801       in
3802
3803       (* Code. *)
3804       (match fst style with
3805        | RErr ->
3806            pr "PREINIT:\n";
3807            pr "      int r;\n";
3808            pr " PPCODE:\n";
3809            pr "      r = guestfs_%s " name;
3810            generate_call_args ~handle:"g" style;
3811            pr ";\n";
3812            do_cleanups ();
3813            pr "      if (r == -1)\n";
3814            pr "        croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
3815        | RInt n
3816        | RBool n ->
3817            pr "PREINIT:\n";
3818            pr "      int %s;\n" n;
3819            pr "   CODE:\n";
3820            pr "      %s = guestfs_%s " n name;
3821            generate_call_args ~handle:"g" style;
3822            pr ";\n";
3823            do_cleanups ();
3824            pr "      if (%s == -1)\n" n;
3825            pr "        croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
3826            pr "      RETVAL = newSViv (%s);\n" n;
3827            pr " OUTPUT:\n";
3828            pr "      RETVAL\n"
3829        | RConstString n ->
3830            pr "PREINIT:\n";
3831            pr "      const char *%s;\n" n;
3832            pr "   CODE:\n";
3833            pr "      %s = guestfs_%s " n name;
3834            generate_call_args ~handle:"g" style;
3835            pr ";\n";
3836            do_cleanups ();
3837            pr "      if (%s == NULL)\n" n;
3838            pr "        croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
3839            pr "      RETVAL = newSVpv (%s, 0);\n" n;
3840            pr " OUTPUT:\n";
3841            pr "      RETVAL\n"
3842        | RString n ->
3843            pr "PREINIT:\n";
3844            pr "      char *%s;\n" n;
3845            pr "   CODE:\n";
3846            pr "      %s = guestfs_%s " n name;
3847            generate_call_args ~handle:"g" style;
3848            pr ";\n";
3849            do_cleanups ();
3850            pr "      if (%s == NULL)\n" n;
3851            pr "        croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
3852            pr "      RETVAL = newSVpv (%s, 0);\n" n;
3853            pr "      free (%s);\n" n;
3854            pr " OUTPUT:\n";
3855            pr "      RETVAL\n"
3856        | RStringList n | RHashtable n ->
3857            pr "PREINIT:\n";
3858            pr "      char **%s;\n" n;
3859            pr "      int i, n;\n";
3860            pr " PPCODE:\n";
3861            pr "      %s = guestfs_%s " n name;
3862            generate_call_args ~handle:"g" style;
3863            pr ";\n";
3864            do_cleanups ();
3865            pr "      if (%s == NULL)\n" n;
3866            pr "        croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
3867            pr "      for (n = 0; %s[n] != NULL; ++n) /**/;\n" n;
3868            pr "      EXTEND (SP, n);\n";
3869            pr "      for (i = 0; i < n; ++i) {\n";
3870            pr "        PUSHs (sv_2mortal (newSVpv (%s[i], 0)));\n" n;
3871            pr "        free (%s[i]);\n" n;
3872            pr "      }\n";
3873            pr "      free (%s);\n" n;
3874        | RIntBool _ ->
3875            pr "PREINIT:\n";
3876            pr "      struct guestfs_int_bool *r;\n";
3877            pr " PPCODE:\n";
3878            pr "      r = guestfs_%s " name;
3879            generate_call_args ~handle:"g" style;
3880            pr ";\n";
3881            do_cleanups ();
3882            pr "      if (r == NULL)\n";
3883            pr "        croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
3884            pr "      EXTEND (SP, 2);\n";
3885            pr "      PUSHs (sv_2mortal (newSViv (r->i)));\n";
3886            pr "      PUSHs (sv_2mortal (newSViv (r->b)));\n";
3887            pr "      guestfs_free_int_bool (r);\n";
3888        | RPVList n ->
3889            generate_perl_lvm_code "pv" pv_cols name style n do_cleanups
3890        | RVGList n ->
3891            generate_perl_lvm_code "vg" vg_cols name style n do_cleanups
3892        | RLVList n ->
3893            generate_perl_lvm_code "lv" lv_cols name style n do_cleanups
3894        | RStat n ->
3895            generate_perl_stat_code "stat" stat_cols name style n do_cleanups
3896        | RStatVFS n ->
3897            generate_perl_stat_code
3898              "statvfs" statvfs_cols name style n do_cleanups
3899       );
3900
3901       pr "\n"
3902   ) all_functions
3903
3904 and generate_perl_lvm_code typ cols name style n do_cleanups =
3905   pr "PREINIT:\n";
3906   pr "      struct guestfs_lvm_%s_list *%s;\n" typ n;
3907   pr "      int i;\n";
3908   pr "      HV *hv;\n";
3909   pr " PPCODE:\n";
3910   pr "      %s = guestfs_%s " n name;
3911   generate_call_args ~handle:"g" style;
3912   pr ";\n";
3913   do_cleanups ();
3914   pr "      if (%s == NULL)\n" n;
3915   pr "        croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
3916   pr "      EXTEND (SP, %s->len);\n" n;
3917   pr "      for (i = 0; i < %s->len; ++i) {\n" n;
3918   pr "        hv = newHV ();\n";
3919   List.iter (
3920     function
3921     | name, `String ->
3922         pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (%s->val[i].%s, 0), 0);\n"
3923           name (String.length name) n name
3924     | name, `UUID ->
3925         pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (%s->val[i].%s, 32), 0);\n"
3926           name (String.length name) n name
3927     | name, `Bytes ->
3928         pr "        (void) hv_store (hv, \"%s\", %d, my_newSVull (%s->val[i].%s), 0);\n"
3929           name (String.length name) n name
3930     | name, `Int ->
3931         pr "        (void) hv_store (hv, \"%s\", %d, my_newSVll (%s->val[i].%s), 0);\n"
3932           name (String.length name) n name
3933     | name, `OptPercent ->
3934         pr "        (void) hv_store (hv, \"%s\", %d, newSVnv (%s->val[i].%s), 0);\n"
3935           name (String.length name) n name
3936   ) cols;
3937   pr "        PUSHs (sv_2mortal ((SV *) hv));\n";
3938   pr "      }\n";
3939   pr "      guestfs_free_lvm_%s_list (%s);\n" typ n
3940
3941 and generate_perl_stat_code typ cols name style n do_cleanups =
3942   pr "PREINIT:\n";
3943   pr "      struct guestfs_%s *%s;\n" typ n;
3944   pr " PPCODE:\n";
3945   pr "      %s = guestfs_%s " n name;
3946   generate_call_args ~handle:"g" style;
3947   pr ";\n";
3948   do_cleanups ();
3949   pr "      if (%s == NULL)\n" n;
3950   pr "        croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
3951   pr "      EXTEND (SP, %d);\n" (List.length cols);
3952   List.iter (
3953     function
3954     | name, `Int ->
3955         pr "      PUSHs (sv_2mortal (my_newSVll (%s->%s)));\n" n name
3956   ) cols;
3957   pr "      free (%s);\n" n
3958
3959 (* Generate Sys/Guestfs.pm. *)
3960 and generate_perl_pm () =
3961   generate_header HashStyle LGPLv2;
3962
3963   pr "\
3964 =pod
3965
3966 =head1 NAME
3967
3968 Sys::Guestfs - Perl bindings for libguestfs
3969
3970 =head1 SYNOPSIS
3971
3972  use Sys::Guestfs;
3973  
3974  my $h = Sys::Guestfs->new ();
3975  $h->add_drive ('guest.img');
3976  $h->launch ();
3977  $h->wait_ready ();
3978  $h->mount ('/dev/sda1', '/');
3979  $h->touch ('/hello');
3980  $h->sync ();
3981
3982 =head1 DESCRIPTION
3983
3984 The C<Sys::Guestfs> module provides a Perl XS binding to the
3985 libguestfs API for examining and modifying virtual machine
3986 disk images.
3987
3988 Amongst the things this is good for: making batch configuration
3989 changes to guests, getting disk used/free statistics (see also:
3990 virt-df), migrating between virtualization systems (see also:
3991 virt-p2v), performing partial backups, performing partial guest
3992 clones, cloning guests and changing registry/UUID/hostname info, and
3993 much else besides.
3994
3995 Libguestfs uses Linux kernel and qemu code, and can access any type of
3996 guest filesystem that Linux and qemu can, including but not limited
3997 to: ext2/3/4, btrfs, FAT and NTFS, LVM, many different disk partition
3998 schemes, qcow, qcow2, vmdk.
3999
4000 Libguestfs provides ways to enumerate guest storage (eg. partitions,
4001 LVs, what filesystem is in each LV, etc.).  It can also run commands
4002 in the context of the guest.  Also you can access filesystems over FTP.
4003
4004 =head1 ERRORS
4005
4006 All errors turn into calls to C<croak> (see L<Carp(3)>).
4007
4008 =head1 METHODS
4009
4010 =over 4
4011
4012 =cut
4013
4014 package Sys::Guestfs;
4015
4016 use strict;
4017 use warnings;
4018
4019 require XSLoader;
4020 XSLoader::load ('Sys::Guestfs');
4021
4022 =item $h = Sys::Guestfs->new ();
4023
4024 Create a new guestfs handle.
4025
4026 =cut
4027
4028 sub new {
4029   my $proto = shift;
4030   my $class = ref ($proto) || $proto;
4031
4032   my $self = Sys::Guestfs::_create ();
4033   bless $self, $class;
4034   return $self;
4035 }
4036
4037 ";
4038
4039   (* Actions.  We only need to print documentation for these as
4040    * they are pulled in from the XS code automatically.
4041    *)
4042   List.iter (
4043     fun (name, style, _, flags, _, _, longdesc) ->
4044       let longdesc = replace_str longdesc "C<guestfs_" "C<$h-E<gt>" in
4045       pr "=item ";
4046       generate_perl_prototype name style;
4047       pr "\n\n";
4048       pr "%s\n\n" longdesc;
4049       if List.mem ProtocolLimitWarning flags then
4050         pr "%s\n\n" protocol_limit_warning;
4051       if List.mem DangerWillRobinson flags then
4052         pr "%s\n\n" danger_will_robinson
4053   ) all_functions_sorted;
4054
4055   (* End of file. *)
4056   pr "\
4057 =cut
4058
4059 1;
4060
4061 =back
4062
4063 =head1 COPYRIGHT
4064
4065 Copyright (C) 2009 Red Hat Inc.
4066
4067 =head1 LICENSE
4068
4069 Please see the file COPYING.LIB for the full license.
4070
4071 =head1 SEE ALSO
4072
4073 L<guestfs(3)>, L<guestfish(1)>.
4074
4075 =cut
4076 "
4077
4078 and generate_perl_prototype name style =
4079   (match fst style with
4080    | RErr -> ()
4081    | RBool n
4082    | RInt n
4083    | RConstString n
4084    | RString n -> pr "$%s = " n
4085    | RIntBool (n, m) -> pr "($%s, $%s) = " n m
4086    | RStringList n
4087    | RPVList n
4088    | RVGList n
4089    | RLVList n -> pr "@%s = " n
4090    | RStat n
4091    | RStatVFS n
4092    | RHashtable n -> pr "%%%s = " n
4093   );
4094   pr "$h->%s (" name;
4095   let comma = ref false in
4096   List.iter (
4097     fun arg ->
4098       if !comma then pr ", ";
4099       comma := true;
4100       match arg with
4101       | String n | OptString n | Bool n | Int n ->
4102           pr "$%s" n
4103       | StringList n ->
4104           pr "\\@%s" n
4105   ) (snd style);
4106   pr ");"
4107
4108 (* Generate Python C module. *)
4109 and generate_python_c () =
4110   generate_header CStyle LGPLv2;
4111
4112   pr "\
4113 #include <stdio.h>
4114 #include <stdlib.h>
4115 #include <assert.h>
4116
4117 #include <Python.h>
4118
4119 #include \"guestfs.h\"
4120
4121 typedef struct {
4122   PyObject_HEAD
4123   guestfs_h *g;
4124 } Pyguestfs_Object;
4125
4126 static guestfs_h *
4127 get_handle (PyObject *obj)
4128 {
4129   assert (obj);
4130   assert (obj != Py_None);
4131   return ((Pyguestfs_Object *) obj)->g;
4132 }
4133
4134 static PyObject *
4135 put_handle (guestfs_h *g)
4136 {
4137   assert (g);
4138   return
4139     PyCObject_FromVoidPtrAndDesc ((void *) g, (char *) \"guestfs_h\", NULL);
4140 }
4141
4142 /* This list should be freed (but not the strings) after use. */
4143 static const char **
4144 get_string_list (PyObject *obj)
4145 {
4146   int i, len;
4147   const char **r;
4148
4149   assert (obj);
4150
4151   if (!PyList_Check (obj)) {
4152     PyErr_SetString (PyExc_RuntimeError, \"expecting a list parameter\");
4153     return NULL;
4154   }
4155
4156   len = PyList_Size (obj);
4157   r = malloc (sizeof (char *) * (len+1));
4158   if (r == NULL) {
4159     PyErr_SetString (PyExc_RuntimeError, \"get_string_list: out of memory\");
4160     return NULL;
4161   }
4162
4163   for (i = 0; i < len; ++i)
4164     r[i] = PyString_AsString (PyList_GetItem (obj, i));
4165   r[len] = NULL;
4166
4167   return r;
4168 }
4169
4170 static PyObject *
4171 put_string_list (char * const * const argv)
4172 {
4173   PyObject *list;
4174   int argc, i;
4175
4176   for (argc = 0; argv[argc] != NULL; ++argc)
4177     ;
4178
4179   list = PyList_New (argc);
4180   for (i = 0; i < argc; ++i)
4181     PyList_SetItem (list, i, PyString_FromString (argv[i]));
4182
4183   return list;
4184 }
4185
4186 static PyObject *
4187 put_table (char * const * const argv)
4188 {
4189   PyObject *list, *item;
4190   int argc, i;
4191
4192   for (argc = 0; argv[argc] != NULL; ++argc)
4193     ;
4194
4195   list = PyList_New (argc >> 1);
4196   for (i = 0; i < argc; i += 2) {
4197     PyObject *item;
4198     item = PyTuple_New (2);
4199     PyTuple_SetItem (item, 0, PyString_FromString (argv[i]));
4200     PyTuple_SetItem (item, 1, PyString_FromString (argv[i+1]));
4201     PyList_SetItem (list, i >> 1, item);
4202   }
4203
4204   return list;
4205 }
4206
4207 static void
4208 free_strings (char **argv)
4209 {
4210   int argc;
4211
4212   for (argc = 0; argv[argc] != NULL; ++argc)
4213     free (argv[argc]);
4214   free (argv);
4215 }
4216
4217 static PyObject *
4218 py_guestfs_create (PyObject *self, PyObject *args)
4219 {
4220   guestfs_h *g;
4221
4222   g = guestfs_create ();
4223   if (g == NULL) {
4224     PyErr_SetString (PyExc_RuntimeError,
4225                      \"guestfs.create: failed to allocate handle\");
4226     return NULL;
4227   }
4228   guestfs_set_error_handler (g, NULL, NULL);
4229   return put_handle (g);
4230 }
4231
4232 static PyObject *
4233 py_guestfs_close (PyObject *self, PyObject *args)
4234 {
4235   PyObject *py_g;
4236   guestfs_h *g;
4237
4238   if (!PyArg_ParseTuple (args, (char *) \"O:guestfs_close\", &py_g))
4239     return NULL;
4240   g = get_handle (py_g);
4241
4242   guestfs_close (g);
4243
4244   Py_INCREF (Py_None);
4245   return Py_None;
4246 }
4247
4248 ";
4249
4250   (* LVM structures, turned into Python dictionaries. *)
4251   List.iter (
4252     fun (typ, cols) ->
4253       pr "static PyObject *\n";
4254       pr "put_lvm_%s (struct guestfs_lvm_%s *%s)\n" typ typ typ;
4255       pr "{\n";
4256       pr "  PyObject *dict;\n";
4257       pr "\n";
4258       pr "  dict = PyDict_New ();\n";
4259       List.iter (
4260         function
4261         | name, `String ->
4262             pr "  PyDict_SetItemString (dict, \"%s\",\n" name;
4263             pr "                        PyString_FromString (%s->%s));\n"
4264               typ name
4265         | name, `UUID ->
4266             pr "  PyDict_SetItemString (dict, \"%s\",\n" name;
4267             pr "                        PyString_FromStringAndSize (%s->%s, 32));\n"
4268               typ name
4269         | name, `Bytes ->
4270             pr "  PyDict_SetItemString (dict, \"%s\",\n" name;
4271             pr "                        PyLong_FromUnsignedLongLong (%s->%s));\n"
4272               typ name
4273         | name, `Int ->
4274             pr "  PyDict_SetItemString (dict, \"%s\",\n" name;
4275             pr "                        PyLong_FromLongLong (%s->%s));\n"
4276               typ name
4277         | name, `OptPercent ->
4278             pr "  if (%s->%s >= 0)\n" typ name;
4279             pr "    PyDict_SetItemString (dict, \"%s\",\n" name;
4280             pr "                          PyFloat_FromDouble ((double) %s->%s));\n"
4281             &n