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