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