* 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
+ * 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]
*)
type style = ret * args
and ret =
- (* "Err" as a return value means an int used as a simple error
+ (* "RErr" as a return value means an int used as a simple error
* indication, ie. 0 or -1.
*)
- | Err
+ | RErr
(* "RInt" as a return value means an int which is -1 for error
* or any value >= 0 on success.
*)
*)
let non_daemon_functions = [
- ("launch", (Err, []), -1, [FishAlias "run"; FishAction "launch"],
+ ("launch", (RErr, []), -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, []), -1, [NotInFish],
+ ("wait_ready", (RErr, []), -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, []), -1, [],
+ ("kill_subprocess", (RErr, []), -1, [],
"kill the qemu subprocess",
"\
This kills the qemu subprocess. You should never need to call this.");
- ("add_drive", (Err, [String "filename"]), -1, [FishAlias "add"],
+ ("add_drive", (RErr, [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, [String "filename"]), -1, [FishAlias "cdrom"],
+ ("add_cdrom", (RErr, [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, [String "qemuparam"; OptString "qemuvalue"]), -1, [],
+ ("config", (RErr, [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, [String "path"]), -1, [FishAlias "path"],
+ ("set_path", (RErr, [String "path"]), -1, [FishAlias "path"],
"set the search path",
"\
Set the path that libguestfs searches for kernel and initrd.img.
This is always non-NULL. If it wasn't set already, then this will
return the default path.");
- ("set_autosync", (Err, [Bool "autosync"]), -1, [FishAlias "autosync"],
+ ("set_autosync", (RErr, [Bool "autosync"]), -1, [FishAlias "autosync"],
"set autosync mode",
"\
If C<autosync> is true, this enables autosync. Libguestfs will make a
"\
Get the autosync flag.");
- ("set_verbose", (Err, [Bool "verbose"]), -1, [FishAlias "verbose"],
+ ("set_verbose", (RErr, [Bool "verbose"]), -1, [FishAlias "verbose"],
"set verbose mode",
"\
If C<verbose> is true, this turns on verbose messages (to C<stderr>).
]
let daemon_functions = [
- ("mount", (Err, [String "device"; String "mountpoint"]), 1, [],
+ ("mount", (RErr, [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, []), 2, [],
+ ("sync", (RErr, []), 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, [String "path"]), 3, [],
+ ("touch", (RErr, [String "path"]), 3, [],
"update file timestamps or create a new file",
"\
Touch acts like the L<touch(1)> command. It can be used to
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, [String "root"; Int "flags"]), 16, [],
+ ("aug_init", (RErr, [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, []), 26, [],
+ ("aug_close", (RErr, []), 26, [],
"close the current Augeas handle",
"\
Close the current Augeas handle and free up any resources
Look up the value associated with C<path>. If C<path>
matches exactly one node, the C<value> is returned.");
- ("aug_set", (Err, [String "path"; String "val"]), 20, [],
+ ("aug_set", (RErr, [String "path"; String "val"]), 20, [],
"set Augeas path to value",
"\
Set the value associated with C<path> to C<value>.");
- ("aug_insert", (Err, [String "path"; String "label"; Bool "before"]), 21, [],
+ ("aug_insert", (RErr, [String "path"; String "label"; Bool "before"]), 21, [],
"insert a sibling Augeas node",
"\
Create a new sibling C<label> for C<path>, inserting it into
On success this returns the number of entries which were removed.");
- ("aug_mv", (Err, [String "src"; String "dest"]), 23, [],
+ ("aug_mv", (RErr, [String "src"; String "dest"]), 23, [],
"move Augeas node",
"\
Move the node C<src> to C<dest>. C<src> must match exactly
The returned paths are sufficiently qualified so that they match
exactly one node in the current tree.");
- ("aug_save", (Err, []), 25, [],
+ ("aug_save", (RErr, []), 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, []), 27, [],
+ ("aug_load", (RErr, []), 27, [],
"load files into the tree",
"\
Load files into the tree.
"\
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 name_of_argt = function String n | OptString n | Bool n | Int n -> n
(* 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
+
+ (* Check function names. *)
List.iter (
- fun (name, _, _, _, _, longdesc) ->
+ 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;
+ failwithf "function name %s should not contain '-', use '_' instead."
+ name
+ ) all_functions;
+
+ (* 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
+
+ (match fst style with
+ | RErr -> ()
+ | 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 long dscriptions. *)
+ List.iter (
+ fun (name, _, _, _, _, longdesc) ->
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
pr "\n\n";
pr "%s\n\n" longdesc;
(match fst style with
- | Err ->
+ | RErr ->
pr "This function returns 0 on success or -1 on error.\n\n"
| RInt _ ->
pr "On error this function returns -1.\n\n"
I<The caller must free the strings and the array after use>.\n\n"
| RIntBool _ ->
pr "This function returns a C<struct guestfs_int_bool *>.
-I<The caller must call C<guestfs_free_int_bool> after use.>.\n\n"
+I<The caller must call C<guestfs_free_int_bool> after use>.\n\n"
| RPVList _ ->
pr "This function returns a C<struct guestfs_lvm_pv_list *>.
-I<The caller must call C<guestfs_free_lvm_pv_list> after use.>.\n\n"
+I<The caller must call C<guestfs_free_lvm_pv_list> after use>.\n\n"
| RVGList _ ->
pr "This function returns a C<struct guestfs_lvm_vg_list *>.
-I<The caller must call C<guestfs_free_lvm_vg_list> after use.>.\n\n"
+I<The caller must call C<guestfs_free_lvm_vg_list> after use>.\n\n"
| RLVList _ ->
pr "This function returns a C<struct guestfs_lvm_lv_list *>.
-I<The caller must call C<guestfs_free_lvm_lv_list> after use.>.\n\n"
+I<The caller must call C<guestfs_free_lvm_lv_list> after use>.\n\n"
);
if List.mem ProtocolLimitWarning flags then
pr "Because of the message protocol, there is a transfer limit
) ["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.
pr "};\n\n"
);
(match fst style with
- | Err -> ()
+ | RErr -> ()
| RInt n ->
pr "struct %s_ret {\n" name;
pr " int %s;\n" n;
pr " struct guestfs_message_header hdr;\n";
pr " struct guestfs_message_error err;\n";
(match fst style with
- | Err -> ()
+ | RErr -> ()
| RConstString _ ->
failwithf "RConstString cannot be returned from a daemon function"
| RInt _
pr " }\n";
(match fst style with
- | Err -> ()
+ | RErr -> ()
| RConstString _ ->
failwithf "RConstString cannot be returned from a daemon function"
| RInt _
let error_code =
match fst style with
- | Err | RInt _ | RBool _ -> "-1"
+ | RErr | RInt _ | RBool _ -> "-1"
| RConstString _ ->
failwithf "RConstString cannot be returned from a daemon function"
| RString _ | RStringList _ | RIntBool _
pr "\n";
(match fst style with
- | Err -> pr " return 0;\n"
+ | RErr -> pr " return 0;\n"
| RInt n
| RBool n -> pr " return rv.ret.%s;\n" n
| RConstString _ ->
pr "{\n";
let error_code =
match fst style with
- | Err | RInt _ -> pr " int r;\n"; "-1"
+ | RErr | RInt _ -> pr " int r;\n"; "-1"
| RBool _ -> pr " int r;\n"; "-1"
| RConstString _ ->
failwithf "RConstString cannot be returned from a daemon function"
pr "\n";
(match fst style with
- | Err -> pr " reply (NULL, NULL);\n"
+ | RErr -> pr " reply (NULL, NULL);\n"
| RInt n ->
pr " struct guestfs_%s_ret ret;\n" name;
pr " ret.%s = r;\n" n;
pr "static int run_%s (const char *cmd, int argc, char *argv[])\n" name;
pr "{\n";
(match fst style with
- | Err
+ | RErr
| RInt _
| RBool _ -> pr " int r;\n"
| RConstString _ -> pr " const char *r;\n"
(* Check return value for errors and display command results. *)
(match fst style with
- | Err -> pr " return r;\n"
+ | RErr -> pr " return r;\n"
| RInt _ ->
pr " if (r == -1) return -1;\n";
pr " if (r) printf (\"%%d\\n\", r);\n";
if extern then pr "extern ";
if static then pr "static ";
(match fst style with
- | Err -> pr "int "
+ | RErr -> pr "int "
| RInt _ -> pr "int "
| RBool _ -> pr "int "
| RConstString _ -> pr "const char *"
) (snd style);
let error_code =
match fst style with
- | Err -> pr " int r;\n"; "-1"
+ | RErr -> pr " int r;\n"; "-1"
| RInt _ -> pr " int r;\n"; "-1"
| RBool _ -> pr " int r;\n"; "-1"
| RConstString _ -> pr " const char *r;\n"; "NULL"
pr "\n";
(match fst style with
- | Err -> pr " rv = Val_unit;\n"
+ | RErr -> pr " rv = Val_unit;\n"
| RInt _ -> pr " rv = Val_int (r);\n"
| RBool _ -> pr " rv = Val_bool (r);\n"
| RConstString _ -> pr " rv = caml_copy_string (r);\n"
| Int _ -> pr "int -> "
) (snd style);
(match fst style with
- | Err -> pr "unit" (* all errors are turned into exceptions *)
+ | RErr -> pr "unit" (* all errors are turned into exceptions *)
| RInt _ -> pr "int"
| RBool _ -> pr "bool"
| RConstString _ -> pr "string"
List.iter (
fun (name, style, _, _, _, _) ->
(match fst style with
- | Err -> pr "void\n"
+ | RErr -> pr "void\n"
| RInt _ -> pr "SV *\n"
| RBool _ -> pr "SV *\n"
| RConstString _ -> pr "SV *\n"
) (snd style);
(* Code. *)
(match fst style with
- | Err ->
+ | RErr ->
pr " PPCODE:\n";
pr " if (guestfs_%s " name;
generate_call_args ~handle:"g" style;
and generate_perl_prototype name style =
(match fst style with
- | Err -> ()
+ | RErr -> ()
| RBool n
| RInt n
| RConstString n
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 ();
git.annexia.org / libguestfs.git / blobdiff