Added Python documentation.
[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 "    return NULL;\n";
2398         pr "  }\n";
2399         pr "\n";
2400         pr "  free (err);\n";
2401         pr "\n";
2402         pr "  /* Tokenize each line of the output. */\n";
2403         pr "  p = out;\n";
2404         pr "  i = 0;\n";
2405         pr "  while (p) {\n";
2406         pr "    pend = strchr (p, '\\n');       /* Get the next line of output. */\n";
2407         pr "    if (pend) {\n";
2408         pr "      *pend = '\\0';\n";
2409         pr "      pend++;\n";
2410         pr "    }\n";
2411         pr "\n";
2412         pr "    while (*p && isspace (*p))      /* Skip any leading whitespace. */\n";
2413         pr "      p++;\n";
2414         pr "\n";
2415         pr "    if (!*p) {                      /* Empty line?  Skip it. */\n";
2416         pr "      p = pend;\n";
2417         pr "      continue;\n";
2418         pr "    }\n";
2419         pr "\n";
2420         pr "    /* Allocate some space to store this next entry. */\n";
2421         pr "    newp = realloc (ret->guestfs_lvm_int_%s_list_val,\n" typ;
2422         pr "                sizeof (guestfs_lvm_int_%s) * (i+1));\n" typ;
2423         pr "    if (newp == NULL) {\n";
2424         pr "      reply_with_perror (\"realloc\");\n";
2425         pr "      free (ret->guestfs_lvm_int_%s_list_val);\n" typ;
2426         pr "      free (ret);\n";
2427         pr "      free (out);\n";
2428         pr "      return NULL;\n";
2429         pr "    }\n";
2430         pr "    ret->guestfs_lvm_int_%s_list_val = newp;\n" typ;
2431         pr "\n";
2432         pr "    /* Tokenize the next entry. */\n";
2433         pr "    r = lvm_tokenize_%s (p, &ret->guestfs_lvm_int_%s_list_val[i]);\n" typ typ;
2434         pr "    if (r == -1) {\n";
2435         pr "      reply_with_error (\"failed to parse output of '%ss' command\");\n" typ;
2436         pr "      free (ret->guestfs_lvm_int_%s_list_val);\n" typ;
2437         pr "      free (ret);\n";
2438         pr "      free (out);\n";
2439         pr "      return NULL;\n";
2440         pr "    }\n";
2441         pr "\n";
2442         pr "    ++i;\n";
2443         pr "    p = pend;\n";
2444         pr "  }\n";
2445         pr "\n";
2446         pr "  ret->guestfs_lvm_int_%s_list_len = i;\n" typ;
2447         pr "\n";
2448         pr "  free (out);\n";
2449         pr "  return ret;\n";
2450         pr "}\n"
2451
2452   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols]
2453
2454 (* Generate the tests. *)
2455 and generate_tests () =
2456   generate_header CStyle GPLv2;
2457
2458   pr "\
2459 #include <stdio.h>
2460 #include <stdlib.h>
2461 #include <string.h>
2462 #include <unistd.h>
2463 #include <sys/types.h>
2464 #include <fcntl.h>
2465
2466 #include \"guestfs.h\"
2467
2468 static guestfs_h *g;
2469 static int suppress_error = 0;
2470
2471 static void print_error (guestfs_h *g, void *data, const char *msg)
2472 {
2473   if (!suppress_error)
2474     fprintf (stderr, \"%%s\\n\", msg);
2475 }
2476
2477 static void print_strings (char * const * const argv)
2478 {
2479   int argc;
2480
2481   for (argc = 0; argv[argc] != NULL; ++argc)
2482     printf (\"\\t%%s\\n\", argv[argc]);
2483 }
2484
2485 /*
2486 static void print_table (char * const * const argv)
2487 {
2488   int i;
2489
2490   for (i = 0; argv[i] != NULL; i += 2)
2491     printf (\"%%s: %%s\\n\", argv[i], argv[i+1]);
2492 }
2493 */
2494
2495 static void no_test_warnings (void)
2496 {
2497 ";
2498
2499   List.iter (
2500     function
2501     | name, _, _, _, [], _, _ ->
2502         pr "  fprintf (stderr, \"warning: \\\"guestfs_%s\\\" has no tests\\n\");\n" name
2503     | name, _, _, _, tests, _, _ -> ()
2504   ) all_functions;
2505
2506   pr "}\n";
2507   pr "\n";
2508
2509   (* Generate the actual tests.  Note that we generate the tests
2510    * in reverse order, deliberately, so that (in general) the
2511    * newest tests run first.  This makes it quicker and easier to
2512    * debug them.
2513    *)
2514   let test_names =
2515     List.map (
2516       fun (name, _, _, _, tests, _, _) ->
2517         mapi (generate_one_test name) tests
2518     ) (List.rev all_functions) in
2519   let test_names = List.concat test_names in
2520   let nr_tests = List.length test_names in
2521
2522   pr "\
2523 int main (int argc, char *argv[])
2524 {
2525   char c = 0;
2526   int failed = 0;
2527   const char *srcdir;
2528   int fd;
2529   char buf[256];
2530   int nr_tests, test_num = 0;
2531
2532   no_test_warnings ();
2533
2534   g = guestfs_create ();
2535   if (g == NULL) {
2536     printf (\"guestfs_create FAILED\\n\");
2537     exit (1);
2538   }
2539
2540   guestfs_set_error_handler (g, print_error, NULL);
2541
2542   srcdir = getenv (\"srcdir\");
2543   if (!srcdir) srcdir = \".\";
2544   guestfs_set_path (g, srcdir);
2545
2546   snprintf (buf, sizeof buf, \"%%s/test1.img\", srcdir);
2547   fd = open (buf, O_WRONLY|O_CREAT|O_NOCTTY|O_NONBLOCK|O_TRUNC, 0666);
2548   if (fd == -1) {
2549     perror (buf);
2550     exit (1);
2551   }
2552   if (lseek (fd, %d, SEEK_SET) == -1) {
2553     perror (\"lseek\");
2554     close (fd);
2555     unlink (buf);
2556     exit (1);
2557   }
2558   if (write (fd, &c, 1) == -1) {
2559     perror (\"write\");
2560     close (fd);
2561     unlink (buf);
2562     exit (1);
2563   }
2564   if (close (fd) == -1) {
2565     perror (buf);
2566     unlink (buf);
2567     exit (1);
2568   }
2569   if (guestfs_add_drive (g, buf) == -1) {
2570     printf (\"guestfs_add_drive %%s FAILED\\n\", buf);
2571     exit (1);
2572   }
2573
2574   snprintf (buf, sizeof buf, \"%%s/test2.img\", srcdir);
2575   fd = open (buf, O_WRONLY|O_CREAT|O_NOCTTY|O_NONBLOCK|O_TRUNC, 0666);
2576   if (fd == -1) {
2577     perror (buf);
2578     exit (1);
2579   }
2580   if (lseek (fd, %d, SEEK_SET) == -1) {
2581     perror (\"lseek\");
2582     close (fd);
2583     unlink (buf);
2584     exit (1);
2585   }
2586   if (write (fd, &c, 1) == -1) {
2587     perror (\"write\");
2588     close (fd);
2589     unlink (buf);
2590     exit (1);
2591   }
2592   if (close (fd) == -1) {
2593     perror (buf);
2594     unlink (buf);
2595     exit (1);
2596   }
2597   if (guestfs_add_drive (g, buf) == -1) {
2598     printf (\"guestfs_add_drive %%s FAILED\\n\", buf);
2599     exit (1);
2600   }
2601
2602   snprintf (buf, sizeof buf, \"%%s/test3.img\", srcdir);
2603   fd = open (buf, O_WRONLY|O_CREAT|O_NOCTTY|O_NONBLOCK|O_TRUNC, 0666);
2604   if (fd == -1) {
2605     perror (buf);
2606     exit (1);
2607   }
2608   if (lseek (fd, %d, SEEK_SET) == -1) {
2609     perror (\"lseek\");
2610     close (fd);
2611     unlink (buf);
2612     exit (1);
2613   }
2614   if (write (fd, &c, 1) == -1) {
2615     perror (\"write\");
2616     close (fd);
2617     unlink (buf);
2618     exit (1);
2619   }
2620   if (close (fd) == -1) {
2621     perror (buf);
2622     unlink (buf);
2623     exit (1);
2624   }
2625   if (guestfs_add_drive (g, buf) == -1) {
2626     printf (\"guestfs_add_drive %%s FAILED\\n\", buf);
2627     exit (1);
2628   }
2629
2630   if (guestfs_launch (g) == -1) {
2631     printf (\"guestfs_launch FAILED\\n\");
2632     exit (1);
2633   }
2634   if (guestfs_wait_ready (g) == -1) {
2635     printf (\"guestfs_wait_ready FAILED\\n\");
2636     exit (1);
2637   }
2638
2639   nr_tests = %d;
2640
2641 " (500 * 1024 * 1024) (50 * 1024 * 1024) (10 * 1024 * 1024) nr_tests;
2642
2643   iteri (
2644     fun i test_name ->
2645       pr "  test_num++;\n";
2646       pr "  printf (\"%%3d/%%3d %s\\n\", test_num, nr_tests);\n" test_name;
2647       pr "  if (%s () == -1) {\n" test_name;
2648       pr "    printf (\"%s FAILED\\n\");\n" test_name;
2649       pr "    failed++;\n";
2650       pr "  }\n";
2651   ) test_names;
2652   pr "\n";
2653
2654   pr "  guestfs_close (g);\n";
2655   pr "  snprintf (buf, sizeof buf, \"%%s/test1.img\", srcdir);\n";
2656   pr "  unlink (buf);\n";
2657   pr "  snprintf (buf, sizeof buf, \"%%s/test2.img\", srcdir);\n";
2658   pr "  unlink (buf);\n";
2659   pr "  snprintf (buf, sizeof buf, \"%%s/test3.img\", srcdir);\n";
2660   pr "  unlink (buf);\n";
2661   pr "\n";
2662
2663   pr "  if (failed > 0) {\n";
2664   pr "    printf (\"***** %%d / %%d tests FAILED *****\\n\", failed, nr_tests);\n";
2665   pr "    exit (1);\n";
2666   pr "  }\n";
2667   pr "\n";
2668
2669   pr "  exit (0);\n";
2670   pr "}\n"
2671
2672 and generate_one_test name i (init, test) =
2673   let test_name = sprintf "test_%s_%d" name i in
2674
2675   pr "static int %s (void)\n" test_name;
2676   pr "{\n";
2677
2678   (match init with
2679    | InitNone -> ()
2680    | InitEmpty ->
2681        pr "  /* InitEmpty for %s (%d) */\n" name i;
2682        List.iter (generate_test_command_call test_name)
2683          [["umount_all"];
2684           ["lvm_remove_all"]]
2685    | InitBasicFS ->
2686        pr "  /* InitBasicFS for %s (%d): create ext2 on /dev/sda1 */\n" name i;
2687        List.iter (generate_test_command_call test_name)
2688          [["umount_all"];
2689           ["lvm_remove_all"];
2690           ["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ","];
2691           ["mkfs"; "ext2"; "/dev/sda1"];
2692           ["mount"; "/dev/sda1"; "/"]]
2693    | InitBasicFSonLVM ->
2694        pr "  /* InitBasicFSonLVM for %s (%d): create ext2 on /dev/VG/LV */\n"
2695          name i;
2696        List.iter (generate_test_command_call test_name)
2697          [["umount_all"];
2698           ["lvm_remove_all"];
2699           ["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ","];
2700           ["pvcreate"; "/dev/sda1"];
2701           ["vgcreate"; "VG"; "/dev/sda1"];
2702           ["lvcreate"; "LV"; "VG"; "8"];
2703           ["mkfs"; "ext2"; "/dev/VG/LV"];
2704           ["mount"; "/dev/VG/LV"; "/"]]
2705   );
2706
2707   let get_seq_last = function
2708     | [] ->
2709         failwithf "%s: you cannot use [] (empty list) when expecting a command"
2710           test_name
2711     | seq ->
2712         let seq = List.rev seq in
2713         List.rev (List.tl seq), List.hd seq
2714   in
2715
2716   (match test with
2717    | TestRun seq ->
2718        pr "  /* TestRun for %s (%d) */\n" name i;
2719        List.iter (generate_test_command_call test_name) seq
2720    | TestOutput (seq, expected) ->
2721        pr "  /* TestOutput for %s (%d) */\n" name i;
2722        let seq, last = get_seq_last seq in
2723        let test () =
2724          pr "    if (strcmp (r, \"%s\") != 0) {\n" (c_quote expected);
2725          pr "      fprintf (stderr, \"%s: expected \\\"%s\\\" but got \\\"%%s\\\"\\n\", r);\n" test_name (c_quote expected);
2726          pr "      return -1;\n";
2727          pr "    }\n"
2728        in
2729        List.iter (generate_test_command_call test_name) seq;
2730        generate_test_command_call ~test test_name last
2731    | TestOutputList (seq, expected) ->
2732        pr "  /* TestOutputList for %s (%d) */\n" name i;
2733        let seq, last = get_seq_last seq in
2734        let test () =
2735          iteri (
2736            fun i str ->
2737              pr "    if (!r[%d]) {\n" i;
2738              pr "      fprintf (stderr, \"%s: short list returned from command\\n\");\n" test_name;
2739              pr "      print_strings (r);\n";
2740              pr "      return -1;\n";
2741              pr "    }\n";
2742              pr "    if (strcmp (r[%d], \"%s\") != 0) {\n" i (c_quote str);
2743              pr "      fprintf (stderr, \"%s: expected \\\"%s\\\" but got \\\"%%s\\\"\\n\", r[%d]);\n" test_name (c_quote str) i;
2744              pr "      return -1;\n";
2745              pr "    }\n"
2746          ) expected;
2747          pr "    if (r[%d] != NULL) {\n" (List.length expected);
2748          pr "      fprintf (stderr, \"%s: extra elements returned from command\\n\");\n"
2749            test_name;
2750          pr "      print_strings (r);\n";
2751          pr "      return -1;\n";
2752          pr "    }\n"
2753        in
2754        List.iter (generate_test_command_call test_name) seq;
2755        generate_test_command_call ~test test_name last
2756    | TestOutputInt (seq, expected) ->
2757        pr "  /* TestOutputInt for %s (%d) */\n" name i;
2758        let seq, last = get_seq_last seq in
2759        let test () =
2760          pr "    if (r != %d) {\n" expected;
2761          pr "      fprintf (stderr, \"%s: expected %d but got %%d\\n\","
2762            test_name expected;
2763          pr "               (int) r);\n";
2764          pr "      return -1;\n";
2765          pr "    }\n"
2766        in
2767        List.iter (generate_test_command_call test_name) seq;
2768        generate_test_command_call ~test test_name last
2769    | TestOutputTrue seq ->
2770        pr "  /* TestOutputTrue for %s (%d) */\n" name i;
2771        let seq, last = get_seq_last seq in
2772        let test () =
2773          pr "    if (!r) {\n";
2774          pr "      fprintf (stderr, \"%s: expected true, got false\\n\");\n"
2775            test_name;
2776          pr "      return -1;\n";
2777          pr "    }\n"
2778        in
2779        List.iter (generate_test_command_call test_name) seq;
2780        generate_test_command_call ~test test_name last
2781    | TestOutputFalse seq ->
2782        pr "  /* TestOutputFalse for %s (%d) */\n" name i;
2783        let seq, last = get_seq_last seq in
2784        let test () =
2785          pr "    if (r) {\n";
2786          pr "      fprintf (stderr, \"%s: expected false, got true\\n\");\n"
2787            test_name;
2788          pr "      return -1;\n";
2789          pr "    }\n"
2790        in
2791        List.iter (generate_test_command_call test_name) seq;
2792        generate_test_command_call ~test test_name last
2793    | TestOutputLength (seq, expected) ->
2794        pr "  /* TestOutputLength for %s (%d) */\n" name i;
2795        let seq, last = get_seq_last seq in
2796        let test () =
2797          pr "    int j;\n";
2798          pr "    for (j = 0; j < %d; ++j)\n" expected;
2799          pr "      if (r[j] == NULL) {\n";
2800          pr "        fprintf (stderr, \"%s: short list returned\\n\");\n"
2801            test_name;
2802          pr "        print_strings (r);\n";
2803          pr "        return -1;\n";
2804          pr "      }\n";
2805          pr "    if (r[j] != NULL) {\n";
2806          pr "      fprintf (stderr, \"%s: long list returned\\n\");\n"
2807            test_name;
2808          pr "      print_strings (r);\n";
2809          pr "      return -1;\n";
2810          pr "    }\n"
2811        in
2812        List.iter (generate_test_command_call test_name) seq;
2813        generate_test_command_call ~test test_name last
2814    | TestOutputStruct (seq, checks) ->
2815        pr "  /* TestOutputStruct for %s (%d) */\n" name i;
2816        let seq, last = get_seq_last seq in
2817        let test () =
2818          List.iter (
2819            function
2820            | CompareWithInt (field, expected) ->
2821                pr "    if (r->%s != %d) {\n" field expected;
2822                pr "      fprintf (stderr, \"%s: %s was %%d, expected %d\\n\",\n"
2823                  test_name field expected;
2824                pr "               (int) r->%s);\n" field;
2825                pr "      return -1;\n";
2826                pr "    }\n"
2827            | CompareWithString (field, expected) ->
2828                pr "    if (strcmp (r->%s, \"%s\") != 0) {\n" field expected;
2829                pr "      fprintf (stderr, \"%s: %s was \"%%s\", expected \"%s\"\\n\",\n"
2830                  test_name field expected;
2831                pr "               r->%s);\n" field;
2832                pr "      return -1;\n";
2833                pr "    }\n"
2834            | CompareFieldsIntEq (field1, field2) ->
2835                pr "    if (r->%s != r->%s) {\n" field1 field2;
2836                pr "      fprintf (stderr, \"%s: %s (%%d) <> %s (%%d)\\n\",\n"
2837                  test_name field1 field2;
2838                pr "               (int) r->%s, (int) r->%s);\n" field1 field2;
2839                pr "      return -1;\n";
2840                pr "    }\n"
2841            | CompareFieldsStrEq (field1, field2) ->
2842                pr "    if (strcmp (r->%s, r->%s) != 0) {\n" field1 field2;
2843                pr "      fprintf (stderr, \"%s: %s (\"%%s\") <> %s (\"%%s\")\\n\",\n"
2844                  test_name field1 field2;
2845                pr "               r->%s, r->%s);\n" field1 field2;
2846                pr "      return -1;\n";
2847                pr "    }\n"
2848          ) checks
2849        in
2850        List.iter (generate_test_command_call test_name) seq;
2851        generate_test_command_call ~test test_name last
2852    | TestLastFail seq ->
2853        pr "  /* TestLastFail for %s (%d) */\n" name i;
2854        let seq, last = get_seq_last seq in
2855        List.iter (generate_test_command_call test_name) seq;
2856        generate_test_command_call test_name ~expect_error:true last
2857   );
2858
2859   pr "  return 0;\n";
2860   pr "}\n";
2861   pr "\n";
2862   test_name
2863
2864 (* Generate the code to run a command, leaving the result in 'r'.
2865  * If you expect to get an error then you should set expect_error:true.
2866  *)
2867 and generate_test_command_call ?(expect_error = false) ?test test_name cmd =
2868   match cmd with
2869   | [] -> assert false
2870   | name :: args ->
2871       (* Look up the command to find out what args/ret it has. *)
2872       let style =
2873         try
2874           let _, style, _, _, _, _, _ =
2875             List.find (fun (n, _, _, _, _, _, _) -> n = name) all_functions in
2876           style
2877         with Not_found ->
2878           failwithf "%s: in test, command %s was not found" test_name name in
2879
2880       if List.length (snd style) <> List.length args then
2881         failwithf "%s: in test, wrong number of args given to %s"
2882           test_name name;
2883
2884       pr "  {\n";
2885
2886       List.iter (
2887         function
2888         | String _, _
2889         | OptString _, _
2890         | Int _, _
2891         | Bool _, _ -> ()
2892         | StringList n, arg ->
2893             pr "    char *%s[] = {\n" n;
2894             let strs = string_split " " arg in
2895             List.iter (
2896               fun str -> pr "      \"%s\",\n" (c_quote str)
2897             ) strs;
2898             pr "      NULL\n";
2899             pr "    };\n";
2900       ) (List.combine (snd style) args);
2901
2902       let error_code =
2903         match fst style with
2904         | RErr | RInt _ | RBool _ -> pr "    int r;\n"; "-1"
2905         | RInt64 _ -> pr "    int64_t r;\n"; "-1"
2906         | RConstString _ -> pr "    const char *r;\n"; "NULL"
2907         | RString _ -> pr "    char *r;\n"; "NULL"
2908         | RStringList _ | RHashtable _ ->
2909             pr "    char **r;\n";
2910             pr "    int i;\n";
2911             "NULL"
2912         | RIntBool _ ->
2913             pr "    struct guestfs_int_bool *r;\n"; "NULL"
2914         | RPVList _ ->
2915             pr "    struct guestfs_lvm_pv_list *r;\n"; "NULL"
2916         | RVGList _ ->
2917             pr "    struct guestfs_lvm_vg_list *r;\n"; "NULL"
2918         | RLVList _ ->
2919             pr "    struct guestfs_lvm_lv_list *r;\n"; "NULL"
2920         | RStat _ ->
2921             pr "    struct guestfs_stat *r;\n"; "NULL"
2922         | RStatVFS _ ->
2923             pr "    struct guestfs_statvfs *r;\n"; "NULL" in
2924
2925       pr "    suppress_error = %d;\n" (if expect_error then 1 else 0);
2926       pr "    r = guestfs_%s (g" name;
2927
2928       (* Generate the parameters. *)
2929       List.iter (
2930         function
2931         | String _, arg -> pr ", \"%s\"" (c_quote arg)
2932         | OptString _, arg ->
2933             if arg = "NULL" then pr ", NULL" else pr ", \"%s\"" (c_quote arg)
2934         | StringList n, _ ->
2935             pr ", %s" n
2936         | Int _, arg ->
2937             let i =
2938               try int_of_string arg
2939               with Failure "int_of_string" ->
2940                 failwithf "%s: expecting an int, but got '%s'" test_name arg in
2941             pr ", %d" i
2942         | Bool _, arg ->
2943             let b = bool_of_string arg in pr ", %d" (if b then 1 else 0)
2944       ) (List.combine (snd style) args);
2945
2946       pr ");\n";
2947       if not expect_error then
2948         pr "    if (r == %s)\n" error_code
2949       else
2950         pr "    if (r != %s)\n" error_code;
2951       pr "      return -1;\n";
2952
2953       (* Insert the test code. *)
2954       (match test with
2955        | None -> ()
2956        | Some f -> f ()
2957       );
2958
2959       (match fst style with
2960        | RErr | RInt _ | RInt64 _ | RBool _ | RConstString _ -> ()
2961        | RString _ -> pr "    free (r);\n"
2962        | RStringList _ | RHashtable _ ->
2963            pr "    for (i = 0; r[i] != NULL; ++i)\n";
2964            pr "      free (r[i]);\n";
2965            pr "    free (r);\n"
2966        | RIntBool _ ->
2967            pr "    guestfs_free_int_bool (r);\n"
2968        | RPVList _ ->
2969            pr "    guestfs_free_lvm_pv_list (r);\n"
2970        | RVGList _ ->
2971            pr "    guestfs_free_lvm_vg_list (r);\n"
2972        | RLVList _ ->
2973            pr "    guestfs_free_lvm_lv_list (r);\n"
2974        | RStat _ | RStatVFS _ ->
2975            pr "    free (r);\n"
2976       );
2977
2978       pr "  }\n"
2979
2980 and c_quote str =
2981   let str = replace_str str "\r" "\\r" in
2982   let str = replace_str str "\n" "\\n" in
2983   let str = replace_str str "\t" "\\t" in
2984   str
2985
2986 (* Generate a lot of different functions for guestfish. *)
2987 and generate_fish_cmds () =
2988   generate_header CStyle GPLv2;
2989
2990   let all_functions =
2991     List.filter (
2992       fun (_, _, _, flags, _, _, _) -> not (List.mem NotInFish flags)
2993     ) all_functions in
2994   let all_functions_sorted =
2995     List.filter (
2996       fun (_, _, _, flags, _, _, _) -> not (List.mem NotInFish flags)
2997     ) all_functions_sorted in
2998
2999   pr "#include <stdio.h>\n";
3000   pr "#include <stdlib.h>\n";
3001   pr "#include <string.h>\n";
3002   pr "#include <inttypes.h>\n";
3003   pr "\n";
3004   pr "#include <guestfs.h>\n";
3005   pr "#include \"fish.h\"\n";
3006   pr "\n";
3007
3008   (* list_commands function, which implements guestfish -h *)
3009   pr "void list_commands (void)\n";
3010   pr "{\n";
3011   pr "  printf (\"    %%-16s     %%s\\n\", \"Command\", \"Description\");\n";
3012   pr "  list_builtin_commands ();\n";
3013   List.iter (
3014     fun (name, _, _, flags, _, shortdesc, _) ->
3015       let name = replace_char name '_' '-' in
3016       pr "  printf (\"%%-20s %%s\\n\", \"%s\", \"%s\");\n"
3017         name shortdesc
3018   ) all_functions_sorted;
3019   pr "  printf (\"    Use -h <cmd> / help <cmd> to show detailed help for a command.\\n\");\n";
3020   pr "}\n";
3021   pr "\n";
3022
3023   (* display_command function, which implements guestfish -h cmd *)
3024   pr "void display_command (const char *cmd)\n";
3025   pr "{\n";
3026   List.iter (
3027     fun (name, style, _, flags, _, shortdesc, longdesc) ->
3028       let name2 = replace_char name '_' '-' in
3029       let alias =
3030         try find_map (function FishAlias n -> Some n | _ -> None) flags
3031         with Not_found -> name in
3032       let longdesc = replace_str longdesc "C<guestfs_" "C<" in
3033       let synopsis =
3034         match snd style with
3035         | [] -> name2
3036         | args ->
3037             sprintf "%s <%s>"
3038               name2 (String.concat "> <" (List.map name_of_argt args)) in
3039
3040       let warnings =
3041         if List.mem ProtocolLimitWarning flags then
3042           ("\n\n" ^ protocol_limit_warning)
3043         else "" in
3044
3045       (* For DangerWillRobinson commands, we should probably have
3046        * guestfish prompt before allowing you to use them (especially
3047        * in interactive mode). XXX
3048        *)
3049       let warnings =
3050         warnings ^
3051           if List.mem DangerWillRobinson flags then
3052             ("\n\n" ^ danger_will_robinson)
3053           else "" in
3054
3055       let describe_alias =
3056         if name <> alias then
3057           sprintf "\n\nYou can use '%s' as an alias for this command." alias
3058         else "" in
3059
3060       pr "  if (";
3061       pr "strcasecmp (cmd, \"%s\") == 0" name;
3062       if name <> name2 then
3063         pr " || strcasecmp (cmd, \"%s\") == 0" name2;
3064       if name <> alias then
3065         pr " || strcasecmp (cmd, \"%s\") == 0" alias;
3066       pr ")\n";
3067       pr "    pod2text (\"%s - %s\", %S);\n"
3068         name2 shortdesc
3069         (" " ^ synopsis ^ "\n\n" ^ longdesc ^ warnings ^ describe_alias);
3070       pr "  else\n"
3071   ) all_functions;
3072   pr "    display_builtin_command (cmd);\n";
3073   pr "}\n";
3074   pr "\n";
3075
3076   (* print_{pv,vg,lv}_list functions *)
3077   List.iter (
3078     function
3079     | typ, cols ->
3080         pr "static void print_%s (struct guestfs_lvm_%s *%s)\n" typ typ typ;
3081         pr "{\n";
3082         pr "  int i;\n";
3083         pr "\n";
3084         List.iter (
3085           function
3086           | name, `String ->
3087               pr "  printf (\"%s: %%s\\n\", %s->%s);\n" name typ name
3088           | name, `UUID ->
3089               pr "  printf (\"%s: \");\n" name;
3090               pr "  for (i = 0; i < 32; ++i)\n";
3091               pr "    printf (\"%%c\", %s->%s[i]);\n" typ name;
3092               pr "  printf (\"\\n\");\n"
3093           | name, `Bytes ->
3094               pr "  printf (\"%s: %%\" PRIu64 \"\\n\", %s->%s);\n" name typ name
3095           | name, `Int ->
3096               pr "  printf (\"%s: %%\" PRIi64 \"\\n\", %s->%s);\n" name typ name
3097           | name, `OptPercent ->
3098               pr "  if (%s->%s >= 0) printf (\"%s: %%g %%%%\\n\", %s->%s);\n"
3099                 typ name name typ name;
3100               pr "  else printf (\"%s: \\n\");\n" name
3101         ) cols;
3102         pr "}\n";
3103         pr "\n";
3104         pr "static void print_%s_list (struct guestfs_lvm_%s_list *%ss)\n"
3105           typ typ typ;
3106         pr "{\n";
3107         pr "  int i;\n";
3108         pr "\n";
3109         pr "  for (i = 0; i < %ss->len; ++i)\n" typ;
3110         pr "    print_%s (&%ss->val[i]);\n" typ typ;
3111         pr "}\n";
3112         pr "\n";
3113   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols];
3114
3115   (* print_{stat,statvfs} functions *)
3116   List.iter (
3117     function
3118     | typ, cols ->
3119         pr "static void print_%s (struct guestfs_%s *%s)\n" typ typ typ;
3120         pr "{\n";
3121         List.iter (
3122           function
3123           | name, `Int ->
3124               pr "  printf (\"%s: %%\" PRIi64 \"\\n\", %s->%s);\n" name typ name
3125         ) cols;
3126         pr "}\n";
3127         pr "\n";
3128   ) ["stat", stat_cols; "statvfs", statvfs_cols];
3129
3130   (* run_<action> actions *)
3131   List.iter (
3132     fun (name, style, _, flags, _, _, _) ->
3133       pr "static int run_%s (const char *cmd, int argc, char *argv[])\n" name;
3134       pr "{\n";
3135       (match fst style with
3136        | RErr
3137        | RInt _
3138        | RBool _ -> pr "  int r;\n"
3139        | RInt64 _ -> pr "  int64_t r;\n"
3140        | RConstString _ -> pr "  const char *r;\n"
3141        | RString _ -> pr "  char *r;\n"
3142        | RStringList _ | RHashtable _ -> pr "  char **r;\n"
3143        | RIntBool _ -> pr "  struct guestfs_int_bool *r;\n"
3144        | RPVList _ -> pr "  struct guestfs_lvm_pv_list *r;\n"
3145        | RVGList _ -> pr "  struct guestfs_lvm_vg_list *r;\n"
3146        | RLVList _ -> pr "  struct guestfs_lvm_lv_list *r;\n"
3147        | RStat _ -> pr "  struct guestfs_stat *r;\n"
3148        | RStatVFS _ -> pr "  struct guestfs_statvfs *r;\n"
3149       );
3150       List.iter (
3151         function
3152         | String n
3153         | OptString n -> pr "  const char *%s;\n" n
3154         | StringList n -> pr "  char **%s;\n" n
3155         | Bool n -> pr "  int %s;\n" n
3156         | Int n -> pr "  int %s;\n" n
3157       ) (snd style);
3158
3159       (* Check and convert parameters. *)
3160       let argc_expected = List.length (snd style) in
3161       pr "  if (argc != %d) {\n" argc_expected;
3162       pr "    fprintf (stderr, \"%%s should have %d parameter(s)\\n\", cmd);\n"
3163         argc_expected;
3164       pr "    fprintf (stderr, \"type 'help %%s' for help on %%s\\n\", cmd, cmd);\n";
3165       pr "    return -1;\n";
3166       pr "  }\n";
3167       iteri (
3168         fun i ->
3169           function
3170           | String name -> pr "  %s = argv[%d];\n" name i
3171           | OptString name ->
3172               pr "  %s = strcmp (argv[%d], \"\") != 0 ? argv[%d] : NULL;\n"
3173                 name i i
3174           | StringList name ->
3175               pr "  %s = parse_string_list (argv[%d]);\n" name i
3176           | Bool name ->
3177               pr "  %s = is_true (argv[%d]) ? 1 : 0;\n" name i
3178           | Int name ->
3179               pr "  %s = atoi (argv[%d]);\n" name i
3180       ) (snd style);
3181
3182       (* Call C API function. *)
3183       let fn =
3184         try find_map (function FishAction n -> Some n | _ -> None) flags
3185         with Not_found -> sprintf "guestfs_%s" name in
3186       pr "  r = %s " fn;
3187       generate_call_args ~handle:"g" style;
3188       pr ";\n";
3189
3190       (* Check return value for errors and display command results. *)
3191       (match fst style with
3192        | RErr -> pr "  return r;\n"
3193        | RInt _ ->
3194            pr "  if (r == -1) return -1;\n";
3195            pr "  printf (\"%%d\\n\", r);\n";
3196            pr "  return 0;\n"
3197        | RInt64 _ ->
3198            pr "  if (r == -1) return -1;\n";
3199            pr "  printf (\"%%\" PRIi64 \"\\n\", r);\n";
3200            pr "  return 0;\n"
3201        | RBool _ ->
3202            pr "  if (r == -1) return -1;\n";
3203            pr "  if (r) printf (\"true\\n\"); else printf (\"false\\n\");\n";
3204            pr "  return 0;\n"
3205        | RConstString _ ->
3206            pr "  if (r == NULL) return -1;\n";
3207            pr "  printf (\"%%s\\n\", r);\n";
3208            pr "  return 0;\n"
3209        | RString _ ->
3210            pr "  if (r == NULL) return -1;\n";
3211            pr "  printf (\"%%s\\n\", r);\n";
3212            pr "  free (r);\n";
3213            pr "  return 0;\n"
3214        | RStringList _ ->
3215            pr "  if (r == NULL) return -1;\n";
3216            pr "  print_strings (r);\n";
3217            pr "  free_strings (r);\n";
3218            pr "  return 0;\n"
3219        | RIntBool _ ->
3220            pr "  if (r == NULL) return -1;\n";
3221            pr "  printf (\"%%d, %%s\\n\", r->i,\n";
3222            pr "    r->b ? \"true\" : \"false\");\n";
3223            pr "  guestfs_free_int_bool (r);\n";
3224            pr "  return 0;\n"
3225        | RPVList _ ->
3226            pr "  if (r == NULL) return -1;\n";
3227            pr "  print_pv_list (r);\n";
3228            pr "  guestfs_free_lvm_pv_list (r);\n";
3229            pr "  return 0;\n"
3230        | RVGList _ ->
3231            pr "  if (r == NULL) return -1;\n";
3232            pr "  print_vg_list (r);\n";
3233            pr "  guestfs_free_lvm_vg_list (r);\n";
3234            pr "  return 0;\n"
3235        | RLVList _ ->
3236            pr "  if (r == NULL) return -1;\n";
3237            pr "  print_lv_list (r);\n";
3238            pr "  guestfs_free_lvm_lv_list (r);\n";
3239            pr "  return 0;\n"
3240        | RStat _ ->
3241            pr "  if (r == NULL) return -1;\n";
3242            pr "  print_stat (r);\n";
3243            pr "  free (r);\n";
3244            pr "  return 0;\n"
3245        | RStatVFS _ ->
3246            pr "  if (r == NULL) return -1;\n";
3247            pr "  print_statvfs (r);\n";
3248            pr "  free (r);\n";
3249            pr "  return 0;\n"
3250        | RHashtable _ ->
3251            pr "  if (r == NULL) return -1;\n";
3252            pr "  print_table (r);\n";
3253            pr "  free_strings (r);\n";
3254            pr "  return 0;\n"
3255       );
3256       pr "}\n";
3257       pr "\n"
3258   ) all_functions;
3259
3260   (* run_action function *)
3261   pr "int run_action (const char *cmd, int argc, char *argv[])\n";
3262   pr "{\n";
3263   List.iter (
3264     fun (name, _, _, flags, _, _, _) ->
3265       let name2 = replace_char name '_' '-' in
3266       let alias =
3267         try find_map (function FishAlias n -> Some n | _ -> None) flags
3268         with Not_found -> name in
3269       pr "  if (";
3270       pr "strcasecmp (cmd, \"%s\") == 0" name;
3271       if name <> name2 then
3272         pr " || strcasecmp (cmd, \"%s\") == 0" name2;
3273       if name <> alias then
3274         pr " || strcasecmp (cmd, \"%s\") == 0" alias;
3275       pr ")\n";
3276       pr "    return run_%s (cmd, argc, argv);\n" name;
3277       pr "  else\n";
3278   ) all_functions;
3279   pr "    {\n";
3280   pr "      fprintf (stderr, \"%%s: unknown command\\n\", cmd);\n";
3281   pr "      return -1;\n";
3282   pr "    }\n";
3283   pr "  return 0;\n";
3284   pr "}\n";
3285   pr "\n"
3286
3287 (* Readline completion for guestfish. *)
3288 and generate_fish_completion () =
3289   generate_header CStyle GPLv2;
3290
3291   let all_functions =
3292     List.filter (
3293       fun (_, _, _, flags, _, _, _) -> not (List.mem NotInFish flags)
3294     ) all_functions in
3295
3296   pr "\
3297 #include <config.h>
3298
3299 #include <stdio.h>
3300 #include <stdlib.h>
3301 #include <string.h>
3302
3303 #ifdef HAVE_LIBREADLINE
3304 #include <readline/readline.h>
3305 #endif
3306
3307 #include \"fish.h\"
3308
3309 #ifdef HAVE_LIBREADLINE
3310
3311 static const char *commands[] = {
3312 ";
3313
3314   (* Get the commands and sort them, including the aliases. *)
3315   let commands =
3316     List.map (
3317       fun (name, _, _, flags, _, _, _) ->
3318         let name2 = replace_char name '_' '-' in
3319         let alias =
3320           try find_map (function FishAlias n -> Some n | _ -> None) flags
3321           with Not_found -> name in
3322
3323         if name <> alias then [name2; alias] else [name2]
3324     ) all_functions in
3325   let commands = List.flatten commands in
3326   let commands = List.sort compare commands in
3327
3328   List.iter (pr "  \"%s\",\n") commands;
3329
3330   pr "  NULL
3331 };
3332
3333 static char *
3334 generator (const char *text, int state)
3335 {
3336   static int index, len;
3337   const char *name;
3338
3339   if (!state) {
3340     index = 0;
3341     len = strlen (text);
3342   }
3343
3344   while ((name = commands[index]) != NULL) {
3345     index++;
3346     if (strncasecmp (name, text, len) == 0)
3347       return strdup (name);
3348   }
3349
3350   return NULL;
3351 }
3352
3353 #endif /* HAVE_LIBREADLINE */
3354
3355 char **do_completion (const char *text, int start, int end)
3356 {
3357   char **matches = NULL;
3358
3359 #ifdef HAVE_LIBREADLINE
3360   if (start == 0)
3361     matches = rl_completion_matches (text, generator);
3362 #endif
3363
3364   return matches;
3365 }
3366 ";
3367
3368 (* Generate the POD documentation for guestfish. *)
3369 and generate_fish_actions_pod () =
3370   let all_functions_sorted =
3371     List.filter (
3372       fun (_, _, _, flags, _, _, _) -> not (List.mem NotInFish flags)
3373     ) all_functions_sorted in
3374
3375   List.iter (
3376     fun (name, style, _, flags, _, _, longdesc) ->
3377       let longdesc = replace_str longdesc "C<guestfs_" "C<" in
3378       let name = replace_char name '_' '-' in
3379       let alias =
3380         try find_map (function FishAlias n -> Some n | _ -> None) flags
3381         with Not_found -> name in
3382
3383       pr "=head2 %s" name;
3384       if name <> alias then
3385         pr " | %s" alias;
3386       pr "\n";
3387       pr "\n";
3388       pr " %s" name;
3389       List.iter (
3390         function
3391         | String n -> pr " %s" n
3392         | OptString n -> pr " %s" n
3393         | StringList n -> pr " %s,..." n
3394         | Bool _ -> pr " true|false"
3395         | Int n -> pr " %s" n
3396       ) (snd style);
3397       pr "\n";
3398       pr "\n";
3399       pr "%s\n\n" longdesc;
3400
3401       if List.mem ProtocolLimitWarning flags then
3402         pr "%s\n\n" protocol_limit_warning;
3403
3404       if List.mem DangerWillRobinson flags then
3405         pr "%s\n\n" danger_will_robinson
3406   ) all_functions_sorted
3407
3408 (* Generate a C function prototype. *)
3409 and generate_prototype ?(extern = true) ?(static = false) ?(semicolon = true)
3410     ?(single_line = false) ?(newline = false) ?(in_daemon = false)
3411     ?(prefix = "")
3412     ?handle name style =
3413   if extern then pr "extern ";
3414   if static then pr "static ";
3415   (match fst style with
3416    | RErr -> pr "int "
3417    | RInt _ -> pr "int "
3418    | RInt64 _ -> pr "int64_t "
3419    | RBool _ -> pr "int "
3420    | RConstString _ -> pr "const char *"
3421    | RString _ -> pr "char *"
3422    | RStringList _ | RHashtable _ -> pr "char **"
3423    | RIntBool _ ->
3424        if not in_daemon then pr "struct guestfs_int_bool *"
3425        else pr "guestfs_%s_ret *" name
3426    | RPVList _ ->
3427        if not in_daemon then pr "struct guestfs_lvm_pv_list *"
3428        else pr "guestfs_lvm_int_pv_list *"
3429    | RVGList _ ->
3430        if not in_daemon then pr "struct guestfs_lvm_vg_list *"
3431        else pr "guestfs_lvm_int_vg_list *"
3432    | RLVList _ ->
3433        if not in_daemon then pr "struct guestfs_lvm_lv_list *"
3434        else pr "guestfs_lvm_int_lv_list *"
3435    | RStat _ ->
3436        if not in_daemon then pr "struct guestfs_stat *"
3437        else pr "guestfs_int_stat *"
3438    | RStatVFS _ ->
3439        if not in_daemon then pr "struct guestfs_statvfs *"
3440        else pr "guestfs_int_statvfs *"
3441   );
3442   pr "%s%s (" prefix name;
3443   if handle = None && List.length (snd style) = 0 then
3444     pr "void"
3445   else (
3446     let comma = ref false in
3447     (match handle with
3448      | None -> ()
3449      | Some handle -> pr "guestfs_h *%s" handle; comma := true
3450     );
3451     let next () =
3452       if !comma then (
3453         if single_line then pr ", " else pr ",\n\t\t"
3454       );
3455       comma := true
3456     in
3457     List.iter (
3458       function
3459       | String n -> next (); pr "const char *%s" n
3460       | OptString n -> next (); pr "const char *%s" n
3461       | StringList n -> next (); pr "char * const* const %s" n
3462       | Bool n -> next (); pr "int %s" n
3463       | Int n -> next (); pr "int %s" n
3464     ) (snd style);
3465   );
3466   pr ")";
3467   if semicolon then pr ";";
3468   if newline then pr "\n"
3469
3470 (* Generate C call arguments, eg "(handle, foo, bar)" *)
3471 and generate_call_args ?handle style =
3472   pr "(";
3473   let comma = ref false in
3474   (match handle with
3475    | None -> ()
3476    | Some handle -> pr "%s" handle; comma := true
3477   );
3478   List.iter (
3479     fun arg ->
3480       if !comma then pr ", ";
3481       comma := true;
3482       match arg with
3483       | String n
3484       | OptString n
3485       | StringList n
3486       | Bool n
3487       | Int n -> pr "%s" n
3488   ) (snd style);
3489   pr ")"
3490
3491 (* Generate the OCaml bindings interface. *)
3492 and generate_ocaml_mli () =
3493   generate_header OCamlStyle LGPLv2;
3494
3495   pr "\
3496 (** For API documentation you should refer to the C API
3497     in the guestfs(3) manual page.  The OCaml API uses almost
3498     exactly the same calls. *)
3499
3500 type t
3501 (** A [guestfs_h] handle. *)
3502
3503 exception Error of string
3504 (** This exception is raised when there is an error. *)
3505
3506 val create : unit -> t
3507
3508 val close : t -> unit
3509 (** Handles are closed by the garbage collector when they become
3510     unreferenced, but callers can also call this in order to
3511     provide predictable cleanup. *)
3512
3513 ";
3514   generate_ocaml_lvm_structure_decls ();
3515
3516   generate_ocaml_stat_structure_decls ();
3517
3518   (* The actions. *)
3519   List.iter (
3520     fun (name, style, _, _, _, shortdesc, _) ->
3521       generate_ocaml_prototype name style;
3522       pr "(** %s *)\n" shortdesc;
3523       pr "\n"
3524   ) all_functions
3525
3526 (* Generate the OCaml bindings implementation. *)
3527 and generate_ocaml_ml () =
3528   generate_header OCamlStyle LGPLv2;
3529
3530   pr "\
3531 type t
3532 exception Error of string
3533 external create : unit -> t = \"ocaml_guestfs_create\"
3534 external close : t -> unit = \"ocaml_guestfs_close\"
3535
3536 let () =
3537   Callback.register_exception \"ocaml_guestfs_error\" (Error \"\")
3538
3539 ";
3540
3541   generate_ocaml_lvm_structure_decls ();
3542
3543   generate_ocaml_stat_structure_decls ();
3544
3545   (* The actions. *)
3546   List.iter (
3547     fun (name, style, _, _, _, shortdesc, _) ->
3548       generate_ocaml_prototype ~is_external:true name style;
3549   ) all_functions
3550
3551 (* Generate the OCaml bindings C implementation. *)
3552 and generate_ocaml_c () =
3553   generate_header CStyle LGPLv2;
3554
3555   pr "\
3556 #include <stdio.h>
3557 #include <stdlib.h>
3558 #include <string.h>
3559
3560 #include <caml/config.h>
3561 #include <caml/alloc.h>
3562 #include <caml/callback.h>
3563 #include <caml/fail.h>
3564 #include <caml/memory.h>
3565 #include <caml/mlvalues.h>
3566 #include <caml/signals.h>
3567
3568 #include <guestfs.h>
3569
3570 #include \"guestfs_c.h\"
3571
3572 /* Copy a hashtable of string pairs into an assoc-list.  We return
3573  * the list in reverse order, but hashtables aren't supposed to be
3574  * ordered anyway.
3575  */
3576 static CAMLprim value
3577 copy_table (char * const * argv)
3578 {
3579   CAMLparam0 ();
3580   CAMLlocal5 (rv, pairv, kv, vv, cons);
3581   int i;
3582
3583   rv = Val_int (0);
3584   for (i = 0; argv[i] != NULL; i += 2) {
3585     kv = caml_copy_string (argv[i]);
3586     vv = caml_copy_string (argv[i+1]);
3587     pairv = caml_alloc (2, 0);
3588     Store_field (pairv, 0, kv);
3589     Store_field (pairv, 1, vv);
3590     cons = caml_alloc (2, 0);
3591     Store_field (cons, 1, rv);
3592     rv = cons;
3593     Store_field (cons, 0, pairv);
3594   }
3595
3596   CAMLreturn (rv);
3597 }
3598
3599 ";
3600
3601   (* LVM struct copy functions. *)
3602   List.iter (
3603     fun (typ, cols) ->
3604       let has_optpercent_col =
3605         List.exists (function (_, `OptPercent) -> true | _ -> false) cols in
3606
3607       pr "static CAMLprim value\n";
3608       pr "copy_lvm_%s (const struct guestfs_lvm_%s *%s)\n" typ typ typ;
3609       pr "{\n";
3610       pr "  CAMLparam0 ();\n";
3611       if has_optpercent_col then
3612         pr "  CAMLlocal3 (rv, v, v2);\n"
3613       else
3614         pr "  CAMLlocal2 (rv, v);\n";
3615       pr "\n";
3616       pr "  rv = caml_alloc (%d, 0);\n" (List.length cols);
3617       iteri (
3618         fun i col ->
3619           (match col with
3620            | name, `String ->
3621                pr "  v = caml_copy_string (%s->%s);\n" typ name
3622            | name, `UUID ->
3623                pr "  v = caml_alloc_string (32);\n";
3624                pr "  memcpy (String_val (v), %s->%s, 32);\n" typ name
3625            | name, `Bytes
3626            | name, `Int ->
3627                pr "  v = caml_copy_int64 (%s->%s);\n" typ name
3628            | name, `OptPercent ->
3629                pr "  if (%s->%s >= 0) { /* Some %s */\n" typ name name;