X-Git-Url: http://git.annexia.org/?p=libguestfs.git;a=blobdiff_plain;f=src%2Fgenerator.ml;h=55b4b8bb37f98559faf995e931d21a32f08dffae;hp=08817c127920e10a6217037199a1a35de791fc3d;hb=677e021225d05e92034a68cb9a9b487e5331d35d;hpb=2d9953097b6d3b71122d444a4550047e97aee009 diff --git a/src/generator.ml b/src/generator.ml index 08817c1..55b4b8b 100755 --- a/src/generator.ml +++ b/src/generator.ml @@ -1,6 +1,6 @@ #!/usr/bin/env ocaml (* libguestfs - * Copyright (C) 2009 Red Hat Inc. + * Copyright (C) 2009-2010 Red Hat Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -19,21 +19,30 @@ (* 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 (see the big table below), and - * daemon/.c to write the implementation. - * - * After editing this file, run it (./src/generator.ml) to regenerate all the - * output files. Note that if you are using a separate build directory you - * must run generator.ml from the _source_ directory. - * + * this one to describe the interface (see the big table of + * 'daemon_functions' below), and daemon/.c to write the + * implementation. + * + * After editing this file, run it (./src/generator.ml) to regenerate + * all the output files. 'make' will rerun this automatically when + * necessary. Note that if you are using a separate build directory + * you must run generator.ml from the _source_ directory. + * * IMPORTANT: This script should NOT print any warnings. If it prints * warnings, you should treat them as errors. + * + * OCaml tips: + * (1) In emacs, install tuareg-mode to display and format OCaml code + * correctly. 'vim' comes with a good OCaml editing mode by default. + * (2) Read the resources at http://ocaml-tutorial.org/ *) #load "unix.cma";; #load "str.cma";; +#directory "+xml-light";; +#load "xml-light.cma";; open Unix open Printf @@ -1861,12 +1870,12 @@ Reread the partition table on C. This uses the L command."); - ("upload", (RErr, [FileIn "filename"; String "remotefilename"]), 66, [], + ("upload", (RErr, [FileIn "filename"; Dev_or_Path "remotefilename"]), 66, [], [InitBasicFS, Always, TestOutput ( (* Pick a file from cwd which isn't likely to change. *) [["upload"; "../COPYING.LIB"; "/COPYING.LIB"]; ["checksum"; "md5"; "/COPYING.LIB"]], - Digest.to_hex (Digest.file "COPYING.LIB"))], + Digest.to_hex (Digest.file "COPYING.LIB"))], "upload a file from the local machine", "\ Upload local file C to C on the @@ -1883,7 +1892,7 @@ See also C."); ["download"; "/COPYING.LIB"; "testdownload.tmp"]; ["upload"; "testdownload.tmp"; "/upload"]; ["checksum"; "md5"; "/upload"]], - Digest.to_hex (Digest.file "COPYING.LIB"))], + Digest.to_hex (Digest.file "COPYING.LIB"))], "download a file to the local machine", "\ Download file C and save it as C @@ -3115,11 +3124,11 @@ a list of devices. This one returns a hash table (map) of device name to directory where the device is mounted."); ("mkmountpoint", (RErr, [String "exemptpath"]), 148, [], - (* This is a special case: while you would expect a parameter - * of type "Pathname", that doesn't work, because it implies - * NEED_ROOT in the generated calling code in stubs.c, and - * this function cannot use NEED_ROOT. - *) + (* This is a special case: while you would expect a parameter + * of type "Pathname", that doesn't work, because it implies + * NEED_ROOT in the generated calling code in stubs.c, and + * this function cannot use NEED_ROOT. + *) [], "create a mountpoint", "\ @@ -3266,7 +3275,7 @@ matching lines."); This calls the external C program and returns the matching lines."); - ("realpath", (RString "rpath", [Pathname "path"]), 163, [], + ("realpath", (RString "rpath", [Pathname "path"]), 163, [Optional "realpath"], [InitISOFS, Always, TestOutput ( [["realpath"; "/../directory"]], "/directory")], "canonicalized absolute pathname", @@ -3638,8 +3647,8 @@ was built (see C in the source)."); ("echo_daemon", (RString "output", [StringList "words"]), 195, [], [InitNone, Always, TestOutput ( - [["echo_daemon"; "This is a test"]], "This is a test" - )], + [["echo_daemon"; "This is a test"]], "This is a test" + )], "echo arguments back to the client", "\ This command concatenate the list of C passed with single spaces between @@ -4105,28 +4114,28 @@ To fill a file with zero bytes (sparsely), it is much more efficient to use C."); ("available", (RErr, [StringList "groups"]), 216, [], - [], + [InitNone, Always, TestRun [["available"; ""]]], "test availability of some parts of the API", "\ This command is used to check the availability of some -groups of libguestfs functions which not all builds of -libguestfs will be able to provide. +groups of functionality in the appliance, which not all builds of +the libguestfs appliance will be able to provide. -The precise libguestfs function groups that may be checked by this -command are listed in L. +The libguestfs groups, and the functions that those +groups correspond to, are listed in L. -The argument C is a list of API group names, eg: +The argument C is a list of group names, eg: C<[\"inotify\", \"augeas\"]> would check for the availability of -the C functions and C -(partition editing) functions. +the Linux inotify functions and Augeas (configuration file +editing) functions. The command returns no error if I requested groups are available. -It returns an error if one or more of the requested -groups is unavailable. +It fails with an error if one or more of the requested +groups is unavailable in the appliance. If an unknown group name is included in the -list of C then an error is always returned. +list of groups then an error is always returned. I @@ -4135,7 +4144,8 @@ I =item * You must call C before calling this function. -The reason is because we don't know what function groups are + +The reason is because we don't know what groups are supported by the appliance/daemon until it is running and can be queried. @@ -4162,6 +4172,22 @@ See also C. =back"); + ("dd", (RErr, [Dev_or_Path "src"; Dev_or_Path "dest"]), 217, [], + [InitBasicFS, Always, TestOutputBuffer ( + [["write_file"; "/src"; "hello, world"; "0"]; + ["dd"; "/src"; "/dest"]; + ["read_file"; "/dest"]], "hello, world")], + "copy from source to destination using dd", + "\ +This command copies from one source device or file C +to another destination device or file C. Normally you +would use this to copy to or from a device or partition, for +example to duplicate a filesystem. + +If the destination is a device, it must be as large or larger +than the source file or device, otherwise the copy will fail. +This command cannot do partial copies."); + ] let all_functions = non_daemon_functions @ daemon_functions @@ -4433,8 +4459,12 @@ let pod2text_memo_updated () = * Note we don't want to use any external OCaml libraries which * makes this a bit harder than it should be. *) +module StringMap = Map.Make (String) + let failwithf fs = ksprintf failwith fs +let unique = let i = ref 0 in fun () -> incr i; !i + let replace_char s c1 c2 = let s2 = String.copy s in let r = ref false in @@ -4780,21 +4810,27 @@ let check_functions () = let chan = ref Pervasives.stdout let pr fs = ksprintf (output_string !chan) fs +let copyright_years = + let this_year = 1900 + (localtime (time ())).tm_year in + if this_year > 2009 then sprintf "2009-%04d" this_year else "2009" + (* Generate a header block in a number of standard styles. *) type comment_style = CStyle | HashStyle | OCamlStyle | HaskellStyle type license = GPLv2 | LGPLv2 -let generate_header comment license = +let generate_header ?(extra_inputs = []) comment license = + let inputs = "src/generator.ml" :: extra_inputs in let c = match comment with | CStyle -> pr "/* "; " *" | HashStyle -> pr "# "; "#" | OCamlStyle -> pr "(* "; " *" | HaskellStyle -> pr "{- "; " " in pr "libguestfs generated file\n"; - pr "%s WARNING: THIS FILE IS GENERATED BY 'src/generator.ml'.\n" c; + pr "%s WARNING: THIS FILE IS GENERATED FROM:\n" c; + List.iter (pr "%s %s\n" c) inputs; pr "%s ANY CHANGES YOU MAKE TO THIS FILE WILL BE LOST.\n" c; pr "%s\n" c; - pr "%s Copyright (C) 2009 Red Hat Inc.\n" c; + pr "%s Copyright (C) %s Red Hat Inc.\n" c copyright_years; pr "%s\n" c; (match license with | GPLv2 -> @@ -6076,8 +6112,8 @@ static void print_table (char const *const *argv) *) let test_names = List.map ( - fun (name, _, _, _, tests, _, _) -> - mapi (generate_one_test name) tests + fun (name, _, _, flags, tests, _, _) -> + mapi (generate_one_test name flags) tests ) (List.rev all_functions) in let test_names = List.concat test_names in let nr_tests = List.length test_names in @@ -6235,7 +6271,7 @@ int main (int argc, char *argv[]) pr " exit (EXIT_SUCCESS);\n"; pr "}\n" -and generate_one_test name i (init, prereq, test) = +and generate_one_test name flags i (init, prereq, test) = let test_name = sprintf "test_%s_%d" name i in pr "\ @@ -6275,6 +6311,26 @@ static int %s (void) " test_name test_name test_name; + (* Optional functions should only be tested if the relevant + * support is available in the daemon. + *) + List.iter ( + function + | Optional group -> + pr " {\n"; + pr " const char *groups[] = { \"%s\", NULL };\n" group; + pr " int r;\n"; + pr " suppress_error = 1;\n"; + pr " r = guestfs_available (g, (char **) groups);\n"; + pr " suppress_error = 0;\n"; + pr " if (r == -1) {\n"; + pr " printf (\" %%s skipped (reason: group %%s not available in daemon)\\n\", \"%s\", groups[0]);\n" test_name; + pr " return 0;\n"; + pr " }\n"; + pr " }\n"; + | _ -> () + ) flags; + (match prereq with | Disabled -> pr " printf (\" %%s skipped (reason: test disabled in generator)\\n\", \"%s\");\n" test_name @@ -6608,6 +6664,8 @@ and generate_test_command_call ?(expect_error = false) ?test test_name cmd = | Int64 _, _ | Bool _, _ | FileIn _, _ | FileOut _, _ -> () + | StringList n, "" | DeviceList n, "" -> + pr " const char *const %s[1] = { NULL };\n" n | StringList n, arg | DeviceList n, arg -> let strs = string_split " " arg in iteri ( @@ -8210,7 +8268,7 @@ sub new { =head1 COPYRIGHT -Copyright (C) 2009 Red Hat Inc. +Copyright (C) %s Red Hat Inc. =head1 LICENSE @@ -8224,7 +8282,7 @@ L, L. =cut -" +" copyright_years and generate_perl_prototype name style = (match fst style with @@ -10267,6 +10325,494 @@ and generate_lang_bindtests call = (* XXX Add here tests of the return and error functions. *) +(* Code to generator bindings for virt-inspector. Currently only + * implemented for OCaml code (for virt-p2v 2.0). + *) +let rng_input = "inspector/virt-inspector.rng" + +(* Read the input file and parse it into internal structures. This is + * by no means a complete RELAX NG parser, but is just enough to be + * able to parse the specific input file. + *) +type rng = + | Element of string * rng list (* *) + | Attribute of string * rng list (* *) + | Interleave of rng list (* *) + | ZeroOrMore of rng (* *) + | OneOrMore of rng (* *) + | Optional of rng (* *) + | Choice of string list (* * *) + | Value of string (* str *) + | Text (* *) + +let rec string_of_rng = function + | Element (name, xs) -> + "Element (\"" ^ name ^ "\", (" ^ string_of_rng_list xs ^ "))" + | Attribute (name, xs) -> + "Attribute (\"" ^ name ^ "\", (" ^ string_of_rng_list xs ^ "))" + | Interleave xs -> "Interleave (" ^ string_of_rng_list xs ^ ")" + | ZeroOrMore rng -> "ZeroOrMore (" ^ string_of_rng rng ^ ")" + | OneOrMore rng -> "OneOrMore (" ^ string_of_rng rng ^ ")" + | Optional rng -> "Optional (" ^ string_of_rng rng ^ ")" + | Choice values -> "Choice [" ^ String.concat ", " values ^ "]" + | Value value -> "Value \"" ^ value ^ "\"" + | Text -> "Text" + +and string_of_rng_list xs = + String.concat ", " (List.map string_of_rng xs) + +let rec parse_rng ?defines context = function + | [] -> [] + | Xml.Element ("element", ["name", name], children) :: rest -> + Element (name, parse_rng ?defines context children) + :: parse_rng ?defines context rest + | Xml.Element ("attribute", ["name", name], children) :: rest -> + Attribute (name, parse_rng ?defines context children) + :: parse_rng ?defines context rest + | Xml.Element ("interleave", [], children) :: rest -> + Interleave (parse_rng ?defines context children) + :: parse_rng ?defines context rest + | Xml.Element ("zeroOrMore", [], [child]) :: rest -> + let rng = parse_rng ?defines context [child] in + (match rng with + | [child] -> ZeroOrMore child :: parse_rng ?defines context rest + | _ -> + failwithf "%s: contains more than one child element" + context + ) + | Xml.Element ("oneOrMore", [], [child]) :: rest -> + let rng = parse_rng ?defines context [child] in + (match rng with + | [child] -> OneOrMore child :: parse_rng ?defines context rest + | _ -> + failwithf "%s: contains more than one child element" + context + ) + | Xml.Element ("optional", [], [child]) :: rest -> + let rng = parse_rng ?defines context [child] in + (match rng with + | [child] -> Optional child :: parse_rng ?defines context rest + | _ -> + failwithf "%s: contains more than one child element" + context + ) + | Xml.Element ("choice", [], children) :: rest -> + let values = List.map ( + function Xml.Element ("value", [], [Xml.PCData value]) -> value + | _ -> + failwithf "%s: can't handle anything except in " + context + ) children in + Choice values + :: parse_rng ?defines context rest + | Xml.Element ("value", [], [Xml.PCData value]) :: rest -> + Value value :: parse_rng ?defines context rest + | Xml.Element ("text", [], []) :: rest -> + Text :: parse_rng ?defines context rest + | Xml.Element ("ref", ["name", name], []) :: rest -> + (* Look up the reference. Because of limitations in this parser, + * we can't handle arbitrarily nested yet. You can only + * use from inside . + *) + (match defines with + | None -> + failwithf "%s: contains , but no refs are defined yet" context + | Some map -> + let rng = StringMap.find name map in + rng @ parse_rng ?defines context rest + ) + | x :: _ -> + failwithf "%s: can't handle '%s' in schema" context (Xml.to_string x) + +let grammar = + let xml = Xml.parse_file rng_input in + match xml with + | Xml.Element ("grammar", _, + Xml.Element ("start", _, gram) :: defines) -> + (* The elements are referenced in the section, + * so build a map of those first. + *) + let defines = List.fold_left ( + fun map -> + function Xml.Element ("define", ["name", name], defn) -> + StringMap.add name defn map + | _ -> + failwithf "%s: expected " rng_input + ) StringMap.empty defines in + let defines = StringMap.mapi parse_rng defines in + + (* Parse the clause, passing the defines. *) + parse_rng ~defines "" gram + | _ -> + failwithf "%s: input is not *" + rng_input + +let name_of_field = function + | Element (name, _) | Attribute (name, _) + | ZeroOrMore (Element (name, _)) + | OneOrMore (Element (name, _)) + | Optional (Element (name, _)) -> name + | Optional (Attribute (name, _)) -> name + | Text -> (* an unnamed field in an element *) + "data" + | rng -> + failwithf "name_of_field failed at: %s" (string_of_rng rng) + +(* At the moment this function only generates OCaml types. However we + * should parameterize it later so it can generate types/structs in a + * variety of languages. + *) +let generate_types xs = + (* A simple type is one that can be printed out directly, eg. + * "string option". A complex type is one which has a name and has + * to be defined via another toplevel definition, eg. a struct. + * + * generate_type generates code for either simple or complex types. + * In the simple case, it returns the string ("string option"). In + * the complex case, it returns the name ("mountpoint"). In the + * complex case it has to print out the definition before returning, + * so it should only be called when we are at the beginning of a + * new line (BOL context). + *) + let rec generate_type = function + | Text -> (* string *) + "string", true + | Choice values -> (* [`val1|`val2|...] *) + "[" ^ String.concat "|" (List.map ((^)"`") values) ^ "]", true + | ZeroOrMore rng -> (* list *) + let t, is_simple = generate_type rng in + t ^ " list (* 0 or more *)", is_simple + | OneOrMore rng -> (* list *) + let t, is_simple = generate_type rng in + t ^ " list (* 1 or more *)", is_simple + (* virt-inspector hack: bool *) + | Optional (Attribute (name, [Value "1"])) -> + "bool", true + | Optional rng -> (* list *) + let t, is_simple = generate_type rng in + t ^ " option", is_simple + (* type name = { fields ... } *) + | Element (name, fields) when is_attrs_interleave fields -> + generate_type_struct name (get_attrs_interleave fields) + | Element (name, [field]) (* type name = field *) + | Attribute (name, [field]) -> + let t, is_simple = generate_type field in + if is_simple then (t, true) + else ( + pr "type %s = %s\n" name t; + name, false + ) + | Element (name, fields) -> (* type name = { fields ... } *) + generate_type_struct name fields + | rng -> + failwithf "generate_type failed at: %s" (string_of_rng rng) + + and is_attrs_interleave = function + | [Interleave _] -> true + | Attribute _ :: fields -> is_attrs_interleave fields + | Optional (Attribute _) :: fields -> is_attrs_interleave fields + | _ -> false + + and get_attrs_interleave = function + | [Interleave fields] -> fields + | ((Attribute _) as field) :: fields + | ((Optional (Attribute _)) as field) :: fields -> + field :: get_attrs_interleave fields + | _ -> assert false + + and generate_types xs = + List.iter (fun x -> ignore (generate_type x)) xs + + and generate_type_struct name fields = + (* Calculate the types of the fields first. We have to do this + * before printing anything so we are still in BOL context. + *) + let types = List.map fst (List.map generate_type fields) in + + (* Special case of a struct containing just a string and another + * field. Turn it into an assoc list. + *) + match types with + | ["string"; other] -> + let fname1, fname2 = + match fields with + | [f1; f2] -> name_of_field f1, name_of_field f2 + | _ -> assert false in + pr "type %s = string * %s (* %s -> %s *)\n" name other fname1 fname2; + name, false + + | types -> + pr "type %s = {\n" name; + List.iter ( + fun (field, ftype) -> + let fname = name_of_field field in + pr " %s_%s : %s;\n" name fname ftype + ) (List.combine fields types); + pr "}\n"; + (* Return the name of this type, and + * false because it's not a simple type. + *) + name, false + in + + generate_types xs + +let generate_parsers xs = + (* As for generate_type above, generate_parser makes a parser for + * some type, and returns the name of the parser it has generated. + * Because it (may) need to print something, it should always be + * called in BOL context. + *) + let rec generate_parser = function + | Text -> (* string *) + "string_child_or_empty" + | Choice values -> (* [`val1|`val2|...] *) + sprintf "(fun x -> match Xml.pcdata (first_child x) with %s | str -> failwith (\"unexpected field value: \" ^ str))" + (String.concat "|" + (List.map (fun v -> sprintf "%S -> `%s" v v) values)) + | ZeroOrMore rng -> (* list *) + let pa = generate_parser rng in + sprintf "(fun x -> List.map %s (Xml.children x))" pa + | OneOrMore rng -> (* list *) + let pa = generate_parser rng in + sprintf "(fun x -> List.map %s (Xml.children x))" pa + (* virt-inspector hack: bool *) + | Optional (Attribute (name, [Value "1"])) -> + sprintf "(fun x -> try ignore (Xml.attrib x %S); true with Xml.No_attribute _ -> false)" name + | Optional rng -> (* list *) + let pa = generate_parser rng in + sprintf "(function None -> None | Some x -> Some (%s x))" pa + (* type name = { fields ... } *) + | Element (name, fields) when is_attrs_interleave fields -> + generate_parser_struct name (get_attrs_interleave fields) + | Element (name, [field]) -> (* type name = field *) + let pa = generate_parser field in + let parser_name = sprintf "parse_%s_%d" name (unique ()) in + pr "let %s =\n" parser_name; + pr " %s\n" pa; + pr "let parse_%s = %s\n" name parser_name; + parser_name + | Attribute (name, [field]) -> + let pa = generate_parser field in + let parser_name = sprintf "parse_%s_%d" name (unique ()) in + pr "let %s =\n" parser_name; + pr " %s\n" pa; + pr "let parse_%s = %s\n" name parser_name; + parser_name + | Element (name, fields) -> (* type name = { fields ... } *) + generate_parser_struct name ([], fields) + | rng -> + failwithf "generate_parser failed at: %s" (string_of_rng rng) + + and is_attrs_interleave = function + | [Interleave _] -> true + | Attribute _ :: fields -> is_attrs_interleave fields + | Optional (Attribute _) :: fields -> is_attrs_interleave fields + | _ -> false + + and get_attrs_interleave = function + | [Interleave fields] -> [], fields + | ((Attribute _) as field) :: fields + | ((Optional (Attribute _)) as field) :: fields -> + let attrs, interleaves = get_attrs_interleave fields in + (field :: attrs), interleaves + | _ -> assert false + + and generate_parsers xs = + List.iter (fun x -> ignore (generate_parser x)) xs + + and generate_parser_struct name (attrs, interleaves) = + (* Generate parsers for the fields first. We have to do this + * before printing anything so we are still in BOL context. + *) + let fields = attrs @ interleaves in + let pas = List.map generate_parser fields in + + (* Generate an intermediate tuple from all the fields first. + * If the type is just a string + another field, then we will + * return this directly, otherwise it is turned into a record. + * + * RELAX NG note: This code treats and plain lists of + * fields the same. In other words, it doesn't bother enforcing + * any ordering of fields in the XML. + *) + pr "let parse_%s x =\n" name; + pr " let t = (\n "; + let comma = ref false in + List.iter ( + fun x -> + if !comma then pr ",\n "; + comma := true; + match x with + | Optional (Attribute (fname, [field])), pa -> + pr "%s x" pa + | Optional (Element (fname, [field])), pa -> + pr "%s (optional_child %S x)" pa fname + | Attribute (fname, [Text]), _ -> + pr "attribute %S x" fname + | (ZeroOrMore _ | OneOrMore _), pa -> + pr "%s x" pa + | Text, pa -> + pr "%s x" pa + | (field, pa) -> + let fname = name_of_field field in + pr "%s (child %S x)" pa fname + ) (List.combine fields pas); + pr "\n ) in\n"; + + (match fields with + | [Element (_, [Text]) | Attribute (_, [Text]); _] -> + pr " t\n" + + | _ -> + pr " (Obj.magic t : %s)\n" name +(* + List.iter ( + function + | (Optional (Attribute (fname, [field])), pa) -> + pr " %s_%s =\n" name fname; + pr " %s x;\n" pa + | (Optional (Element (fname, [field])), pa) -> + pr " %s_%s =\n" name fname; + pr " (let x = optional_child %S x in\n" fname; + pr " %s x);\n" pa + | (field, pa) -> + let fname = name_of_field field in + pr " %s_%s =\n" name fname; + pr " (let x = child %S x in\n" fname; + pr " %s x);\n" pa + ) (List.combine fields pas); + pr "}\n" +*) + ); + sprintf "parse_%s" name + in + + generate_parsers xs + +(* Generate ocaml/guestfs_inspector.mli. *) +let generate_ocaml_inspector_mli () = + generate_header ~extra_inputs:[rng_input] OCamlStyle LGPLv2; + + pr "\ +(** This is an OCaml language binding to the external [virt-inspector] + program. + + For more information, please read the man page [virt-inspector(1)]. +*) + +"; + + generate_types grammar; + pr "(** The nested information returned from the {!inspect} function. *)\n"; + pr "\n"; + + pr "\ +val inspect : ?connect:string -> ?xml:string -> string list -> operatingsystems +(** To inspect a libvirt domain called [name], pass a singleton + list: [inspect [name]]. When using libvirt only, you may + optionally pass a libvirt URI using [inspect ~connect:uri ...]. + + To inspect a disk image or images, pass a list of the filenames + of the disk images: [inspect filenames] + + This function inspects the given guest or disk images and + returns a list of operating system(s) found and a large amount + of information about them. In the vast majority of cases, + a virtual machine only contains a single operating system. + + If the optional [~xml] parameter is given, then this function + skips running the external virt-inspector program and just + parses the given XML directly (which is expected to be XML + produced from a previous run of virt-inspector). The list of + names and connect URI are ignored in this case. + + This function can throw a wide variety of exceptions, for example + if the external virt-inspector program cannot be found, or if + it doesn't generate valid XML. +*) +" + +(* Generate ocaml/guestfs_inspector.ml. *) +let generate_ocaml_inspector_ml () = + generate_header ~extra_inputs:[rng_input] OCamlStyle LGPLv2; + + pr "open Unix\n"; + pr "\n"; + + generate_types grammar; + pr "\n"; + + pr "\ +(* Misc functions which are used by the parser code below. *) +let first_child = function + | Xml.Element (_, _, c::_) -> c + | Xml.Element (name, _, []) -> + failwith (\"expected <\" ^ name ^ \"/> to have a child node\") + | Xml.PCData str -> + failwith (\"expected XML tag, but read PCDATA '\" ^ str ^ \"' instead\") + +let string_child_or_empty = function + | Xml.Element (_, _, [Xml.PCData s]) -> s + | Xml.Element (_, _, []) -> \"\" + | Xml.Element (x, _, _) -> + failwith (\"expected XML tag with a single PCDATA child, but got \" ^ + x ^ \" instead\") + | Xml.PCData str -> + failwith (\"expected XML tag, but read PCDATA '\" ^ str ^ \"' instead\") + +let optional_child name xml = + let children = Xml.children xml in + try + Some (List.find (function + | Xml.Element (n, _, _) when n = name -> true + | _ -> false) children) + with + Not_found -> None + +let child name xml = + match optional_child name xml with + | Some c -> c + | None -> + failwith (\"mandatory field <\" ^ name ^ \"/> missing in XML output\") + +let attribute name xml = + try Xml.attrib xml name + with Xml.No_attribute _ -> + failwith (\"mandatory attribute \" ^ name ^ \" missing in XML output\") + +"; + + generate_parsers grammar; + pr "\n"; + + pr "\ +(* Run external virt-inspector, then use parser to parse the XML. *) +let inspect ?connect ?xml names = + let xml = + match xml with + | None -> + if names = [] then invalid_arg \"inspect: no names given\"; + let cmd = [ \"virt-inspector\"; \"--xml\" ] @ + (match connect with None -> [] | Some uri -> [ \"--connect\"; uri ]) @ + names in + let cmd = List.map Filename.quote cmd in + let cmd = String.concat \" \" cmd in + let chan = open_process_in cmd in + let xml = Xml.parse_in chan in + (match close_process_in chan with + | WEXITED 0 -> () + | WEXITED _ -> failwith \"external virt-inspector command failed\" + | WSIGNALED i | WSTOPPED i -> + failwith (\"external virt-inspector command died or stopped on sig \" ^ + string_of_int i) + ); + xml + | Some doc -> + Xml.parse_string doc in + parse_operatingsystems xml +" + (* This is used to generate the src/MAX_PROC_NR file which * contains the maximum procedure number, a surrogate for the * ABI version number. See src/Makefile.am for the details. @@ -10422,6 +10968,14 @@ Run it from the top source directory using the command generate_ocaml_bindtests (); close (); + let close = output_to "ocaml/guestfs_inspector.mli" in + generate_ocaml_inspector_mli (); + close (); + + let close = output_to "ocaml/guestfs_inspector.ml" in + generate_ocaml_inspector_ml (); + close (); + let close = output_to "perl/Guestfs.xs" in generate_perl_xs (); close ();