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