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