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