3 * Copyright (C) 2009 Red Hat Inc.
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.
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.
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
20 (* This script generates a large amount of code and documentation for
21 * all the daemon actions.
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.
27 * After editing this file, run it (./src/generator.ml) to regenerate
28 * all the output files.
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]
39 type style = ret * args
41 (* "RErr" as a return value means an int used as a simple error
42 * indication, ie. 0 or -1.
45 (* "RInt" as a return value means an int which is -1 for error
46 * or any value >= 0 on success.
49 (* "RBool" is a bool return value which can be true/false or
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.
58 | RConstString of string
59 (* "RString" and "RStringList" are caller-frees. *)
61 | RStringList of string
62 (* Some limited tuples are possible: *)
63 | RIntBool of string * string
64 (* LVM PVs, VGs and LVs. *)
68 and args = argt list (* Function parameters, guestfs handle is implicit. *)
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.
78 | String of string (* const char *name, cannot be NULL *)
79 | OptString of string (* const char *name, may be NULL *)
80 | Bool of string (* boolean *)
81 | Int of string (* int (smallish ints, signed, <= 31 bits) *)
84 | ProtocolLimitWarning (* display warning about protocol size limits *)
85 | FishAlias of string (* provide an alias for this cmd in guestfish *)
86 | FishAction of string (* call this function in guestfish *)
87 | NotInFish (* do not export via guestfish *)
89 (* You can supply zero or as many tests as you want per API call.
91 * Note that the test environment has 3 block devices, of size 10M, 20M
92 * and 30M (respectively /dev/sda, /dev/sdb, /dev/sdc). To run the
93 * tests in a reasonable amount of time, the virtual machine and
94 * block devices are reused between tests. So don't try testing
97 * Don't assume anything about the previous contents of the block
98 * devices. Use 'Init*' to create some initial scenarios.
100 type tests = test list
102 (* Run the command sequence and just expect nothing to fail. *)
103 | TestRun of test_init * seq
104 (* Run the command sequence and expect the output of the final
105 * command to be the string.
107 | TestOutput of test_init * seq * string
108 (* Run the command sequence and expect the output of the final
109 * command to be the list of strings.
111 | TestOutputList of test_init * seq * string list
112 (* Run the command sequence and expect the output of the final
113 * command to be the integer.
115 | TestOutputInt of test_init * seq * int
116 (* Run the command sequence and expect the output of the final
117 * command to be a true value (!= 0 or != NULL).
119 | TestOutputTrue of test_init * seq
120 (* Run the command sequence and expect the output of the final
121 * command to be a false value (== 0 or == NULL, but not an error).
123 | TestOutputFalse of test_init * seq
124 (* Run the command sequence and expect the output of the final
125 * command to be a list of the given length (but don't care about
128 | TestOutputLength of test_init * seq * int
129 (* Run the command sequence and expect the final command (only)
132 | TestLastFail of test_init * seq
134 (* Some initial scenarios for testing. *)
136 (* Do nothing, block devices could contain random stuff. *)
138 (* /dev/sda contains a single partition /dev/sda1, which is formatted
139 * as ext2, empty [except for lost+found] and mounted on /.
140 * /dev/sdb and /dev/sdc may have random content.
145 * /dev/sda1 (is a PV):
147 * formatted as ext2, empty [except for lost+found], mounted on /
148 * /dev/sdb and /dev/sdc may have random content.
152 (* Sequence of commands for testing. *)
154 and cmd = string list
156 (* Note about long descriptions: When referring to another
157 * action, use the format C<guestfs_other> (ie. the full name of
158 * the C function). This will be replaced as appropriate in other
161 * Apart from that, long descriptions are just perldoc paragraphs.
164 let non_daemon_functions = [
165 ("launch", (RErr, []), -1, [FishAlias "run"; FishAction "launch"],
167 "launch the qemu subprocess",
169 Internally libguestfs is implemented by running a virtual machine
172 You should call this after configuring the handle
173 (eg. adding drives) but before performing any actions.");
175 ("wait_ready", (RErr, []), -1, [NotInFish],
177 "wait until the qemu subprocess launches",
179 Internally libguestfs is implemented by running a virtual machine
182 You should call this after C<guestfs_launch> to wait for the launch
185 ("kill_subprocess", (RErr, []), -1, [],
187 "kill the qemu subprocess",
189 This kills the qemu subprocess. You should never need to call this.");
191 ("add_drive", (RErr, [String "filename"]), -1, [FishAlias "add"],
193 "add an image to examine or modify",
195 This function adds a virtual machine disk image C<filename> to the
196 guest. The first time you call this function, the disk appears as IDE
197 disk 0 (C</dev/sda>) in the guest, the second time as C</dev/sdb>, and
200 You don't necessarily need to be root when using libguestfs. However
201 you obviously do need sufficient permissions to access the filename
202 for whatever operations you want to perform (ie. read access if you
203 just want to read the image or write access if you want to modify the
206 This is equivalent to the qemu parameter C<-drive file=filename>.");
208 ("add_cdrom", (RErr, [String "filename"]), -1, [FishAlias "cdrom"],
210 "add a CD-ROM disk image to examine",
212 This function adds a virtual CD-ROM disk image to the guest.
214 This is equivalent to the qemu parameter C<-cdrom filename>.");
216 ("config", (RErr, [String "qemuparam"; OptString "qemuvalue"]), -1, [],
218 "add qemu parameters",
220 This can be used to add arbitrary qemu command line parameters
221 of the form C<-param value>. Actually it's not quite arbitrary - we
222 prevent you from setting some parameters which would interfere with
223 parameters that we use.
225 The first character of C<param> string must be a C<-> (dash).
227 C<value> can be NULL.");
229 ("set_path", (RErr, [String "path"]), -1, [FishAlias "path"],
231 "set the search path",
233 Set the path that libguestfs searches for kernel and initrd.img.
235 The default is C<$libdir/guestfs> unless overridden by setting
236 C<LIBGUESTFS_PATH> environment variable.
238 The string C<path> is stashed in the libguestfs handle, so the caller
239 must make sure it remains valid for the lifetime of the handle.
241 Setting C<path> to C<NULL> restores the default path.");
243 ("get_path", (RConstString "path", []), -1, [],
245 "get the search path",
247 Return the current search path.
249 This is always non-NULL. If it wasn't set already, then this will
250 return the default path.");
252 ("set_autosync", (RErr, [Bool "autosync"]), -1, [FishAlias "autosync"],
256 If C<autosync> is true, this enables autosync. Libguestfs will make a
257 best effort attempt to run C<guestfs_sync> when the handle is closed
258 (also if the program exits without closing handles).");
260 ("get_autosync", (RBool "autosync", []), -1, [],
264 Get the autosync flag.");
266 ("set_verbose", (RErr, [Bool "verbose"]), -1, [FishAlias "verbose"],
270 If C<verbose> is true, this turns on verbose messages (to C<stderr>).
272 Verbose messages are disabled unless the environment variable
273 C<LIBGUESTFS_DEBUG> is defined and set to C<1>.");
275 ("get_verbose", (RBool "verbose", []), -1, [],
279 This returns the verbose messages flag.")
282 let daemon_functions = [
283 ("mount", (RErr, [String "device"; String "mountpoint"]), 1, [],
287 ["mkfs"; "ext2"; "/dev/sda1"];
288 ["mount"; "/dev/sda1"; "/"];
289 ["write_file"; "/new"; "new file contents"; "0"];
290 ["cat"; "/new"]], "new file contents")],
291 "mount a guest disk at a position in the filesystem",
293 Mount a guest disk at a position in the filesystem. Block devices
294 are named C</dev/sda>, C</dev/sdb> and so on, as they were added to
295 the guest. If those block devices contain partitions, they will have
296 the usual names (eg. C</dev/sda1>). Also LVM C</dev/VG/LV>-style
299 The rules are the same as for L<mount(2)>: A filesystem must
300 first be mounted on C</> before others can be mounted. Other
301 filesystems can only be mounted on directories which already
304 The mounted filesystem is writable, if we have sufficient permissions
305 on the underlying device.
307 The filesystem options C<sync> and C<noatime> are set with this
308 call, in order to improve reliability.");
310 ("sync", (RErr, []), 2, [],
311 [ TestRun (InitNone, [["sync"]])],
312 "sync disks, writes are flushed through to the disk image",
314 This syncs the disk, so that any writes are flushed through to the
315 underlying disk image.
317 You should always call this if you have modified a disk image, before
318 closing the handle.");
320 ("touch", (RErr, [String "path"]), 3, [],
324 ["exists"; "/new"]])],
325 "update file timestamps or create a new file",
327 Touch acts like the L<touch(1)> command. It can be used to
328 update the timestamps on a file, or, if the file does not exist,
329 to create a new zero-length file.");
331 ("cat", (RString "content", [String "path"]), 4, [ProtocolLimitWarning],
334 [["write_file"; "/new"; "new file contents"; "0"];
335 ["cat"; "/new"]], "new file contents")],
336 "list the contents of a file",
338 Return the contents of the file named C<path>.
340 Note that this function cannot correctly handle binary files
341 (specifically, files containing C<\\0> character which is treated
342 as end of string). For those you need to use the C<guestfs_read_file>
343 function which has a more complex interface.");
345 ("ll", (RString "listing", [String "directory"]), 5, [],
346 [], (* XXX Tricky to test because it depends on the exact format
347 * of the 'ls -l' command, which changes between F10 and F11.
349 "list the files in a directory (long format)",
351 List the files in C<directory> (relative to the root directory,
352 there is no cwd) in the format of 'ls -la'.
354 This command is mostly useful for interactive sessions. It
355 is I<not> intended that you try to parse the output string.");
357 ("ls", (RStringList "listing", [String "directory"]), 6, [],
362 ["touch"; "/newest"];
363 ["ls"; "/"]], ["lost+found"; "new"; "newer"; "newest"])],
364 "list the files in a directory",
366 List the files in C<directory> (relative to the root directory,
367 there is no cwd). The '.' and '..' entries are not returned, but
368 hidden files are shown.
370 This command is mostly useful for interactive sessions. Programs
371 should probably use C<guestfs_readdir> instead.");
373 ("list_devices", (RStringList "devices", []), 7, [],
376 [["list_devices"]], ["/dev/sda"; "/dev/sdb"; "/dev/sdc"])],
377 "list the block devices",
379 List all the block devices.
381 The full block device names are returned, eg. C</dev/sda>");
383 ("list_partitions", (RStringList "partitions", []), 8, [],
386 [["list_partitions"]], ["/dev/sda1"]);
390 ["list_partitions"]], ["/dev/sda1"; "/dev/sda2"; "/dev/sda3"])],
391 "list the partitions",
393 List all the partitions detected on all block devices.
395 The full partition device names are returned, eg. C</dev/sda1>
397 This does not return logical volumes. For that you will need to
398 call C<guestfs_lvs>.");
400 ("pvs", (RStringList "physvols", []), 9, [],
403 [["pvs"]], ["/dev/sda1"]);
407 ["pvcreate"; "/dev/sda1"];
408 ["pvcreate"; "/dev/sda2"];
409 ["pvcreate"; "/dev/sda3"];
410 ["pvs"]], ["/dev/sda1"; "/dev/sda2"; "/dev/sda3"])],
411 "list the LVM physical volumes (PVs)",
413 List all the physical volumes detected. This is the equivalent
414 of the L<pvs(8)> command.
416 This returns a list of just the device names that contain
417 PVs (eg. C</dev/sda2>).
419 See also C<guestfs_pvs_full>.");
421 ("vgs", (RStringList "volgroups", []), 10, [],
428 ["pvcreate"; "/dev/sda1"];
429 ["pvcreate"; "/dev/sda2"];
430 ["pvcreate"; "/dev/sda3"];
431 ["vgcreate"; "VG1"; "/dev/sda1 /dev/sda2"];
432 ["vgcreate"; "VG2"; "/dev/sda3"];
433 ["vgs"]], ["VG1"; "VG2"])],
434 "list the LVM volume groups (VGs)",
436 List all the volumes groups detected. This is the equivalent
437 of the L<vgs(8)> command.
439 This returns a list of just the volume group names that were
440 detected (eg. C<VolGroup00>).
442 See also C<guestfs_vgs_full>.");
444 ("lvs", (RStringList "logvols", []), 11, [],
447 [["lvs"]], ["/dev/VG/LV"]);
451 ["pvcreate"; "/dev/sda1"];
452 ["pvcreate"; "/dev/sda2"];
453 ["pvcreate"; "/dev/sda3"];
454 ["vgcreate"; "VG1"; "/dev/sda1 /dev/sda2"];
455 ["vgcreate"; "VG2"; "/dev/sda3"];
456 ["lvcreate"; "LV1"; "VG1"; "5000"];
457 ["lvcreate"; "LV2"; "VG1"; "5000"];
458 ["lvcreate"; "LV3"; "VG2"; "5000"];
459 ["lvs"]], ["LV1"; "LV2"; "LV3"])],
460 "list the LVM logical volumes (LVs)",
462 List all the logical volumes detected. This is the equivalent
463 of the L<lvs(8)> command.
465 This returns a list of the logical volume device names
466 (eg. C</dev/VolGroup00/LogVol00>).
468 See also C<guestfs_lvs_full>.");
470 ("pvs_full", (RPVList "physvols", []), 12, [],
474 "list the LVM physical volumes (PVs)",
476 List all the physical volumes detected. This is the equivalent
477 of the L<pvs(8)> command. The \"full\" version includes all fields.");
479 ("vgs_full", (RVGList "volgroups", []), 13, [],
483 "list the LVM volume groups (VGs)",
485 List all the volumes groups detected. This is the equivalent
486 of the L<vgs(8)> command. The \"full\" version includes all fields.");
488 ("lvs_full", (RLVList "logvols", []), 14, [],
492 "list the LVM logical volumes (LVs)",
494 List all the logical volumes detected. This is the equivalent
495 of the L<lvs(8)> command. The \"full\" version includes all fields.");
497 ("read_lines", (RStringList "lines", [String "path"]), 15, [],
500 [["write_file"; "/new"; "line1\r\nline2\nline3"; "0"];
501 ["read_lines"; "/new"]], ["line1"; "line2"; "line3"]);
504 [["write_file"; "/new"; ""; "0"];
505 ["read_lines"; "/new"]], [])],
506 "read file as lines",
508 Return the contents of the file named C<path>.
510 The file contents are returned as a list of lines. Trailing
511 C<LF> and C<CRLF> character sequences are I<not> returned.
513 Note that this function cannot correctly handle binary files
514 (specifically, files containing C<\\0> character which is treated
515 as end of line). For those you need to use the C<guestfs_read_file>
516 function which has a more complex interface.");
518 ("aug_init", (RErr, [String "root"; Int "flags"]), 16, [],
519 [], (* XXX Augeas code needs tests. *)
520 "create a new Augeas handle",
522 Create a new Augeas handle for editing configuration files.
523 If there was any previous Augeas handle associated with this
524 guestfs session, then it is closed.
526 You must call this before using any other C<guestfs_aug_*>
529 C<root> is the filesystem root. C<root> must not be NULL,
532 The flags are the same as the flags defined in
533 E<lt>augeas.hE<gt>, the logical I<or> of the following
538 =item C<AUG_SAVE_BACKUP> = 1
540 Keep the original file with a C<.augsave> extension.
542 =item C<AUG_SAVE_NEWFILE> = 2
544 Save changes into a file with extension C<.augnew>, and
545 do not overwrite original. Overrides C<AUG_SAVE_BACKUP>.
547 =item C<AUG_TYPE_CHECK> = 4
549 Typecheck lenses (can be expensive).
551 =item C<AUG_NO_STDINC> = 8
553 Do not use standard load path for modules.
555 =item C<AUG_SAVE_NOOP> = 16
557 Make save a no-op, just record what would have been changed.
559 =item C<AUG_NO_LOAD> = 32
561 Do not load the tree in C<guestfs_aug_init>.
565 To close the handle, you can call C<guestfs_aug_close>.
567 To find out more about Augeas, see L<http://augeas.net/>.");
569 ("aug_close", (RErr, []), 26, [],
570 [], (* XXX Augeas code needs tests. *)
571 "close the current Augeas handle",
573 Close the current Augeas handle and free up any resources
574 used by it. After calling this, you have to call
575 C<guestfs_aug_init> again before you can use any other
578 ("aug_defvar", (RInt "nrnodes", [String "name"; OptString "expr"]), 17, [],
579 [], (* XXX Augeas code needs tests. *)
580 "define an Augeas variable",
582 Defines an Augeas variable C<name> whose value is the result
583 of evaluating C<expr>. If C<expr> is NULL, then C<name> is
586 On success this returns the number of nodes in C<expr>, or
587 C<0> if C<expr> evaluates to something which is not a nodeset.");
589 ("aug_defnode", (RIntBool ("nrnodes", "created"), [String "name"; String "expr"; String "val"]), 18, [],
590 [], (* XXX Augeas code needs tests. *)
591 "define an Augeas node",
593 Defines a variable C<name> whose value is the result of
596 If C<expr> evaluates to an empty nodeset, a node is created,
597 equivalent to calling C<guestfs_aug_set> C<expr>, C<value>.
598 C<name> will be the nodeset containing that single node.
600 On success this returns a pair containing the
601 number of nodes in the nodeset, and a boolean flag
602 if a node was created.");
604 ("aug_get", (RString "val", [String "path"]), 19, [],
605 [], (* XXX Augeas code needs tests. *)
606 "look up the value of an Augeas path",
608 Look up the value associated with C<path>. If C<path>
609 matches exactly one node, the C<value> is returned.");
611 ("aug_set", (RErr, [String "path"; String "val"]), 20, [],
612 [], (* XXX Augeas code needs tests. *)
613 "set Augeas path to value",
615 Set the value associated with C<path> to C<value>.");
617 ("aug_insert", (RErr, [String "path"; String "label"; Bool "before"]), 21, [],
618 [], (* XXX Augeas code needs tests. *)
619 "insert a sibling Augeas node",
621 Create a new sibling C<label> for C<path>, inserting it into
622 the tree before or after C<path> (depending on the boolean
625 C<path> must match exactly one existing node in the tree, and
626 C<label> must be a label, ie. not contain C</>, C<*> or end
627 with a bracketed index C<[N]>.");
629 ("aug_rm", (RInt "nrnodes", [String "path"]), 22, [],
630 [], (* XXX Augeas code needs tests. *)
631 "remove an Augeas path",
633 Remove C<path> and all of its children.
635 On success this returns the number of entries which were removed.");
637 ("aug_mv", (RErr, [String "src"; String "dest"]), 23, [],
638 [], (* XXX Augeas code needs tests. *)
641 Move the node C<src> to C<dest>. C<src> must match exactly
642 one node. C<dest> is overwritten if it exists.");
644 ("aug_match", (RStringList "matches", [String "path"]), 24, [],
645 [], (* XXX Augeas code needs tests. *)
646 "return Augeas nodes which match path",
648 Returns a list of paths which match the path expression C<path>.
649 The returned paths are sufficiently qualified so that they match
650 exactly one node in the current tree.");
652 ("aug_save", (RErr, []), 25, [],
653 [], (* XXX Augeas code needs tests. *)
654 "write all pending Augeas changes to disk",
656 This writes all pending changes to disk.
658 The flags which were passed to C<guestfs_aug_init> affect exactly
659 how files are saved.");
661 ("aug_load", (RErr, []), 27, [],
662 [], (* XXX Augeas code needs tests. *)
663 "load files into the tree",
665 Load files into the tree.
667 See C<aug_load> in the Augeas documentation for the full gory
670 ("aug_ls", (RStringList "matches", [String "path"]), 28, [],
671 [], (* XXX Augeas code needs tests. *)
672 "list Augeas nodes under a path",
674 This is just a shortcut for listing C<guestfs_aug_match>
675 C<path/*> and sorting the resulting nodes into alphabetical order.");
677 ("rm", (RErr, [String "path"]), 29, [],
691 Remove the single file C<path>.");
693 ("rmdir", (RErr, [String "path"]), 30, [],
700 [["rmdir"; "/new"]]);
704 ["rmdir"; "/new"]])],
705 "remove a directory",
707 Remove the single directory C<path>.");
709 ("rm_rf", (RErr, [String "path"]), 31, [],
713 ["mkdir"; "/new/foo"];
714 ["touch"; "/new/foo/bar"];
716 ["exists"; "/new"]])],
717 "remove a file or directory recursively",
719 Remove the file or directory C<path>, recursively removing the
720 contents if its a directory. This is like the C<rm -rf> shell
723 ("mkdir", (RErr, [String "path"]), 32, [],
727 ["is_dir"; "/new"]])],
728 "create a directory",
730 Create a directory named C<path>.");
732 ("mkdir_p", (RErr, [String "path"]), 33, [],
735 [["mkdir_p"; "/new/foo/bar"];
736 ["is_dir"; "/new/foo/bar"]]);
739 [["mkdir_p"; "/new/foo/bar"];
740 ["is_dir"; "/new/foo"]]);
743 [["mkdir_p"; "/new/foo/bar"];
744 ["is_dir"; "/new"]])],
745 "create a directory and parents",
747 Create a directory named C<path>, creating any parent directories
748 as necessary. This is like the C<mkdir -p> shell command.");
750 ("chmod", (RErr, [Int "mode"; String "path"]), 34, [],
751 [], (* XXX Need stat command to test *)
754 Change the mode (permissions) of C<path> to C<mode>. Only
755 numeric modes are supported.");
757 ("chown", (RErr, [Int "owner"; Int "group"; String "path"]), 35, [],
758 [], (* XXX Need stat command to test *)
759 "change file owner and group",
761 Change the file owner to C<owner> and group to C<group>.
763 Only numeric uid and gid are supported. If you want to use
764 names, you will need to locate and parse the password file
765 yourself (Augeas support makes this relatively easy).");
768 let all_functions = non_daemon_functions @ daemon_functions
770 (* In some places we want the functions to be displayed sorted
771 * alphabetically, so this is useful:
773 let all_functions_sorted =
774 List.sort (fun (n1,_,_,_,_,_,_) (n2,_,_,_,_,_,_) ->
775 compare n1 n2) all_functions
777 (* Column names and types from LVM PVs/VGs/LVs. *)
786 "pv_attr", `String (* XXX *);
788 "pv_pe_alloc_count", `Int;
791 "pv_mda_count", `Int;
792 "pv_mda_free", `Bytes;
794 "pv_mda_size", `Bytes;
801 "vg_attr", `String (* XXX *);
805 "vg_extent_size", `Bytes;
806 "vg_extent_count", `Int;
807 "vg_free_count", `Int;
815 "vg_mda_count", `Int;
816 "vg_mda_free", `Bytes;
818 "vg_mda_size", `Bytes;
824 "lv_attr", `String (* XXX *);
827 "lv_kernel_major", `Int;
828 "lv_kernel_minor", `Int;
832 "snap_percent", `OptPercent;
833 "copy_percent", `OptPercent;
836 "mirror_log", `String;
841 * Note we don't want to use any external OCaml libraries which
842 * makes this a bit harder than it should be.
844 let failwithf fs = ksprintf failwith fs
846 let replace_char s c1 c2 =
847 let s2 = String.copy s in
849 for i = 0 to String.length s2 - 1 do
850 if String.unsafe_get s2 i = c1 then (
851 String.unsafe_set s2 i c2;
855 if not !r then s else s2
858 let len = String.length s in
859 let sublen = String.length sub in
861 if i <= len-sublen then (
864 if s.[i+j] = sub.[j] then loop2 (j+1)
870 if r = -1 then loop (i+1) else r
876 let rec replace_str s s1 s2 =
877 let len = String.length s in
878 let sublen = String.length s1 in
882 let s' = String.sub s 0 i in
883 let s'' = String.sub s (i+sublen) (len-i-sublen) in
884 s' ^ s2 ^ replace_str s'' s1 s2
887 let rec find_map f = function
888 | [] -> raise Not_found
892 | None -> find_map f xs
895 let rec loop i = function
897 | x :: xs -> f i x; loop (i+1) xs
901 let name_of_argt = function String n | OptString n | Bool n | Int n -> n
903 (* Check function names etc. for consistency. *)
904 let check_functions () =
905 let contains_uppercase str =
906 let len = String.length str in
908 if i >= len then false
911 if c >= 'A' && c <= 'Z' then true
918 (* Check function names. *)
920 fun (name, _, _, _, _, _, _) ->
921 if String.length name >= 7 && String.sub name 0 7 = "guestfs" then
922 failwithf "function name %s does not need 'guestfs' prefix" name;
923 if contains_uppercase name then
924 failwithf "function name %s should not contain uppercase chars" name;
925 if String.contains name '-' then
926 failwithf "function name %s should not contain '-', use '_' instead."
930 (* Check function parameter/return names. *)
932 fun (name, style, _, _, _, _, _) ->
933 let check_arg_ret_name n =
934 if contains_uppercase n then
935 failwithf "%s param/ret %s should not contain uppercase chars"
937 if String.contains n '-' || String.contains n '_' then
938 failwithf "%s param/ret %s should not contain '-' or '_'"
941 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
944 (match fst style with
946 | RInt n | RBool n | RConstString n | RString n
947 | RStringList n | RPVList n | RVGList n | RLVList n ->
950 check_arg_ret_name n;
953 List.iter (fun arg -> check_arg_ret_name (name_of_argt arg)) (snd style)
956 (* Check long dscriptions. *)
958 fun (name, _, _, _, _, _, longdesc) ->
959 if longdesc.[String.length longdesc-1] = '\n' then
960 failwithf "long description of %s should not end with \\n." name
963 (* Check proc_nrs. *)
965 fun (name, _, proc_nr, _, _, _, _) ->
967 failwithf "daemon function %s should have proc_nr > 0" name
971 fun (name, _, proc_nr, _, _, _, _) ->
972 if proc_nr <> -1 then
973 failwithf "non-daemon function %s should have proc_nr -1" name
974 ) non_daemon_functions;
977 List.map (fun (name, _, proc_nr, _, _, _, _) -> name, proc_nr)
980 List.sort (fun (_,nr1) (_,nr2) -> compare nr1 nr2) proc_nrs in
981 let rec loop = function
984 | (name1,nr1) :: ((name2,nr2) :: _ as rest) when nr1 < nr2 ->
986 | (name1,nr1) :: (name2,nr2) :: _ ->
987 failwithf "%s and %s have conflicting procedure numbers (%d, %d)"
992 (* 'pr' prints to the current output file. *)
993 let chan = ref stdout
994 let pr fs = ksprintf (output_string !chan) fs
996 (* Generate a header block in a number of standard styles. *)
997 type comment_style = CStyle | HashStyle | OCamlStyle
998 type license = GPLv2 | LGPLv2
1000 let generate_header comment license =
1001 let c = match comment with
1002 | CStyle -> pr "/* "; " *"
1003 | HashStyle -> pr "# "; "#"
1004 | OCamlStyle -> pr "(* "; " *" in
1005 pr "libguestfs generated file\n";
1006 pr "%s WARNING: THIS FILE IS GENERATED BY 'src/generator.ml'.\n" c;
1007 pr "%s ANY CHANGES YOU MAKE TO THIS FILE WILL BE LOST.\n" c;
1009 pr "%s Copyright (C) 2009 Red Hat Inc.\n" c;
1013 pr "%s This program is free software; you can redistribute it and/or modify\n" c;
1014 pr "%s it under the terms of the GNU General Public License as published by\n" c;
1015 pr "%s the Free Software Foundation; either version 2 of the License, or\n" c;
1016 pr "%s (at your option) any later version.\n" c;
1018 pr "%s This program is distributed in the hope that it will be useful,\n" c;
1019 pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
1020 pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n" c;
1021 pr "%s GNU General Public License for more details.\n" c;
1023 pr "%s You should have received a copy of the GNU General Public License along\n" c;
1024 pr "%s with this program; if not, write to the Free Software Foundation, Inc.,\n" c;
1025 pr "%s 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n" c;
1028 pr "%s This library is free software; you can redistribute it and/or\n" c;
1029 pr "%s modify it under the terms of the GNU Lesser General Public\n" c;
1030 pr "%s License as published by the Free Software Foundation; either\n" c;
1031 pr "%s version 2 of the License, or (at your option) any later version.\n" c;
1033 pr "%s This library is distributed in the hope that it will be useful,\n" c;
1034 pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
1035 pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU\n" c;
1036 pr "%s Lesser General Public License for more details.\n" c;
1038 pr "%s You should have received a copy of the GNU Lesser General Public\n" c;
1039 pr "%s License along with this library; if not, write to the Free Software\n" c;
1040 pr "%s Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA\n" c;
1043 | CStyle -> pr " */\n"
1045 | OCamlStyle -> pr " *)\n"
1049 (* Start of main code generation functions below this line. *)
1051 (* Generate the pod documentation for the C API. *)
1052 let rec generate_actions_pod () =
1054 fun (shortname, style, _, flags, _, _, longdesc) ->
1055 let name = "guestfs_" ^ shortname in
1056 pr "=head2 %s\n\n" name;
1058 generate_prototype ~extern:false ~handle:"handle" name style;
1060 pr "%s\n\n" longdesc;
1061 (match fst style with
1063 pr "This function returns 0 on success or -1 on error.\n\n"
1065 pr "On error this function returns -1.\n\n"
1067 pr "This function returns a C truth value on success or -1 on error.\n\n"
1069 pr "This function returns a string or NULL on error.
1070 The string is owned by the guest handle and must I<not> be freed.\n\n"
1072 pr "This function returns a string or NULL on error.
1073 I<The caller must free the returned string after use>.\n\n"
1075 pr "This function returns a NULL-terminated array of strings
1076 (like L<environ(3)>), or NULL if there was an error.
1077 I<The caller must free the strings and the array after use>.\n\n"
1079 pr "This function returns a C<struct guestfs_int_bool *>.
1080 I<The caller must call C<guestfs_free_int_bool> after use>.\n\n"
1082 pr "This function returns a C<struct guestfs_lvm_pv_list *>.
1083 I<The caller must call C<guestfs_free_lvm_pv_list> after use>.\n\n"
1085 pr "This function returns a C<struct guestfs_lvm_vg_list *>.
1086 I<The caller must call C<guestfs_free_lvm_vg_list> after use>.\n\n"
1088 pr "This function returns a C<struct guestfs_lvm_lv_list *>.
1089 I<The caller must call C<guestfs_free_lvm_lv_list> after use>.\n\n"
1091 if List.mem ProtocolLimitWarning flags then
1092 pr "Because of the message protocol, there is a transfer limit
1093 of somewhere between 2MB and 4MB. To transfer large files you should use
1095 ) all_functions_sorted
1097 and generate_structs_pod () =
1098 (* LVM structs documentation. *)
1101 pr "=head2 guestfs_lvm_%s\n" typ;
1103 pr " struct guestfs_lvm_%s {\n" typ;
1106 | name, `String -> pr " char *%s;\n" name
1108 pr " /* The next field is NOT nul-terminated, be careful when printing it: */\n";
1109 pr " char %s[32];\n" name
1110 | name, `Bytes -> pr " uint64_t %s;\n" name
1111 | name, `Int -> pr " int64_t %s;\n" name
1112 | name, `OptPercent ->
1113 pr " /* The next field is [0..100] or -1 meaning 'not present': */\n";
1114 pr " float %s;\n" name
1117 pr " struct guestfs_lvm_%s_list {\n" typ;
1118 pr " uint32_t len; /* Number of elements in list. */\n";
1119 pr " struct guestfs_lvm_%s *val; /* Elements. */\n" typ;
1122 pr " void guestfs_free_lvm_%s_list (struct guestfs_free_lvm_%s_list *);\n"
1125 ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols]
1127 (* Generate the protocol (XDR) file, 'guestfs_protocol.x' and
1128 * indirectly 'guestfs_protocol.h' and 'guestfs_protocol.c'.
1130 * We have to use an underscore instead of a dash because otherwise
1131 * rpcgen generates incorrect code.
1133 * This header is NOT exported to clients, but see also generate_structs_h.
1135 and generate_xdr () =
1136 generate_header CStyle LGPLv2;
1138 (* This has to be defined to get around a limitation in Sun's rpcgen. *)
1139 pr "typedef string str<>;\n";
1142 (* LVM internal structures. *)
1146 pr "struct guestfs_lvm_int_%s {\n" typ;
1148 | name, `String -> pr " string %s<>;\n" name
1149 | name, `UUID -> pr " opaque %s[32];\n" name
1150 | name, `Bytes -> pr " hyper %s;\n" name
1151 | name, `Int -> pr " hyper %s;\n" name
1152 | name, `OptPercent -> pr " float %s;\n" name
1156 pr "typedef struct guestfs_lvm_int_%s guestfs_lvm_int_%s_list<>;\n" typ typ;
1158 ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols];
1161 fun (shortname, style, _, _, _, _, _) ->
1162 let name = "guestfs_" ^ shortname in
1164 (match snd style with
1167 pr "struct %s_args {\n" name;
1170 | String n -> pr " string %s<>;\n" n
1171 | OptString n -> pr " str *%s;\n" n
1172 | Bool n -> pr " bool %s;\n" n
1173 | Int n -> pr " int %s;\n" n
1177 (match fst style with
1180 pr "struct %s_ret {\n" name;
1184 pr "struct %s_ret {\n" name;
1188 failwithf "RConstString cannot be returned from a daemon function"
1190 pr "struct %s_ret {\n" name;
1191 pr " string %s<>;\n" n;
1194 pr "struct %s_ret {\n" name;
1195 pr " str %s<>;\n" n;
1198 pr "struct %s_ret {\n" name;
1203 pr "struct %s_ret {\n" name;
1204 pr " guestfs_lvm_int_pv_list %s;\n" n;
1207 pr "struct %s_ret {\n" name;
1208 pr " guestfs_lvm_int_vg_list %s;\n" n;
1211 pr "struct %s_ret {\n" name;
1212 pr " guestfs_lvm_int_lv_list %s;\n" n;
1217 (* Table of procedure numbers. *)
1218 pr "enum guestfs_procedure {\n";
1220 fun (shortname, _, proc_nr, _, _, _, _) ->
1221 pr " GUESTFS_PROC_%s = %d,\n" (String.uppercase shortname) proc_nr
1223 pr " GUESTFS_PROC_dummy\n"; (* so we don't have a "hanging comma" *)
1227 (* Having to choose a maximum message size is annoying for several
1228 * reasons (it limits what we can do in the API), but it (a) makes
1229 * the protocol a lot simpler, and (b) provides a bound on the size
1230 * of the daemon which operates in limited memory space. For large
1231 * file transfers you should use FTP.
1233 pr "const GUESTFS_MESSAGE_MAX = %d;\n" (4 * 1024 * 1024);
1236 (* Message header, etc. *)
1238 const GUESTFS_PROGRAM = 0x2000F5F5;
1239 const GUESTFS_PROTOCOL_VERSION = 1;
1241 enum guestfs_message_direction {
1242 GUESTFS_DIRECTION_CALL = 0, /* client -> daemon */
1243 GUESTFS_DIRECTION_REPLY = 1 /* daemon -> client */
1246 enum guestfs_message_status {
1247 GUESTFS_STATUS_OK = 0,
1248 GUESTFS_STATUS_ERROR = 1
1251 const GUESTFS_ERROR_LEN = 256;
1253 struct guestfs_message_error {
1254 string error<GUESTFS_ERROR_LEN>; /* error message */
1257 struct guestfs_message_header {
1258 unsigned prog; /* GUESTFS_PROGRAM */
1259 unsigned vers; /* GUESTFS_PROTOCOL_VERSION */
1260 guestfs_procedure proc; /* GUESTFS_PROC_x */
1261 guestfs_message_direction direction;
1262 unsigned serial; /* message serial number */
1263 guestfs_message_status status;
1267 (* Generate the guestfs-structs.h file. *)
1268 and generate_structs_h () =
1269 generate_header CStyle LGPLv2;
1271 (* This is a public exported header file containing various
1272 * structures. The structures are carefully written to have
1273 * exactly the same in-memory format as the XDR structures that
1274 * we use on the wire to the daemon. The reason for creating
1275 * copies of these structures here is just so we don't have to
1276 * export the whole of guestfs_protocol.h (which includes much
1277 * unrelated and XDR-dependent stuff that we don't want to be
1278 * public, or required by clients).
1280 * To reiterate, we will pass these structures to and from the
1281 * client with a simple assignment or memcpy, so the format
1282 * must be identical to what rpcgen / the RFC defines.
1285 (* guestfs_int_bool structure. *)
1286 pr "struct guestfs_int_bool {\n";
1292 (* LVM public structures. *)
1296 pr "struct guestfs_lvm_%s {\n" typ;
1299 | name, `String -> pr " char *%s;\n" name
1300 | name, `UUID -> pr " char %s[32]; /* this is NOT nul-terminated, be careful when printing */\n" name
1301 | name, `Bytes -> pr " uint64_t %s;\n" name
1302 | name, `Int -> pr " int64_t %s;\n" name
1303 | name, `OptPercent -> pr " float %s; /* [0..100] or -1 */\n" name
1307 pr "struct guestfs_lvm_%s_list {\n" typ;
1308 pr " uint32_t len;\n";
1309 pr " struct guestfs_lvm_%s *val;\n" typ;
1312 ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols]
1314 (* Generate the guestfs-actions.h file. *)
1315 and generate_actions_h () =
1316 generate_header CStyle LGPLv2;
1318 fun (shortname, style, _, _, _, _, _) ->
1319 let name = "guestfs_" ^ shortname in
1320 generate_prototype ~single_line:true ~newline:true ~handle:"handle"
1324 (* Generate the client-side dispatch stubs. *)
1325 and generate_client_actions () =
1326 generate_header CStyle LGPLv2;
1328 (* Client-side stubs for each function. *)
1330 fun (shortname, style, _, _, _, _, _) ->
1331 let name = "guestfs_" ^ shortname in
1333 (* Generate the return value struct. *)
1334 pr "struct %s_rv {\n" shortname;
1335 pr " int cb_done; /* flag to indicate callback was called */\n";
1336 pr " struct guestfs_message_header hdr;\n";
1337 pr " struct guestfs_message_error err;\n";
1338 (match fst style with
1341 failwithf "RConstString cannot be returned from a daemon function"
1343 | RBool _ | RString _ | RStringList _
1345 | RPVList _ | RVGList _ | RLVList _ ->
1346 pr " struct %s_ret ret;\n" name
1350 (* Generate the callback function. *)
1351 pr "static void %s_cb (guestfs_h *g, void *data, XDR *xdr)\n" shortname;
1353 pr " struct %s_rv *rv = (struct %s_rv *) data;\n" shortname shortname;
1355 pr " if (!xdr_guestfs_message_header (xdr, &rv->hdr)) {\n";
1356 pr " error (g, \"%s: failed to parse reply header\");\n" name;
1359 pr " if (rv->hdr.status == GUESTFS_STATUS_ERROR) {\n";
1360 pr " if (!xdr_guestfs_message_error (xdr, &rv->err)) {\n";
1361 pr " error (g, \"%s: failed to parse reply error\");\n" name;
1367 (match fst style with
1370 failwithf "RConstString cannot be returned from a daemon function"
1372 | RBool _ | RString _ | RStringList _
1374 | RPVList _ | RVGList _ | RLVList _ ->
1375 pr " if (!xdr_%s_ret (xdr, &rv->ret)) {\n" name;
1376 pr " error (g, \"%s: failed to parse reply\");\n" name;
1382 pr " rv->cb_done = 1;\n";
1383 pr " main_loop.main_loop_quit (g);\n";
1386 (* Generate the action stub. *)
1387 generate_prototype ~extern:false ~semicolon:false ~newline:true
1388 ~handle:"g" name style;
1391 match fst style with
1392 | RErr | RInt _ | RBool _ -> "-1"
1394 failwithf "RConstString cannot be returned from a daemon function"
1395 | RString _ | RStringList _ | RIntBool _
1396 | RPVList _ | RVGList _ | RLVList _ ->
1401 (match snd style with
1403 | _ -> pr " struct %s_args args;\n" name
1406 pr " struct %s_rv rv;\n" shortname;
1407 pr " int serial;\n";
1409 pr " if (g->state != READY) {\n";
1410 pr " error (g, \"%s called from the wrong state, %%d != READY\",\n"
1413 pr " return %s;\n" error_code;
1416 pr " memset (&rv, 0, sizeof rv);\n";
1419 (match snd style with
1421 pr " serial = dispatch (g, GUESTFS_PROC_%s, NULL, NULL);\n"
1422 (String.uppercase shortname)
1427 pr " args.%s = (char *) %s;\n" n n
1429 pr " args.%s = %s ? (char **) &%s : NULL;\n" n n n
1431 pr " args.%s = %s;\n" n n
1433 pr " args.%s = %s;\n" n n
1435 pr " serial = dispatch (g, GUESTFS_PROC_%s,\n"
1436 (String.uppercase shortname);
1437 pr " (xdrproc_t) xdr_%s_args, (char *) &args);\n"
1440 pr " if (serial == -1)\n";
1441 pr " return %s;\n" error_code;
1444 pr " rv.cb_done = 0;\n";
1445 pr " g->reply_cb_internal = %s_cb;\n" shortname;
1446 pr " g->reply_cb_internal_data = &rv;\n";
1447 pr " main_loop.main_loop_run (g);\n";
1448 pr " g->reply_cb_internal = NULL;\n";
1449 pr " g->reply_cb_internal_data = NULL;\n";
1450 pr " if (!rv.cb_done) {\n";
1451 pr " error (g, \"%s failed, see earlier error messages\");\n" name;
1452 pr " return %s;\n" error_code;
1456 pr " if (check_reply_header (g, &rv.hdr, GUESTFS_PROC_%s, serial) == -1)\n"
1457 (String.uppercase shortname);
1458 pr " return %s;\n" error_code;
1461 pr " if (rv.hdr.status == GUESTFS_STATUS_ERROR) {\n";
1462 pr " error (g, \"%%s\", rv.err.error);\n";
1463 pr " return %s;\n" error_code;
1467 (match fst style with
1468 | RErr -> pr " return 0;\n"
1470 | RBool n -> pr " return rv.ret.%s;\n" n
1472 failwithf "RConstString cannot be returned from a daemon function"
1474 pr " return rv.ret.%s; /* caller will free */\n" n
1476 pr " /* caller will free this, but we need to add a NULL entry */\n";
1477 pr " rv.ret.%s.%s_val =" n n;
1478 pr " safe_realloc (g, rv.ret.%s.%s_val,\n" n n;
1479 pr " sizeof (char *) * (rv.ret.%s.%s_len + 1));\n"
1481 pr " rv.ret.%s.%s_val[rv.ret.%s.%s_len] = NULL;\n" n n n n;
1482 pr " return rv.ret.%s.%s_val;\n" n n
1484 pr " /* caller with free this */\n";
1485 pr " return safe_memdup (g, &rv.ret, sizeof (rv.ret));\n"
1487 pr " /* caller will free this */\n";
1488 pr " return safe_memdup (g, &rv.ret.%s, sizeof (rv.ret.%s));\n" n n
1490 pr " /* caller will free this */\n";
1491 pr " return safe_memdup (g, &rv.ret.%s, sizeof (rv.ret.%s));\n" n n
1493 pr " /* caller will free this */\n";
1494 pr " return safe_memdup (g, &rv.ret.%s, sizeof (rv.ret.%s));\n" n n
1500 (* Generate daemon/actions.h. *)
1501 and generate_daemon_actions_h () =
1502 generate_header CStyle GPLv2;
1504 pr "#include \"../src/guestfs_protocol.h\"\n";
1508 fun (name, style, _, _, _, _, _) ->
1510 ~single_line:true ~newline:true ~in_daemon:true ~prefix:"do_"
1514 (* Generate the server-side stubs. *)
1515 and generate_daemon_actions () =
1516 generate_header CStyle GPLv2;
1518 pr "#define _GNU_SOURCE // for strchrnul\n";
1520 pr "#include <stdio.h>\n";
1521 pr "#include <stdlib.h>\n";
1522 pr "#include <string.h>\n";
1523 pr "#include <inttypes.h>\n";
1524 pr "#include <ctype.h>\n";
1525 pr "#include <rpc/types.h>\n";
1526 pr "#include <rpc/xdr.h>\n";
1528 pr "#include \"daemon.h\"\n";
1529 pr "#include \"../src/guestfs_protocol.h\"\n";
1530 pr "#include \"actions.h\"\n";
1534 fun (name, style, _, _, _, _, _) ->
1535 (* Generate server-side stubs. *)
1536 pr "static void %s_stub (XDR *xdr_in)\n" name;
1539 match fst style with
1540 | RErr | RInt _ -> pr " int r;\n"; "-1"
1541 | RBool _ -> pr " int r;\n"; "-1"
1543 failwithf "RConstString cannot be returned from a daemon function"
1544 | RString _ -> pr " char *r;\n"; "NULL"
1545 | RStringList _ -> pr " char **r;\n"; "NULL"
1546 | RIntBool _ -> pr " guestfs_%s_ret *r;\n" name; "NULL"
1547 | RPVList _ -> pr " guestfs_lvm_int_pv_list *r;\n"; "NULL"
1548 | RVGList _ -> pr " guestfs_lvm_int_vg_list *r;\n"; "NULL"
1549 | RLVList _ -> pr " guestfs_lvm_int_lv_list *r;\n"; "NULL" in
1551 (match snd style with
1554 pr " struct guestfs_%s_args args;\n" name;
1558 | OptString n -> pr " const char *%s;\n" n
1559 | Bool n -> pr " int %s;\n" n
1560 | Int n -> pr " int %s;\n" n
1565 (match snd style with
1568 pr " memset (&args, 0, sizeof args);\n";
1570 pr " if (!xdr_guestfs_%s_args (xdr_in, &args)) {\n" name;
1571 pr " reply_with_error (\"%%s: daemon failed to decode procedure arguments\", \"%s\");\n" name;
1576 | String n -> pr " %s = args.%s;\n" n n
1577 | OptString n -> pr " %s = args.%s ? *args.%s : NULL;\n" n n n
1578 | Bool n -> pr " %s = args.%s;\n" n n
1579 | Int n -> pr " %s = args.%s;\n" n n
1584 pr " r = do_%s " name;
1585 generate_call_args style;
1588 pr " if (r == %s)\n" error_code;
1589 pr " /* do_%s has already called reply_with_error, so just return */\n" name;
1593 (match fst style with
1594 | RErr -> pr " reply (NULL, NULL);\n"
1596 pr " struct guestfs_%s_ret ret;\n" name;
1597 pr " ret.%s = r;\n" n;
1598 pr " reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name
1600 pr " struct guestfs_%s_ret ret;\n" name;
1601 pr " ret.%s = r;\n" n;
1602 pr " reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name
1604 failwithf "RConstString cannot be returned from a daemon function"
1606 pr " struct guestfs_%s_ret ret;\n" name;
1607 pr " ret.%s = r;\n" n;
1608 pr " reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name;
1611 pr " struct guestfs_%s_ret ret;\n" name;
1612 pr " ret.%s.%s_len = count_strings (r);\n" n n;
1613 pr " ret.%s.%s_val = r;\n" n n;
1614 pr " reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name;
1615 pr " free_strings (r);\n"
1617 pr " reply ((xdrproc_t) xdr_guestfs_%s_ret, (char *) r);\n" name;
1618 pr " xdr_free ((xdrproc_t) xdr_guestfs_%s_ret, (char *) r);\n" name
1620 pr " struct guestfs_%s_ret ret;\n" name;
1621 pr " ret.%s = *r;\n" n;
1622 pr " reply ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n" name;
1623 pr " xdr_free ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n" name
1625 pr " struct guestfs_%s_ret ret;\n" name;
1626 pr " ret.%s = *r;\n" n;
1627 pr " reply ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n" name;
1628 pr " xdr_free ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n" name
1630 pr " struct guestfs_%s_ret ret;\n" name;
1631 pr " ret.%s = *r;\n" n;
1632 pr " reply ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n" name;
1633 pr " xdr_free ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n" name
1639 (* Dispatch function. *)
1640 pr "void dispatch_incoming_message (XDR *xdr_in)\n";
1642 pr " switch (proc_nr) {\n";
1645 fun (name, style, _, _, _, _, _) ->
1646 pr " case GUESTFS_PROC_%s:\n" (String.uppercase name);
1647 pr " %s_stub (xdr_in);\n" name;
1652 pr " reply_with_error (\"dispatch_incoming_message: unknown procedure number %%d\", proc_nr);\n";
1657 (* LVM columns and tokenization functions. *)
1658 (* XXX This generates crap code. We should rethink how we
1664 pr "static const char *lvm_%s_cols = \"%s\";\n"
1665 typ (String.concat "," (List.map fst cols));
1668 pr "static int lvm_tokenize_%s (char *str, struct guestfs_lvm_int_%s *r)\n" typ typ;
1670 pr " char *tok, *p, *next;\n";
1674 pr " fprintf (stderr, \"%%s: <<%%s>>\\n\", __func__, str);\n";
1677 pr " if (!str) {\n";
1678 pr " fprintf (stderr, \"%%s: failed: passed a NULL string\\n\", __func__);\n";
1681 pr " if (!*str || isspace (*str)) {\n";
1682 pr " fprintf (stderr, \"%%s: failed: passed a empty string or one beginning with whitespace\\n\", __func__);\n";
1687 fun (name, coltype) ->
1688 pr " if (!tok) {\n";
1689 pr " fprintf (stderr, \"%%s: failed: string finished early, around token %%s\\n\", __func__, \"%s\");\n" name;
1692 pr " p = strchrnul (tok, ',');\n";
1693 pr " if (*p) next = p+1; else next = NULL;\n";
1694 pr " *p = '\\0';\n";
1697 pr " r->%s = strdup (tok);\n" name;
1698 pr " if (r->%s == NULL) {\n" name;
1699 pr " perror (\"strdup\");\n";
1703 pr " for (i = j = 0; i < 32; ++j) {\n";
1704 pr " if (tok[j] == '\\0') {\n";
1705 pr " fprintf (stderr, \"%%s: failed to parse UUID from '%%s'\\n\", __func__, tok);\n";
1707 pr " } else if (tok[j] != '-')\n";
1708 pr " r->%s[i++] = tok[j];\n" name;
1711 pr " if (sscanf (tok, \"%%\"SCNu64, &r->%s) != 1) {\n" name;
1712 pr " fprintf (stderr, \"%%s: failed to parse size '%%s' from token %%s\\n\", __func__, tok, \"%s\");\n" name;
1716 pr " if (sscanf (tok, \"%%\"SCNi64, &r->%s) != 1) {\n" name;
1717 pr " fprintf (stderr, \"%%s: failed to parse int '%%s' from token %%s\\n\", __func__, tok, \"%s\");\n" name;
1721 pr " if (tok[0] == '\\0')\n";
1722 pr " r->%s = -1;\n" name;
1723 pr " else if (sscanf (tok, \"%%f\", &r->%s) != 1) {\n" name;
1724 pr " fprintf (stderr, \"%%s: failed to parse float '%%s' from token %%s\\n\", __func__, tok, \"%s\");\n" name;
1728 pr " tok = next;\n";
1731 pr " if (tok != NULL) {\n";
1732 pr " fprintf (stderr, \"%%s: failed: extra tokens at end of string\\n\", __func__);\n";
1739 pr "guestfs_lvm_int_%s_list *\n" typ;
1740 pr "parse_command_line_%ss (void)\n" typ;
1742 pr " char *out, *err;\n";
1743 pr " char *p, *pend;\n";
1745 pr " guestfs_lvm_int_%s_list *ret;\n" typ;
1746 pr " void *newp;\n";
1748 pr " ret = malloc (sizeof *ret);\n";
1749 pr " if (!ret) {\n";
1750 pr " reply_with_perror (\"malloc\");\n";
1751 pr " return NULL;\n";
1754 pr " ret->guestfs_lvm_int_%s_list_len = 0;\n" typ;
1755 pr " ret->guestfs_lvm_int_%s_list_val = NULL;\n" typ;
1757 pr " r = command (&out, &err,\n";
1758 pr " \"/sbin/lvm\", \"%ss\",\n" typ;
1759 pr " \"-o\", lvm_%s_cols, \"--unbuffered\", \"--noheadings\",\n" typ;
1760 pr " \"--nosuffix\", \"--separator\", \",\", \"--units\", \"b\", NULL);\n";
1761 pr " if (r == -1) {\n";
1762 pr " reply_with_error (\"%%s\", err);\n";
1763 pr " free (out);\n";
1764 pr " free (err);\n";
1765 pr " return NULL;\n";
1768 pr " free (err);\n";
1770 pr " /* Tokenize each line of the output. */\n";
1773 pr " while (p) {\n";
1774 pr " pend = strchr (p, '\\n'); /* Get the next line of output. */\n";
1775 pr " if (pend) {\n";
1776 pr " *pend = '\\0';\n";
1780 pr " while (*p && isspace (*p)) /* Skip any leading whitespace. */\n";
1783 pr " if (!*p) { /* Empty line? Skip it. */\n";
1788 pr " /* Allocate some space to store this next entry. */\n";
1789 pr " newp = realloc (ret->guestfs_lvm_int_%s_list_val,\n" typ;
1790 pr " sizeof (guestfs_lvm_int_%s) * (i+1));\n" typ;
1791 pr " if (newp == NULL) {\n";
1792 pr " reply_with_perror (\"realloc\");\n";
1793 pr " free (ret->guestfs_lvm_int_%s_list_val);\n" typ;
1794 pr " free (ret);\n";
1795 pr " free (out);\n";
1796 pr " return NULL;\n";
1798 pr " ret->guestfs_lvm_int_%s_list_val = newp;\n" typ;
1800 pr " /* Tokenize the next entry. */\n";
1801 pr " r = lvm_tokenize_%s (p, &ret->guestfs_lvm_int_%s_list_val[i]);\n" typ typ;
1802 pr " if (r == -1) {\n";
1803 pr " reply_with_error (\"failed to parse output of '%ss' command\");\n" typ;
1804 pr " free (ret->guestfs_lvm_int_%s_list_val);\n" typ;
1805 pr " free (ret);\n";
1806 pr " free (out);\n";
1807 pr " return NULL;\n";
1814 pr " ret->guestfs_lvm_int_%s_list_len = i;\n" typ;
1816 pr " free (out);\n";
1817 pr " return ret;\n";
1820 ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols]
1822 (* Generate the tests. *)
1823 and generate_tests () =
1824 generate_header CStyle GPLv2;
1826 pr "#include <stdio.h>\n";
1827 pr "#include <stdlib.h>\n";
1828 pr "#include <string.h>\n";
1830 pr "#include \"guestfs.h\"\n";
1835 pr "int main (int argc, char *argv[])\n";
1840 (* Generate a lot of different functions for guestfish. *)
1841 and generate_fish_cmds () =
1842 generate_header CStyle GPLv2;
1846 fun (_, _, _, flags, _, _, _) -> not (List.mem NotInFish flags)
1848 let all_functions_sorted =
1850 fun (_, _, _, flags, _, _, _) -> not (List.mem NotInFish flags)
1851 ) all_functions_sorted in
1853 pr "#include <stdio.h>\n";
1854 pr "#include <stdlib.h>\n";
1855 pr "#include <string.h>\n";
1856 pr "#include <inttypes.h>\n";
1858 pr "#include <guestfs.h>\n";
1859 pr "#include \"fish.h\"\n";
1862 (* list_commands function, which implements guestfish -h *)
1863 pr "void list_commands (void)\n";
1865 pr " printf (\" %%-16s %%s\\n\", \"Command\", \"Description\");\n";
1866 pr " list_builtin_commands ();\n";
1868 fun (name, _, _, flags, _, shortdesc, _) ->
1869 let name = replace_char name '_' '-' in
1870 pr " printf (\"%%-20s %%s\\n\", \"%s\", \"%s\");\n"
1872 ) all_functions_sorted;
1873 pr " printf (\" Use -h <cmd> / help <cmd> to show detailed help for a command.\\n\");\n";
1877 (* display_command function, which implements guestfish -h cmd *)
1878 pr "void display_command (const char *cmd)\n";
1881 fun (name, style, _, flags, _, shortdesc, longdesc) ->
1882 let name2 = replace_char name '_' '-' in
1884 try find_map (function FishAlias n -> Some n | _ -> None) flags
1885 with Not_found -> name in
1886 let longdesc = replace_str longdesc "C<guestfs_" "C<" in
1888 match snd style with
1892 name2 (String.concat "> <" (List.map name_of_argt args)) in
1895 if List.mem ProtocolLimitWarning flags then
1896 "\n\nBecause of the message protocol, there is a transfer limit
1897 of somewhere between 2MB and 4MB. To transfer large files you should use
1901 let describe_alias =
1902 if name <> alias then
1903 sprintf "\n\nYou can use '%s' as an alias for this command." alias
1907 pr "strcasecmp (cmd, \"%s\") == 0" name;
1908 if name <> name2 then
1909 pr " || strcasecmp (cmd, \"%s\") == 0" name2;
1910 if name <> alias then
1911 pr " || strcasecmp (cmd, \"%s\") == 0" alias;
1913 pr " pod2text (\"%s - %s\", %S);\n"
1915 (" " ^ synopsis ^ "\n\n" ^ longdesc ^ warnings ^ describe_alias);
1918 pr " display_builtin_command (cmd);\n";
1922 (* print_{pv,vg,lv}_list functions *)
1926 pr "static void print_%s (struct guestfs_lvm_%s *%s)\n" typ typ typ;
1933 pr " printf (\"%s: %%s\\n\", %s->%s);\n" name typ name
1935 pr " printf (\"%s: \");\n" name;
1936 pr " for (i = 0; i < 32; ++i)\n";
1937 pr " printf (\"%%c\", %s->%s[i]);\n" typ name;
1938 pr " printf (\"\\n\");\n"
1940 pr " printf (\"%s: %%\" PRIu64 \"\\n\", %s->%s);\n" name typ name
1942 pr " printf (\"%s: %%\" PRIi64 \"\\n\", %s->%s);\n" name typ name
1943 | name, `OptPercent ->
1944 pr " if (%s->%s >= 0) printf (\"%s: %%g %%%%\\n\", %s->%s);\n"
1945 typ name name typ name;
1946 pr " else printf (\"%s: \\n\");\n" name
1950 pr "static void print_%s_list (struct guestfs_lvm_%s_list *%ss)\n"
1955 pr " for (i = 0; i < %ss->len; ++i)\n" typ;
1956 pr " print_%s (&%ss->val[i]);\n" typ typ;
1959 ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols];
1961 (* run_<action> actions *)
1963 fun (name, style, _, flags, _, _, _) ->
1964 pr "static int run_%s (const char *cmd, int argc, char *argv[])\n" name;
1966 (match fst style with
1969 | RBool _ -> pr " int r;\n"
1970 | RConstString _ -> pr " const char *r;\n"
1971 | RString _ -> pr " char *r;\n"
1972 | RStringList _ -> pr " char **r;\n"
1973 | RIntBool _ -> pr " struct guestfs_int_bool *r;\n"
1974 | RPVList _ -> pr " struct guestfs_lvm_pv_list *r;\n"
1975 | RVGList _ -> pr " struct guestfs_lvm_vg_list *r;\n"
1976 | RLVList _ -> pr " struct guestfs_lvm_lv_list *r;\n"
1980 | String n -> pr " const char *%s;\n" n
1981 | OptString n -> pr " const char *%s;\n" n
1982 | Bool n -> pr " int %s;\n" n
1983 | Int n -> pr " int %s;\n" n
1986 (* Check and convert parameters. *)
1987 let argc_expected = List.length (snd style) in
1988 pr " if (argc != %d) {\n" argc_expected;
1989 pr " fprintf (stderr, \"%%s should have %d parameter(s)\\n\", cmd);\n"
1991 pr " fprintf (stderr, \"type 'help %%s' for help on %%s\\n\", cmd, cmd);\n";
1997 | String name -> pr " %s = argv[%d];\n" name i
1999 pr " %s = strcmp (argv[%d], \"\") != 0 ? argv[%d] : NULL;\n"
2002 pr " %s = is_true (argv[%d]) ? 1 : 0;\n" name i
2004 pr " %s = atoi (argv[%d]);\n" name i
2007 (* Call C API function. *)
2009 try find_map (function FishAction n -> Some n | _ -> None) flags
2010 with Not_found -> sprintf "guestfs_%s" name in
2012 generate_call_args ~handle:"g" style;
2015 (* Check return value for errors and display command results. *)
2016 (match fst style with
2017 | RErr -> pr " return r;\n"
2019 pr " if (r == -1) return -1;\n";
2020 pr " if (r) printf (\"%%d\\n\", r);\n";
2023 pr " if (r == -1) return -1;\n";
2024 pr " if (r) printf (\"true\\n\"); else printf (\"false\\n\");\n";
2027 pr " if (r == NULL) return -1;\n";
2028 pr " printf (\"%%s\\n\", r);\n";
2031 pr " if (r == NULL) return -1;\n";
2032 pr " printf (\"%%s\\n\", r);\n";
2036 pr " if (r == NULL) return -1;\n";
2037 pr " print_strings (r);\n";
2038 pr " free_strings (r);\n";
2041 pr " if (r == NULL) return -1;\n";
2042 pr " printf (\"%%d, %%s\\n\", r->i,\n";
2043 pr " r->b ? \"true\" : \"false\");\n";
2044 pr " guestfs_free_int_bool (r);\n";
2047 pr " if (r == NULL) return -1;\n";
2048 pr " print_pv_list (r);\n";
2049 pr " guestfs_free_lvm_pv_list (r);\n";
2052 pr " if (r == NULL) return -1;\n";
2053 pr " print_vg_list (r);\n";
2054 pr " guestfs_free_lvm_vg_list (r);\n";
2057 pr " if (r == NULL) return -1;\n";
2058 pr " print_lv_list (r);\n";
2059 pr " guestfs_free_lvm_lv_list (r);\n";
2066 (* run_action function *)
2067 pr "int run_action (const char *cmd, int argc, char *argv[])\n";
2070 fun (name, _, _, flags, _, _, _) ->
2071 let name2 = replace_char name '_' '-' in
2073 try find_map (function FishAlias n -> Some n | _ -> None) flags
2074 with Not_found -> name in
2076 pr "strcasecmp (cmd, \"%s\") == 0" name;
2077 if name <> name2 then
2078 pr " || strcasecmp (cmd, \"%s\") == 0" name2;
2079 if name <> alias then
2080 pr " || strcasecmp (cmd, \"%s\") == 0" alias;
2082 pr " return run_%s (cmd, argc, argv);\n" name;
2086 pr " fprintf (stderr, \"%%s: unknown command\\n\", cmd);\n";
2093 (* Generate the POD documentation for guestfish. *)
2094 and generate_fish_actions_pod () =
2095 let all_functions_sorted =
2097 fun (_, _, _, flags, _, _, _) -> not (List.mem NotInFish flags)
2098 ) all_functions_sorted in
2101 fun (name, style, _, flags, _, _, longdesc) ->
2102 let longdesc = replace_str longdesc "C<guestfs_" "C<" in
2103 let name = replace_char name '_' '-' in
2105 try find_map (function FishAlias n -> Some n | _ -> None) flags
2106 with Not_found -> name in
2108 pr "=head2 %s" name;
2109 if name <> alias then
2116 | String n -> pr " %s" n
2117 | OptString n -> pr " %s" n
2118 | Bool _ -> pr " true|false"
2119 | Int n -> pr " %s" n
2123 pr "%s\n\n" longdesc
2124 ) all_functions_sorted
2126 (* Generate a C function prototype. *)
2127 and generate_prototype ?(extern = true) ?(static = false) ?(semicolon = true)
2128 ?(single_line = false) ?(newline = false) ?(in_daemon = false)
2130 ?handle name style =
2131 if extern then pr "extern ";
2132 if static then pr "static ";
2133 (match fst style with
2135 | RInt _ -> pr "int "
2136 | RBool _ -> pr "int "
2137 | RConstString _ -> pr "const char *"
2138 | RString _ -> pr "char *"
2139 | RStringList _ -> pr "char **"
2141 if not in_daemon then pr "struct guestfs_int_bool *"
2142 else pr "guestfs_%s_ret *" name
2144 if not in_daemon then pr "struct guestfs_lvm_pv_list *"
2145 else pr "guestfs_lvm_int_pv_list *"
2147 if not in_daemon then pr "struct guestfs_lvm_vg_list *"
2148 else pr "guestfs_lvm_int_vg_list *"
2150 if not in_daemon then pr "struct guestfs_lvm_lv_list *"
2151 else pr "guestfs_lvm_int_lv_list *"
2153 pr "%s%s (" prefix name;
2154 if handle = None && List.length (snd style) = 0 then
2157 let comma = ref false in
2160 | Some handle -> pr "guestfs_h *%s" handle; comma := true
2164 if single_line then pr ", " else pr ",\n\t\t"
2170 | String n -> next (); pr "const char *%s" n
2171 | OptString n -> next (); pr "const char *%s" n
2172 | Bool n -> next (); pr "int %s" n
2173 | Int n -> next (); pr "int %s" n
2177 if semicolon then pr ";";
2178 if newline then pr "\n"
2180 (* Generate C call arguments, eg "(handle, foo, bar)" *)
2181 and generate_call_args ?handle style =
2183 let comma = ref false in
2186 | Some handle -> pr "%s" handle; comma := true
2190 if !comma then pr ", ";
2193 | String n -> pr "%s" n
2194 | OptString n -> pr "%s" n
2195 | Bool n -> pr "%s" n
2196 | Int n -> pr "%s" n
2200 (* Generate the OCaml bindings interface. *)
2201 and generate_ocaml_mli () =
2202 generate_header OCamlStyle LGPLv2;
2205 (** For API documentation you should refer to the C API
2206 in the guestfs(3) manual page. The OCaml API uses almost
2207 exactly the same calls. *)
2210 (** A [guestfs_h] handle. *)
2212 exception Error of string
2213 (** This exception is raised when there is an error. *)
2215 val create : unit -> t
2217 val close : t -> unit
2218 (** Handles are closed by the garbage collector when they become
2219 unreferenced, but callers can also call this in order to
2220 provide predictable cleanup. *)
2223 generate_ocaml_lvm_structure_decls ();
2227 fun (name, style, _, _, _, shortdesc, _) ->
2228 generate_ocaml_prototype name style;
2229 pr "(** %s *)\n" shortdesc;
2233 (* Generate the OCaml bindings implementation. *)
2234 and generate_ocaml_ml () =
2235 generate_header OCamlStyle LGPLv2;
2239 exception Error of string
2240 external create : unit -> t = \"ocaml_guestfs_create\"
2241 external close : t -> unit = \"ocaml_guestfs_close\"
2244 Callback.register_exception \"ocaml_guestfs_error\" (Error \"\")
2248 generate_ocaml_lvm_structure_decls ();
2252 fun (name, style, _, _, _, shortdesc, _) ->
2253 generate_ocaml_prototype ~is_external:true name style;
2256 (* Generate the OCaml bindings C implementation. *)
2257 and generate_ocaml_c () =
2258 generate_header CStyle LGPLv2;
2260 pr "#include <stdio.h>\n";
2261 pr "#include <stdlib.h>\n";
2262 pr "#include <string.h>\n";
2264 pr "#include <caml/config.h>\n";
2265 pr "#include <caml/alloc.h>\n";
2266 pr "#include <caml/callback.h>\n";
2267 pr "#include <caml/fail.h>\n";
2268 pr "#include <caml/memory.h>\n";
2269 pr "#include <caml/mlvalues.h>\n";
2270 pr "#include <caml/signals.h>\n";
2272 pr "#include <guestfs.h>\n";
2274 pr "#include \"guestfs_c.h\"\n";
2277 (* LVM struct copy functions. *)
2280 let has_optpercent_col =
2281 List.exists (function (_, `OptPercent) -> true | _ -> false) cols in
2283 pr "static CAMLprim value\n";
2284 pr "copy_lvm_%s (const struct guestfs_lvm_%s *%s)\n" typ typ typ;
2286 pr " CAMLparam0 ();\n";
2287 if has_optpercent_col then
2288 pr " CAMLlocal3 (rv, v, v2);\n"
2290 pr " CAMLlocal2 (rv, v);\n";
2292 pr " rv = caml_alloc (%d, 0);\n" (List.length cols);
2297 pr " v = caml_copy_string (%s->%s);\n" typ name
2299 pr " v = caml_alloc_string (32);\n";
2300 pr " memcpy (String_val (v), %s->%s, 32);\n" typ name
2303 pr " v = caml_copy_int64 (%s->%s);\n" typ name
2304 | name, `OptPercent ->
2305 pr " if (%s->%s >= 0) { /* Some %s */\n" typ name name;
2306 pr " v2 = caml_copy_double (%s->%s);\n" typ name;
2307 pr " v = caml_alloc (1, 0);\n";
2308 pr " Store_field (v, 0, v2);\n";
2309 pr " } else /* None */\n";
2310 pr " v = Val_int (0);\n";
2312 pr " Store_field (rv, %d, v);\n" i
2314 pr " CAMLreturn (rv);\n";
2318 pr "static CAMLprim value\n";
2319 pr "copy_lvm_%s_list (const struct guestfs_lvm_%s_list *%ss)\n"
2322 pr " CAMLparam0 ();\n";
2323 pr " CAMLlocal2 (rv, v);\n";
2326 pr " if (%ss->len == 0)\n" typ;
2327 pr " CAMLreturn (Atom (0));\n";
2329 pr " rv = caml_alloc (%ss->len, 0);\n" typ;
2330 pr " for (i = 0; i < %ss->len; ++i) {\n" typ;
2331 pr " v = copy_lvm_%s (&%ss->val[i]);\n" typ typ;
2332 pr " caml_modify (&Field (rv, i), v);\n";
2334 pr " CAMLreturn (rv);\n";
2338 ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols];
2341 fun (name, style, _, _, _, _, _) ->
2342 pr "CAMLprim value\n";
2343 pr "ocaml_guestfs_%s (value gv" name;
2345 fun arg -> pr ", value %sv" (name_of_argt arg)
2349 pr " CAMLparam%d (gv" (1 + (List.length (snd style)));
2351 fun arg -> pr ", %sv" (name_of_argt arg)
2354 pr " CAMLlocal1 (rv);\n";
2357 pr " guestfs_h *g = Guestfs_val (gv);\n";
2358 pr " if (g == NULL)\n";
2359 pr " caml_failwith (\"%s: used handle after closing it\");\n" name;
2365 pr " const char *%s = String_val (%sv);\n" n n
2367 pr " const char *%s =\n" n;
2368 pr " %sv != Val_int (0) ? String_val (Field (%sv, 0)) : NULL;\n"
2371 pr " int %s = Bool_val (%sv);\n" n n
2373 pr " int %s = Int_val (%sv);\n" n n
2376 match fst style with
2377 | RErr -> pr " int r;\n"; "-1"
2378 | RInt _ -> pr " int r;\n"; "-1"
2379 | RBool _ -> pr " int r;\n"; "-1"
2380 | RConstString _ -> pr " const char *r;\n"; "NULL"
2381 | RString _ -> pr " char *r;\n"; "NULL"
2387 pr " struct guestfs_int_bool *r;\n";
2390 pr " struct guestfs_lvm_pv_list *r;\n";
2393 pr " struct guestfs_lvm_vg_list *r;\n";
2396 pr " struct guestfs_lvm_lv_list *r;\n";
2400 pr " caml_enter_blocking_section ();\n";
2401 pr " r = guestfs_%s " name;
2402 generate_call_args ~handle:"g" style;
2404 pr " caml_leave_blocking_section ();\n";
2405 pr " if (r == %s)\n" error_code;
2406 pr " ocaml_guestfs_raise_error (g, \"%s\");\n" name;
2409 (match fst style with
2410 | RErr -> pr " rv = Val_unit;\n"
2411 | RInt _ -> pr " rv = Val_int (r);\n"
2412 | RBool _ -> pr " rv = Val_bool (r);\n"
2413 | RConstString _ -> pr " rv = caml_copy_string (r);\n"
2415 pr " rv = caml_copy_string (r);\n";
2418 pr " rv = caml_copy_string_array ((const char **) r);\n";
2419 pr " for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
2422 pr " rv = caml_alloc (2, 0);\n";
2423 pr " Store_field (rv, 0, Val_int (r->i));\n";
2424 pr " Store_field (rv, 1, Val_bool (r->b));\n";
2425 pr " guestfs_free_int_bool (r);\n";
2427 pr " rv = copy_lvm_pv_list (r);\n";
2428 pr " guestfs_free_lvm_pv_list (r);\n";
2430 pr " rv = copy_lvm_vg_list (r);\n";
2431 pr " guestfs_free_lvm_vg_list (r);\n";
2433 pr " rv = copy_lvm_lv_list (r);\n";
2434 pr " guestfs_free_lvm_lv_list (r);\n";
2437 pr " CAMLreturn (rv);\n";
2442 and generate_ocaml_lvm_structure_decls () =
2445 pr "type lvm_%s = {\n" typ;
2448 | name, `String -> pr " %s : string;\n" name
2449 | name, `UUID -> pr " %s : string;\n" name
2450 | name, `Bytes -> pr " %s : int64;\n" name
2451 | name, `Int -> pr " %s : int64;\n" name
2452 | name, `OptPercent -> pr " %s : float option;\n" name
2456 ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols]
2458 and generate_ocaml_prototype ?(is_external = false) name style =
2459 if is_external then pr "external " else pr "val ";
2460 pr "%s : t -> " name;
2463 | String _ -> pr "string -> "
2464 | OptString _ -> pr "string option -> "
2465 | Bool _ -> pr "bool -> "
2466 | Int _ -> pr "int -> "
2468 (match fst style with
2469 | RErr -> pr "unit" (* all errors are turned into exceptions *)
2470 | RInt _ -> pr "int"
2471 | RBool _ -> pr "bool"
2472 | RConstString _ -> pr "string"
2473 | RString _ -> pr "string"
2474 | RStringList _ -> pr "string array"
2475 | RIntBool _ -> pr "int * bool"
2476 | RPVList _ -> pr "lvm_pv array"
2477 | RVGList _ -> pr "lvm_vg array"
2478 | RLVList _ -> pr "lvm_lv array"
2480 if is_external then pr " = \"ocaml_guestfs_%s\"" name;
2483 (* Generate Perl xs code, a sort of crazy variation of C with macros. *)
2484 and generate_perl_xs () =
2485 generate_header CStyle LGPLv2;
2488 #include \"EXTERN.h\"
2492 #include <guestfs.h>
2495 #define PRId64 \"lld\"
2499 my_newSVll(long long val) {
2500 #ifdef USE_64_BIT_ALL
2501 return newSViv(val);
2505 len = snprintf(buf, 100, \"%%\" PRId64, val);
2506 return newSVpv(buf, len);
2511 #define PRIu64 \"llu\"
2515 my_newSVull(unsigned long long val) {
2516 #ifdef USE_64_BIT_ALL
2517 return newSVuv(val);
2521 len = snprintf(buf, 100, \"%%\" PRIu64, val);
2522 return newSVpv(buf, len);
2526 /* XXX Not thread-safe, and in general not safe if the caller is
2527 * issuing multiple requests in parallel (on different guestfs
2528 * handles). We should use the guestfs_h handle passed to the
2529 * error handle to distinguish these cases.
2531 static char *last_error = NULL;
2534 error_handler (guestfs_h *g,
2538 if (last_error != NULL) free (last_error);
2539 last_error = strdup (msg);
2542 MODULE = Sys::Guestfs PACKAGE = Sys::Guestfs
2547 RETVAL = guestfs_create ();
2549 croak (\"could not create guestfs handle\");
2550 guestfs_set_error_handler (RETVAL, error_handler, NULL);
2563 fun (name, style, _, _, _, _, _) ->
2564 (match fst style with
2565 | RErr -> pr "void\n"
2566 | RInt _ -> pr "SV *\n"
2567 | RBool _ -> pr "SV *\n"
2568 | RConstString _ -> pr "SV *\n"
2569 | RString _ -> pr "SV *\n"
2572 | RPVList _ | RVGList _ | RLVList _ ->
2573 pr "void\n" (* all lists returned implictly on the stack *)
2575 (* Call and arguments. *)
2577 generate_call_args ~handle:"g" style;
2579 pr " guestfs_h *g;\n";
2582 | String n -> pr " char *%s;\n" n
2583 | OptString n -> pr " char *%s;\n" n
2584 | Bool n -> pr " int %s;\n" n
2585 | Int n -> pr " int %s;\n" n
2588 (match fst style with
2591 pr " if (guestfs_%s " name;
2592 generate_call_args ~handle:"g" style;
2594 pr " croak (\"%s: %%s\", last_error);\n" name
2600 pr " %s = guestfs_%s " n name;
2601 generate_call_args ~handle:"g" style;
2603 pr " if (%s == -1)\n" n;
2604 pr " croak (\"%s: %%s\", last_error);\n" name;
2605 pr " RETVAL = newSViv (%s);\n" n;
2610 pr " const char *%s;\n" n;
2612 pr " %s = guestfs_%s " n name;
2613 generate_call_args ~handle:"g" style;
2615 pr " if (%s == NULL)\n" n;
2616 pr " croak (\"%s: %%s\", last_error);\n" name;
2617 pr " RETVAL = newSVpv (%s, 0);\n" n;
2622 pr " char *%s;\n" n;
2624 pr " %s = guestfs_%s " n name;
2625 generate_call_args ~handle:"g" style;
2627 pr " if (%s == NULL)\n" n;
2628 pr " croak (\"%s: %%s\", last_error);\n" name;
2629 pr " RETVAL = newSVpv (%s, 0);\n" n;
2630 pr " free (%s);\n" n;
2635 pr " char **%s;\n" n;
2638 pr " %s = guestfs_%s " n name;
2639 generate_call_args ~handle:"g" style;
2641 pr " if (%s == NULL)\n" n;
2642 pr " croak (\"%s: %%s\", last_error);\n" name;
2643 pr " for (n = 0; %s[n] != NULL; ++n) /**/;\n" n;
2644 pr " EXTEND (SP, n);\n";
2645 pr " for (i = 0; i < n; ++i) {\n";
2646 pr " PUSHs (sv_2mortal (newSVpv (%s[i], 0)));\n" n;
2647 pr " free (%s[i]);\n" n;
2649 pr " free (%s);\n" n;
2652 pr " struct guestfs_int_bool *r;\n";
2654 pr " r = guestfs_%s " name;
2655 generate_call_args ~handle:"g" style;
2657 pr " if (r == NULL)\n";
2658 pr " croak (\"%s: %%s\", last_error);\n" name;
2659 pr " EXTEND (SP, 2);\n";
2660 pr " PUSHs (sv_2mortal (newSViv (r->i)));\n";
2661 pr " PUSHs (sv_2mortal (newSViv (r->b)));\n";
2662 pr " guestfs_free_int_bool (r);\n";
2664 generate_perl_lvm_code "pv" pv_cols name style n;
2666 generate_perl_lvm_code "vg" vg_cols name style n;
2668 generate_perl_lvm_code "lv" lv_cols name style n;
2673 and generate_perl_lvm_code typ cols name style n =
2675 pr " struct guestfs_lvm_%s_list *%s;\n" typ n;
2679 pr " %s = guestfs_%s " n name;
2680 generate_call_args ~handle:"g" style;
2682 pr " if (%s == NULL)\n" n;
2683 pr " croak (\"%s: %%s\", last_error);\n" name;
2684 pr " EXTEND (SP, %s->len);\n" n;
2685 pr " for (i = 0; i < %s->len; ++i) {\n" n;
2686 pr " hv = newHV ();\n";
2690 pr " (void) hv_store (hv, \"%s\", %d, newSVpv (%s->val[i].%s, 0), 0);\n"
2691 name (String.length name) n name
2693 pr " (void) hv_store (hv, \"%s\", %d, newSVpv (%s->val[i].%s, 32), 0);\n"
2694 name (String.length name) n name
2696 pr " (void) hv_store (hv, \"%s\", %d, my_newSVull (%s->val[i].%s), 0);\n"
2697 name (String.length name) n name
2699 pr " (void) hv_store (hv, \"%s\", %d, my_newSVll (%s->val[i].%s), 0);\n"
2700 name (String.length name) n name
2701 | name, `OptPercent ->
2702 pr " (void) hv_store (hv, \"%s\", %d, newSVnv (%s->val[i].%s), 0);\n"
2703 name (String.length name) n name
2705 pr " PUSHs (sv_2mortal ((SV *) hv));\n";
2707 pr " guestfs_free_lvm_%s_list (%s);\n" typ n
2709 (* Generate Sys/Guestfs.pm. *)
2710 and generate_perl_pm () =
2711 generate_header HashStyle LGPLv2;
2718 Sys::Guestfs - Perl bindings for libguestfs
2724 my $h = Sys::Guestfs->new ();
2725 $h->add_drive ('guest.img');
2728 $h->mount ('/dev/sda1', '/');
2729 $h->touch ('/hello');
2734 The C<Sys::Guestfs> module provides a Perl XS binding to the
2735 libguestfs API for examining and modifying virtual machine
2738 Amongst the things this is good for: making batch configuration
2739 changes to guests, getting disk used/free statistics (see also:
2740 virt-df), migrating between virtualization systems (see also:
2741 virt-p2v), performing partial backups, performing partial guest
2742 clones, cloning guests and changing registry/UUID/hostname info, and
2745 Libguestfs uses Linux kernel and qemu code, and can access any type of
2746 guest filesystem that Linux and qemu can, including but not limited
2747 to: ext2/3/4, btrfs, FAT and NTFS, LVM, many different disk partition
2748 schemes, qcow, qcow2, vmdk.
2750 Libguestfs provides ways to enumerate guest storage (eg. partitions,
2751 LVs, what filesystem is in each LV, etc.). It can also run commands
2752 in the context of the guest. Also you can access filesystems over FTP.
2756 All errors turn into calls to C<croak> (see L<Carp(3)>).
2764 package Sys::Guestfs;
2770 XSLoader::load ('Sys::Guestfs');
2772 =item $h = Sys::Guestfs->new ();
2774 Create a new guestfs handle.
2780 my $class = ref ($proto) || $proto;
2782 my $self = Sys::Guestfs::_create ();
2783 bless $self, $class;
2789 (* Actions. We only need to print documentation for these as
2790 * they are pulled in from the XS code automatically.
2793 fun (name, style, _, flags, _, _, longdesc) ->
2794 let longdesc = replace_str longdesc "C<guestfs_" "C<$h-E<gt>" in
2796 generate_perl_prototype name style;
2798 pr "%s\n\n" longdesc;
2799 if List.mem ProtocolLimitWarning flags then
2800 pr "Because of the message protocol, there is a transfer limit
2801 of somewhere between 2MB and 4MB. To transfer large files you should use
2803 ) all_functions_sorted;
2815 Copyright (C) 2009 Red Hat Inc.
2819 Please see the file COPYING.LIB for the full license.
2823 L<guestfs(3)>, L<guestfish(1)>.
2828 and generate_perl_prototype name style =
2829 (match fst style with
2834 | RString n -> pr "$%s = " n
2835 | RIntBool (n, m) -> pr "($%s, $%s) = " n m
2839 | RLVList n -> pr "@%s = " n
2842 let comma = ref false in
2845 if !comma then pr ", ";
2847 pr "%s" (name_of_argt arg)
2851 let output_to filename =
2852 let filename_new = filename ^ ".new" in
2853 chan := open_out filename_new;
2857 Unix.rename filename_new filename;
2858 printf "written %s\n%!" filename;
2866 if not (Sys.file_exists "configure.ac") then (
2868 You are probably running this from the wrong directory.
2869 Run it from the top source directory using the command
2875 let close = output_to "src/guestfs_protocol.x" in
2879 let close = output_to "src/guestfs-structs.h" in
2880 generate_structs_h ();
2883 let close = output_to "src/guestfs-actions.h" in
2884 generate_actions_h ();
2887 let close = output_to "src/guestfs-actions.c" in
2888 generate_client_actions ();
2891 let close = output_to "daemon/actions.h" in
2892 generate_daemon_actions_h ();
2895 let close = output_to "daemon/stubs.c" in
2896 generate_daemon_actions ();
2899 let close = output_to "tests.c" in
2903 let close = output_to "fish/cmds.c" in
2904 generate_fish_cmds ();
2907 let close = output_to "guestfs-structs.pod" in
2908 generate_structs_pod ();
2911 let close = output_to "guestfs-actions.pod" in
2912 generate_actions_pod ();
2915 let close = output_to "guestfish-actions.pod" in
2916 generate_fish_actions_pod ();
2919 let close = output_to "ocaml/guestfs.mli" in
2920 generate_ocaml_mli ();
2923 let close = output_to "ocaml/guestfs.ml" in
2924 generate_ocaml_ml ();
2927 let close = output_to "ocaml/guestfs_c_actions.c" in
2928 generate_ocaml_c ();
2931 let close = output_to "perl/Guestfs.xs" in
2932 generate_perl_xs ();
2935 let close = output_to "perl/lib/Sys/Guestfs.pm" in
2936 generate_perl_pm ();