* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
- *
- * This script generates a large amount of code and documentation for
+ *)
+
+(* This script generates a large amount of code and documentation for
* all the daemon actions. To add a new action there are only two
* files you need to change, this one to describe the interface, and
* daemon/<somefile>.c to write the implementation.
+ *
+ * After editing this file, run it (./src/generator.ml) to regenerate
+ * all the output files.
+ *
+ * IMPORTANT: This script should NOT print any warnings. If it prints
+ * warnings, you should treat them as errors.
+ * [Need to add -warn-error to ocaml command line]
*)
#load "unix.cma";;
* indication, ie. 0 or -1.
*)
| Err
- (* "Int" as a return value means an int which is -1 for error
+ (* "RInt" as a return value means an int which is -1 for error
* or any value >= 0 on success.
*)
| RInt of string
| RPVList of string
| RVGList of string
| RLVList of string
-and args =
- (* 0 arguments, 1 argument, etc. The guestfs_h param is implicit. *)
- | P0
- | P1 of argt
- | P2 of argt * argt
- | P3 of argt * argt * argt
+and args = argt list (* Function parameters, guestfs handle is implicit. *)
and argt =
| String of string (* const char *name, cannot be NULL *)
| OptString of string (* const char *name, may be NULL *)
*)
let non_daemon_functions = [
- ("launch", (Err, P0), -1, [FishAlias "run"; FishAction "launch"],
+ ("launch", (Err, []), -1, [FishAlias "run"; FishAction "launch"],
"launch the qemu subprocess",
"\
Internally libguestfs is implemented by running a virtual machine
You should call this after configuring the handle
(eg. adding drives) but before performing any actions.");
- ("wait_ready", (Err, P0), -1, [NotInFish],
+ ("wait_ready", (Err, []), -1, [NotInFish],
"wait until the qemu subprocess launches",
"\
Internally libguestfs is implemented by running a virtual machine
You should call this after C<guestfs_launch> to wait for the launch
to complete.");
- ("kill_subprocess", (Err, P0), -1, [],
+ ("kill_subprocess", (Err, []), -1, [],
"kill the qemu subprocess",
"\
This kills the qemu subprocess. You should never need to call this.");
- ("add_drive", (Err, P1 (String "filename")), -1, [FishAlias "add"],
+ ("add_drive", (Err, [String "filename"]), -1, [FishAlias "add"],
"add an image to examine or modify",
"\
This function adds a virtual machine disk image C<filename> to the
This is equivalent to the qemu parameter C<-drive file=filename>.");
- ("add_cdrom", (Err, P1 (String "filename")), -1, [FishAlias "cdrom"],
+ ("add_cdrom", (Err, [String "filename"]), -1, [FishAlias "cdrom"],
"add a CD-ROM disk image to examine",
"\
This function adds a virtual CD-ROM disk image to the guest.
This is equivalent to the qemu parameter C<-cdrom filename>.");
- ("config", (Err, P2 (String "qemuparam", OptString "qemuvalue")), -1, [],
+ ("config", (Err, [String "qemuparam"; OptString "qemuvalue"]), -1, [],
"add qemu parameters",
"\
This can be used to add arbitrary qemu command line parameters
C<value> can be NULL.");
- ("set_path", (Err, P1 (String "path")), -1, [FishAlias "path"],
+ ("set_path", (Err, [String "path"]), -1, [FishAlias "path"],
"set the search path",
"\
Set the path that libguestfs searches for kernel and initrd.img.
Setting C<path> to C<NULL> restores the default path.");
- ("get_path", (RConstString "path", P0), -1, [],
+ ("get_path", (RConstString "path", []), -1, [],
"get the search path",
"\
Return the current search path.
This is always non-NULL. If it wasn't set already, then this will
return the default path.");
- ("set_autosync", (Err, P1 (Bool "autosync")), -1, [FishAlias "autosync"],
+ ("set_autosync", (Err, [Bool "autosync"]), -1, [FishAlias "autosync"],
"set autosync mode",
"\
If C<autosync> is true, this enables autosync. Libguestfs will make a
best effort attempt to run C<guestfs_sync> when the handle is closed
(also if the program exits without closing handles).");
- ("get_autosync", (RBool "autosync", P0), -1, [],
+ ("get_autosync", (RBool "autosync", []), -1, [],
"get autosync mode",
"\
Get the autosync flag.");
- ("set_verbose", (Err, P1 (Bool "verbose")), -1, [FishAlias "verbose"],
+ ("set_verbose", (Err, [Bool "verbose"]), -1, [FishAlias "verbose"],
"set verbose mode",
"\
If C<verbose> is true, this turns on verbose messages (to C<stderr>).
Verbose messages are disabled unless the environment variable
C<LIBGUESTFS_DEBUG> is defined and set to C<1>.");
- ("get_verbose", (RBool "verbose", P0), -1, [],
+ ("get_verbose", (RBool "verbose", []), -1, [],
"get verbose mode",
"\
This returns the verbose messages flag.")
]
let daemon_functions = [
- ("mount", (Err, P2 (String "device", String "mountpoint")), 1, [],
+ ("mount", (Err, [String "device"; String "mountpoint"]), 1, [],
"mount a guest disk at a position in the filesystem",
"\
Mount a guest disk at a position in the filesystem. Block devices
The filesystem options C<sync> and C<noatime> are set with this
call, in order to improve reliability.");
- ("sync", (Err, P0), 2, [],
+ ("sync", (Err, []), 2, [],
"sync disks, writes are flushed through to the disk image",
"\
This syncs the disk, so that any writes are flushed through to the
You should always call this if you have modified a disk image, before
closing the handle.");
- ("touch", (Err, P1 (String "path")), 3, [],
+ ("touch", (Err, [String "path"]), 3, [],
"update file timestamps or create a new file",
"\
Touch acts like the L<touch(1)> command. It can be used to
update the timestamps on a file, or, if the file does not exist,
to create a new zero-length file.");
- ("cat", (RString "content", P1 (String "path")), 4, [ProtocolLimitWarning],
+ ("cat", (RString "content", [String "path"]), 4, [ProtocolLimitWarning],
"list the contents of a file",
"\
Return the contents of the file named C<path>.
as end of string). For those you need to use the C<guestfs_read_file>
function which has a more complex interface.");
- ("ll", (RString "listing", P1 (String "directory")), 5, [],
+ ("ll", (RString "listing", [String "directory"]), 5, [],
"list the files in a directory (long format)",
"\
List the files in C<directory> (relative to the root directory,
This command is mostly useful for interactive sessions. It
is I<not> intended that you try to parse the output string.");
- ("ls", (RStringList "listing", P1 (String "directory")), 6, [],
+ ("ls", (RStringList "listing", [String "directory"]), 6, [],
"list the files in a directory",
"\
List the files in C<directory> (relative to the root directory,
This command is mostly useful for interactive sessions. Programs
should probably use C<guestfs_readdir> instead.");
- ("list_devices", (RStringList "devices", P0), 7, [],
+ ("list_devices", (RStringList "devices", []), 7, [],
"list the block devices",
"\
List all the block devices.
The full block device names are returned, eg. C</dev/sda>");
- ("list_partitions", (RStringList "partitions", P0), 8, [],
+ ("list_partitions", (RStringList "partitions", []), 8, [],
"list the partitions",
"\
List all the partitions detected on all block devices.
This does not return logical volumes. For that you will need to
call C<guestfs_lvs>.");
- ("pvs", (RStringList "physvols", P0), 9, [],
+ ("pvs", (RStringList "physvols", []), 9, [],
"list the LVM physical volumes (PVs)",
"\
List all the physical volumes detected. This is the equivalent
See also C<guestfs_pvs_full>.");
- ("vgs", (RStringList "volgroups", P0), 10, [],
+ ("vgs", (RStringList "volgroups", []), 10, [],
"list the LVM volume groups (VGs)",
"\
List all the volumes groups detected. This is the equivalent
See also C<guestfs_vgs_full>.");
- ("lvs", (RStringList "logvols", P0), 11, [],
+ ("lvs", (RStringList "logvols", []), 11, [],
"list the LVM logical volumes (LVs)",
"\
List all the logical volumes detected. This is the equivalent
See also C<guestfs_lvs_full>.");
- ("pvs_full", (RPVList "physvols", P0), 12, [],
+ ("pvs_full", (RPVList "physvols", []), 12, [],
"list the LVM physical volumes (PVs)",
"\
List all the physical volumes detected. This is the equivalent
of the L<pvs(8)> command. The \"full\" version includes all fields.");
- ("vgs_full", (RVGList "volgroups", P0), 13, [],
+ ("vgs_full", (RVGList "volgroups", []), 13, [],
"list the LVM volume groups (VGs)",
"\
List all the volumes groups detected. This is the equivalent
of the L<vgs(8)> command. The \"full\" version includes all fields.");
- ("lvs_full", (RLVList "logvols", P0), 14, [],
+ ("lvs_full", (RLVList "logvols", []), 14, [],
"list the LVM logical volumes (LVs)",
"\
List all the logical volumes detected. This is the equivalent
of the L<lvs(8)> command. The \"full\" version includes all fields.");
- ("read_lines", (RStringList "lines", P1 (String "path")), 15, [],
+ ("read_lines", (RStringList "lines", [String "path"]), 15, [],
"read file as lines",
"\
Return the contents of the file named C<path>.
as end of line). For those you need to use the C<guestfs_read_file>
function which has a more complex interface.");
- ("aug_init", (Err, P2 (String "root", Int "flags")), 16, [],
+ ("aug_init", (Err, [String "root"; Int "flags"]), 16, [],
"create a new Augeas handle",
"\
Create a new Augeas handle for editing configuration files.
To find out more about Augeas, see L<http://augeas.net/>.");
- ("aug_close", (Err, P0), 26, [],
+ ("aug_close", (Err, []), 26, [],
"close the current Augeas handle",
"\
Close the current Augeas handle and free up any resources
C<guestfs_aug_init> again before you can use any other
Augeas functions.");
- ("aug_defvar", (RInt "nrnodes", P2 (String "name", OptString "expr")), 17, [],
+ ("aug_defvar", (RInt "nrnodes", [String "name"; OptString "expr"]), 17, [],
"define an Augeas variable",
"\
Defines an Augeas variable C<name> whose value is the result
On success this returns the number of nodes in C<expr>, or
C<0> if C<expr> evaluates to something which is not a nodeset.");
- ("aug_defnode", (RIntBool ("nrnodes", "created"), P3 (String "name", String "expr", String "val")), 18, [],
+ ("aug_defnode", (RIntBool ("nrnodes", "created"), [String "name"; String "expr"; String "val"]), 18, [],
"define an Augeas node",
"\
Defines a variable C<name> whose value is the result of
number of nodes in the nodeset, and a boolean flag
if a node was created.");
- ("aug_get", (RString "val", P1 (String "path")), 19, [],
+ ("aug_get", (RString "val", [String "path"]), 19, [],
"look up the value of an Augeas path",
"\
Look up the value associated with C<path>. If C<path>
matches exactly one node, the C<value> is returned.");
- ("aug_set", (Err, P2 (String "path", String "val")), 20, [],
+ ("aug_set", (Err, [String "path"; String "val"]), 20, [],
"set Augeas path to value",
"\
Set the value associated with C<path> to C<value>.");
- ("aug_insert", (Err, P3 (String "path", String "label", Bool "before")), 21, [],
+ ("aug_insert", (Err, [String "path"; String "label"; Bool "before"]), 21, [],
"insert a sibling Augeas node",
"\
Create a new sibling C<label> for C<path>, inserting it into
C<label> must be a label, ie. not contain C</>, C<*> or end
with a bracketed index C<[N]>.");
- ("aug_rm", (RInt "nrnodes", P1 (String "path")), 22, [],
+ ("aug_rm", (RInt "nrnodes", [String "path"]), 22, [],
"remove an Augeas path",
"\
Remove C<path> and all of its children.
On success this returns the number of entries which were removed.");
- ("aug_mv", (Err, P2 (String "src", String "dest")), 23, [],
+ ("aug_mv", (Err, [String "src"; String "dest"]), 23, [],
"move Augeas node",
"\
Move the node C<src> to C<dest>. C<src> must match exactly
one node. C<dest> is overwritten if it exists.");
- ("aug_match", (RStringList "matches", P1 (String "path")), 24, [],
+ ("aug_match", (RStringList "matches", [String "path"]), 24, [],
"return Augeas nodes which match path",
"\
Returns a list of paths which match the path expression C<path>.
The returned paths are sufficiently qualified so that they match
exactly one node in the current tree.");
- ("aug_save", (Err, P0), 25, [],
+ ("aug_save", (Err, []), 25, [],
"write all pending Augeas changes to disk",
"\
This writes all pending changes to disk.
The flags which were passed to C<guestfs_aug_init> affect exactly
how files are saved.");
- ("aug_load", (Err, P0), 27, [],
+ ("aug_load", (Err, []), 27, [],
"load files into the tree",
"\
Load files into the tree.
See C<aug_load> in the Augeas documentation for the full gory
details.");
- ("aug_ls", (RStringList "matches", P1 (String "path")), 28, [],
+ ("aug_ls", (RStringList "matches", [String "path"]), 28, [],
"list Augeas nodes under a path",
"\
This is just a shortcut for listing C<guestfs_aug_match>
C<path/*> and sorting the resulting nodes into alphabetical order.");
+
]
let all_functions = non_daemon_functions @ daemon_functions
in
loop 0 xs
-(* 'pr' prints to the current output file. *)
-let chan = ref stdout
-let pr fs = ksprintf (output_string !chan) fs
-
-let iter_args f = function
- | P0 -> ()
- | P1 arg1 -> f arg1
- | P2 (arg1, arg2) -> f arg1; f arg2
- | P3 (arg1, arg2, arg3) -> f arg1; f arg2; f arg3
+let name_of_argt = function String n | OptString n | Bool n | Int n -> n
-let iteri_args f = function
- | P0 -> ()
- | P1 arg1 -> f 0 arg1
- | P2 (arg1, arg2) -> f 0 arg1; f 1 arg2
- | P3 (arg1, arg2, arg3) -> f 0 arg1; f 1 arg2; f 2 arg3
+(* Check function names etc. for consistency. *)
+let check_functions () =
+ let contains_uppercase str =
+ let len = String.length str in
+ let rec loop i =
+ if i >= len then false
+ else (
+ let c = str.[i] in
+ if c >= 'A' && c <= 'Z' then true
+ else loop (i+1)
+ )
+ in
+ loop 0
+ in
-let map_args f = function
- | P0 -> []
- | P1 arg1 -> [f arg1]
- | P2 (arg1, arg2) ->
- let n1 = f arg1 in let n2 = f arg2 in [n1; n2]
- | P3 (arg1, arg2, arg3) ->
- let n1 = f arg1 in let n2 = f arg2 in let n3 = f arg3 in [n1; n2; n3]
+ (* Check function names. *)
+ List.iter (
+ fun (name, _, _, _, _, _) ->
+ if String.length name >= 7 && String.sub name 0 7 = "guestfs" then
+ failwithf "function name %s does not need 'guestfs' prefix" name;
+ if contains_uppercase name then
+ failwithf "function name %s should not contain uppercase chars" name;
+ if String.contains name '-' then
+ failwithf "function name %s should not contain '-', use '_' instead."
+ name
+ ) all_functions;
-let nr_args = function | P0 -> 0 | P1 _ -> 1 | P2 _ -> 2 | P3 _ -> 3
+ (* Check function parameter/return names. *)
+ List.iter (
+ fun (name, style, _, _, _, _) ->
+ let check_arg_ret_name n =
+ if contains_uppercase n then
+ failwithf "%s param/ret %s should not contain uppercase chars"
+ name n;
+ if String.contains n '-' || String.contains n '_' then
+ failwithf "%s param/ret %s should not contain '-' or '_'"
+ name n;
+ if n = "value" then
+ 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
+ in
-let name_of_argt = function String n | OptString n | Bool n | Int n -> n
+ (match fst style with
+ | Err -> ()
+ | RInt n | RBool n | RConstString n | RString n
+ | RStringList n | RPVList n | RVGList n | RLVList n ->
+ check_arg_ret_name n
+ | RIntBool (n,m) ->
+ check_arg_ret_name n;
+ check_arg_ret_name m
+ );
+ List.iter (fun arg -> check_arg_ret_name (name_of_argt arg)) (snd style)
+ ) all_functions;
-(* Check function names etc. for consistency. *)
-let check_functions () =
+ (* Check long dscriptions. *)
List.iter (
fun (name, _, _, _, _, longdesc) ->
- if String.contains name '-' then
- failwithf "function name '%s' should not contain '-', use '_' instead."
- name;
if longdesc.[String.length longdesc-1] = '\n' then
failwithf "long description of %s should not end with \\n." name
) all_functions;
+ (* Check proc_nrs. *)
List.iter (
fun (name, _, proc_nr, _, _, _) ->
if proc_nr <= 0 then
| (name1,nr1) :: ((name2,nr2) :: _ as rest) when nr1 < nr2 ->
loop rest
| (name1,nr1) :: (name2,nr2) :: _ ->
- failwithf "'%s' and '%s' have conflicting procedure numbers (%d, %d)"
+ failwithf "%s and %s have conflicting procedure numbers (%d, %d)"
name1 name2 nr1 nr2
in
loop proc_nrs
+(* 'pr' prints to the current output file. *)
+let chan = ref stdout
+let pr fs = ksprintf (output_string !chan) fs
+
+(* Generate a header block in a number of standard styles. *)
type comment_style = CStyle | HashStyle | OCamlStyle
type license = GPLv2 | LGPLv2
-(* Generate a header block in a number of standard styles. *)
-let rec generate_header comment license =
+let generate_header comment license =
let c = match comment with
| CStyle -> pr "/* "; " *"
| HashStyle -> pr "# "; "#"
);
pr "\n"
+(* Start of main code generation functions below this line. *)
+
(* Generate the pod documentation for the C API. *)
-and generate_actions_pod () =
+let rec generate_actions_pod () =
List.iter (
fun (shortname, style, _, flags, _, longdesc) ->
let name = "guestfs_" ^ shortname in
) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols]
(* Generate the protocol (XDR) file, 'guestfs_protocol.x' and
- * indirectly 'guestfs_protocol.h' and 'guestfs_protocol.c'. We
- * have to use an underscore instead of a dash because otherwise
+ * indirectly 'guestfs_protocol.h' and 'guestfs_protocol.c'.
+ *
+ * We have to use an underscore instead of a dash because otherwise
* rpcgen generates incorrect code.
*
* This header is NOT exported to clients, but see also generate_structs_h.
let name = "guestfs_" ^ shortname in
(match snd style with
- | P0 -> ()
+ | [] -> ()
| args ->
pr "struct %s_args {\n" name;
- iter_args (
+ List.iter (
function
| String n -> pr " string %s<>;\n" n
| OptString n -> pr " str *%s;\n" n
pr "{\n";
(match snd style with
- | P0 -> ()
+ | [] -> ()
| _ -> pr " struct %s_args args;\n" name
);
pr "\n";
(match snd style with
- | P0 ->
+ | [] ->
pr " serial = dispatch (g, GUESTFS_PROC_%s, NULL, NULL);\n"
(String.uppercase shortname)
| args ->
- iter_args (
+ List.iter (
function
| String n ->
pr " args.%s = (char *) %s;\n" n n
| RLVList _ -> pr " guestfs_lvm_int_lv_list *r;\n"; "NULL" in
(match snd style with
- | P0 -> ()
+ | [] -> ()
| args ->
pr " struct guestfs_%s_args args;\n" name;
- iter_args (
+ List.iter (
function
| String n
| OptString n -> pr " const char *%s;\n" n
pr "\n";
(match snd style with
- | P0 -> ()
+ | [] -> ()
| args ->
pr " memset (&args, 0, sizeof args);\n";
pr "\n";
pr " reply_with_error (\"%%s: daemon failed to decode procedure arguments\", \"%s\");\n" name;
pr " return;\n";
pr " }\n";
- iter_args (
+ List.iter (
function
| String n -> pr " %s = args.%s;\n" n n
| OptString n -> pr " %s = args.%s ? *args.%s : NULL;\n" n n n
let longdesc = replace_str longdesc "C<guestfs_" "C<" in
let synopsis =
match snd style with
- | P0 -> name2
+ | [] -> name2
| args ->
sprintf "%s <%s>"
- name2 (String.concat "> <" (map_args name_of_argt args)) in
+ name2 (String.concat "> <" (List.map name_of_argt args)) in
let warnings =
if List.mem ProtocolLimitWarning flags then
| RVGList _ -> pr " struct guestfs_lvm_vg_list *r;\n"
| RLVList _ -> pr " struct guestfs_lvm_lv_list *r;\n"
);
- iter_args (
+ List.iter (
function
| String n -> pr " const char *%s;\n" n
| OptString n -> pr " const char *%s;\n" n
) (snd style);
(* Check and convert parameters. *)
- let argc_expected = nr_args (snd style) in
+ let argc_expected = List.length (snd style) in
pr " if (argc != %d) {\n" argc_expected;
pr " fprintf (stderr, \"%%s should have %d parameter(s)\\n\", cmd);\n"
argc_expected;
pr " fprintf (stderr, \"type 'help %%s' for help on %%s\\n\", cmd, cmd);\n";
pr " return -1;\n";
pr " }\n";
- iteri_args (
+ iteri (
fun i ->
function
| String name -> pr " %s = argv[%d];\n" name i
pr "\n";
pr "\n";
pr " %s" name;
- iter_args (
+ List.iter (
function
| String n -> pr " %s" n
| OptString n -> pr " %s" n
else pr "guestfs_lvm_int_lv_list *"
);
pr "%s%s (" prefix name;
- if handle = None && nr_args (snd style) = 0 then
+ if handle = None && List.length (snd style) = 0 then
pr "void"
else (
let comma = ref false in
);
comma := true
in
- iter_args (
+ List.iter (
function
| String n -> next (); pr "const char *%s" n
| OptString n -> next (); pr "const char *%s" n
| None -> ()
| Some handle -> pr "%s" handle; comma := true
);
- iter_args (
+ List.iter (
fun arg ->
if !comma then pr ", ";
comma := true;
fun (name, style, _, _, _, _) ->
pr "CAMLprim value\n";
pr "ocaml_guestfs_%s (value gv" name;
- iter_args (
+ List.iter (
fun arg -> pr ", value %sv" (name_of_argt arg)
) (snd style);
pr ")\n";
pr "{\n";
- pr " CAMLparam%d (gv" (1 + (nr_args (snd style)));
- iter_args (
+ pr " CAMLparam%d (gv" (1 + (List.length (snd style)));
+ List.iter (
fun arg -> pr ", %sv" (name_of_argt arg)
) (snd style);
pr ");\n";
pr " caml_failwith (\"%s: used handle after closing it\");\n" name;
pr "\n";
- iter_args (
+ List.iter (
function
| String n ->
pr " const char *%s = String_val (%sv);\n" n n
and generate_ocaml_prototype ?(is_external = false) name style =
if is_external then pr "external " else pr "val ";
pr "%s : t -> " name;
- iter_args (
+ List.iter (
function
| String _ -> pr "string -> "
| OptString _ -> pr "string option -> "
generate_call_args ~handle:"g" style;
pr "\n";
pr " guestfs_h *g;\n";
- iter_args (
+ List.iter (
function
| String n -> pr " char *%s;\n" n
| OptString n -> pr " char *%s;\n" n
);
pr "$h->%s (" name;
let comma = ref false in
- iter_args (
+ List.iter (
fun arg ->
if !comma then pr ", ";
comma := true;
let () =
check_functions ();
+ if not (Sys.file_exists "configure.ac") then (
+ eprintf "\
+You are probably running this from the wrong directory.
+Run it from the top source directory using the command
+ src/generator.ml
+";
+ exit 1
+ );
+
let close = output_to "src/guestfs_protocol.x" in
generate_xdr ();
close ();