Richard W.M. Jones
2009-Oct-13 15:55 UTC
[Libguestfs] [PATCH] inspector: Generate language bindings for OCaml.
-- Richard Jones, Virtualization Group, Red Hat http://people.redhat.com/~rjones New in Fedora 11: Fedora Windows cross-compiler. Compile Windows programs, test, and build Windows installers. Over 70 libraries supprt'd http://fedoraproject.org/wiki/MinGW http://www.annexia.org/fedora_mingw -------------- next part -------------->From 9beb6ecc0211b504d39c17bd8e1be21e0ec29a40 Mon Sep 17 00:00:00 2001From: Richard Jones <rjones at trick.home.annexia.org> Date: Fri, 2 Oct 2009 15:42:14 +0100 Subject: [PATCH] inspector: Generate language bindings for OCaml. This commit adds a generic mechanism for deriving language bindings for virt-inspector, and implements one concrete binding, for OCaml. The bindings are generated from the RELAX NG schema (virt-inspector.rng) which is supposed to be a correct and always up to date description of the XML that the virt-inspector program can generate.>From the RNG we generate a set of types to describe the output ofvirt-inspector for the language, plus an XML parser, plus some glue code to actually run an external instance of virt-inspector and parse the resulting XML. At runtime, an external 'virt-inspector --xml <name>' command runs and the XML is parsed into language-specific structures. This has been tested on the four example files (inspector/example?.xml) The only particular difficulty about the OCaml binding is the use of Obj.magic, which is naughty but works because of the isomorphism between the representation of tuples and records in OCaml. This seems to cause no problems in my test program. Apart from this, the OCaml binding is straightforward and could be adapted easily for any other languages that want type-safe virt-inspector bindings. It's important to keep virt-inspector.rng up to date with changes to virt-inspector's XML output format. --- .gitignore | 3 + README | 6 + configure.ac | 17 + inspector/Makefile.am | 14 +- inspector/inspector_generator.ml | 625 ++++++++++++++++++++++++++++++++++++++ ocaml/.depend | 3 + ocaml/Makefile.am | 1 + 7 files changed, 668 insertions(+), 1 deletions(-) create mode 100644 inspector/inspector_generator.ml diff --git a/.gitignore b/.gitignore index 634da99..6237ebc 100644 --- a/.gitignore +++ b/.gitignore @@ -90,6 +90,7 @@ images/test-grep.txt.gz initramfs initramfs.timestamp inspector/virt-inspector.1 +inspector/stamp-inspector-generator install-sh *.jar java/api @@ -136,6 +137,8 @@ ocaml/examples/lvs ocaml/examples/throbber.ml ocaml/examples/viewer ocaml/guestfs_c_actions.c +ocaml/guestfs_inspector.ml +ocaml/guestfs_inspector.mli ocaml/guestfs.ml ocaml/guestfs.mli ocaml/META diff --git a/README b/README index 644a76e..8ca3405 100644 --- a/README +++ b/README @@ -65,6 +65,12 @@ Requirements - (Optional) OCaml if you want to rebuild the generated files, and also to build the OCaml bindings +- (Optional) OCaml xml-light, only needed if you want to rebuild the + virt-inspector bindings from virt-inspector.rng. + +- (Optional) OCaml extlib, only needed if you want to rebuild the + virt-inspector bindings from virt-inspector.rng. + - (Optional) local Fedora mirror - (Optional) Perl if you want to build the perl bindings diff --git a/configure.ac b/configure.ac index d1697e7..17ea2f2 100644 --- a/configure.ac +++ b/configure.ac @@ -420,6 +420,23 @@ AC_PROG_OCAML AC_PROG_FINDLIB AM_CONDITIONAL([HAVE_OCAML],[test "x$OCAMLC" != "xno" -a "x$OCAMLFIND" != "xno"]) +dnl Optional xml-light for building virt-inspector language bindings +dnl from the virt-inspector.rng file. +OCAML_PKG_xml_light=no +if test "x$OCAMLC" != "xno" -a "x$OCAMLFIND" != "xno"; then + AC_CHECK_OCAML_PKG([xml-light]) +fi + +dnl Optional extlib for building virt-inspector language bindings +dnl from the virt-inspector.rng file. +OCAML_PKG_extlib=no +if test "x$OCAMLC" != "xno" -a "x$OCAMLFIND" != "xno"; then + AC_CHECK_OCAML_PKG([extlib]) +fi + +AM_CONDITIONAL([CAN_RUN_INSPECTOR_GENERATOR], + [test "x$OCAMLC" != "xno" -a "x$OCAMLFIND" != "xno" -a "x$OCAML_PKG_xml_light" != "xno" -a "x$OCAML_PKG_extlib" != "xno"]) + dnl Build the OCaml viewer example. This has a lengthy list of dnl dependencies and we don't attempt to detect them all. Read dnl the top of ocaml/examples/viewer.ml before enabling this. diff --git a/inspector/Makefile.am b/inspector/Makefile.am index d41c42b..7b4c922 100644 --- a/inspector/Makefile.am +++ b/inspector/Makefile.am @@ -28,7 +28,8 @@ if HAVE_INSPECTOR bin_SCRIPTS = virt-inspector man_MANS = virt-inspector.1 -noinst_DATA = $(top_builddir)/html/virt-inspector.1.html +noinst_DATA = \ + $(top_builddir)/html/virt-inspector.1.html stamp-inspector-generator virt-inspector.1: virt-inspector $(POD2MAN) \ @@ -53,4 +54,15 @@ TESTS_ENVIRONMENT = $(XMLLINT) --noout --relaxng virt-inspector.rng endif +if CAN_RUN_INSPECTOR_GENERATOR +stamp-inspector-generator: inspector_generator.ml + cd $(top_srcdir) && \ + ocaml -warn-error A \ + inspector/inspector_generator.ml + touch $@ +else +stamp-inspector-generator: + touch $@ +endif + endif diff --git a/inspector/inspector_generator.ml b/inspector/inspector_generator.ml new file mode 100644 index 0000000..92b556a --- /dev/null +++ b/inspector/inspector_generator.ml @@ -0,0 +1,625 @@ +#!/usr/bin/env ocaml +(* libguestfs + * Copyright (C) 2009 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 + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * 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 program generates language bindings for virt-inspector, so + * you can use it from programs (other than Perl programs). + * + * At compile time, the bindings are generated from the file + * [virt-inspector.rng], which is the RELAX NG schema that describes + * the output of the [virt-inspector --xml] command. + * + * At run time, code using these bindings runs the external + * [virt-inspector --xml] command, and parses the XML that this + * generates into language-specific structures. + *) + +(* Unlike src/generator.ml, we allow ourselves to go wild here and use + * a reasonable number of OCaml libraries. NOTE TO DEVELOPERS: You + * still have to detect the libraries in configure.ac and add them to + * inspector/Makefile.am. + *) +#load "unix.cma";; +#directory "+extlib";; +#load "extLib.cma";; +#directory "+xml-light";; +#load "xml-light.cma";; + +open Printf +open ExtList + +module StringMap = Map.Make (String) + +let failwithf fs = ksprintf failwith fs +let unique = let i = ref 0 in fun () -> incr i; !i + +(* Check we're running from the right directory. *) +let () + if not (Sys.file_exists "HACKING") then ( + eprintf "You are probably running this from the wrong directory.\n"; + exit 1 + ) + +let 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 (* <element name=name/> *) + | Attribute of string * rng list (* <attribute name=name/> *) + | Interleave of rng list (* <interleave/> *) + | ZeroOrMore of rng (* <zeroOrMore/> *) + | OneOrMore of rng (* <oneOrMore/> *) + | Optional of rng (* <optional/> *) + | Choice of string list (* <choice><value/>*</choice> *) + | Value of string (* <value>str</value> *) + | Text (* <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: <zeroOrMore> 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: <oneOrMore> 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: <optional> 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 <value> in <choice>" + 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 <ref> yet. You can only + * use <ref> from inside <start>. + *) + (match defines with + | None -> + failwithf "%s: contains <ref>, 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 input in + match xml with + | Xml.Element ("grammar", _, + Xml.Element ("start", _, gram) :: defines) -> + (* The <define/> elements are referenced in the <start> 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 <define name=name/>" input + ) StringMap.empty defines in + let defines = StringMap.mapi parse_rng defines in + + (* Parse the <start> clause, passing the defines. *) + parse_rng ~defines "<start>" gram + | _ -> + failwithf "%s: input is not <grammar><start/><define>*</grammar>" input + +(* '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 | HaskellStyle +type license = GPLv2 | LGPLv2 + +let generate_header comment license + 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 'inspector/inspector_generator.ml'\n" c; + pr "%s FROM THE RELAX NG SCHEMA AT '%s'.\n" c input; + 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\n" c; + (match license with + | GPLv2 -> + pr "%s This program is free software; you can redistribute it and/or modify\n" c; + pr "%s it under the terms of the GNU General Public License as published by\n" c; + pr "%s the Free Software Foundation; either version 2 of the License, or\n" c; + pr "%s (at your option) any later version.\n" c; + pr "%s\n" c; + pr "%s This program is distributed in the hope that it will be useful,\n" c; + pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c; + pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n" c; + pr "%s GNU General Public License for more details.\n" c; + pr "%s\n" c; + pr "%s You should have received a copy of the GNU General Public License along\n" c; + pr "%s with this program; if not, write to the Free Software Foundation, Inc.,\n" c; + pr "%s 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n" c; + + | LGPLv2 -> + pr "%s This library is free software; you can redistribute it and/or\n" c; + pr "%s modify it under the terms of the GNU Lesser General Public\n" c; + pr "%s License as published by the Free Software Foundation; either\n" c; + pr "%s version 2 of the License, or (at your option) any later version.\n" c; + pr "%s\n" c; + pr "%s This library is distributed in the hope that it will be useful,\n" c; + pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c; + pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU\n" c; + pr "%s Lesser General Public License for more details.\n" c; + pr "%s\n" c; + pr "%s You should have received a copy of the GNU Lesser General Public\n" c; + pr "%s License along with this library; if not, write to the Free Software\n" c; + pr "%s Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA\n" c; + ); + (match comment with + | CStyle -> pr " */\n" + | HashStyle -> () + | OCamlStyle -> pr " *)\n" + | HaskellStyle -> pr "-}\n" + ); + pr "\n" + +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 -> (* <rng> list *) + let t, is_simple = generate_type rng in + t ^ " list (* 0 or more *)", is_simple + | OneOrMore rng -> (* <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 -> (* <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 -> (* <rng> list *) + let pa = generate_parser rng in + sprintf "(fun x -> List.map %s (Xml.children x))" pa + | OneOrMore rng -> (* <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 -> (* <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 <interleave> 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_mli () + generate_header 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 -> 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. + + 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_ml () + generate_header 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 names + 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) + ); + parse_operatingsystems xml +" + +let files_equal n1 n2 + let cmd = sprintf "cmp -s %s %s" (Filename.quote n1) (Filename.quote n2) in + match Sys.command cmd with + | 0 -> true + | 1 -> false + | i -> failwithf "%s: failed with error code %d" cmd i + +let output_to filename + let filename_new = filename ^ ".new" in + chan := open_out filename_new; + let close () + close_out !chan; + chan := stdout; + + (* Is the new file different from the current file? *) + if Sys.file_exists filename && files_equal filename filename_new then + Unix.unlink filename_new (* same, so skip it *) + else ( + (* different, overwrite old one *) + (try Unix.chmod filename 0o644 with Unix.Unix_error _ -> ()); + Unix.rename filename_new filename; + Unix.chmod filename 0o444; + printf "written %s\n%!" filename; + ) + in + close + +(* Output. *) +let () + let close = output_to "ocaml/guestfs_inspector.mli" in + generate_ocaml_mli (); + close (); + + let close = output_to "ocaml/guestfs_inspector.ml" in + generate_ocaml_ml (); + close () diff --git a/ocaml/.depend b/ocaml/.depend index 2a582db..8ed7c5b 100644 --- a/ocaml/.depend +++ b/ocaml/.depend @@ -1,5 +1,8 @@ guestfs.cmi: +guestfs_inspector.cmi: bindtests.cmo: guestfs.cmi bindtests.cmx: guestfs.cmx guestfs.cmo: guestfs.cmi guestfs.cmx: guestfs.cmi +guestfs_inspector.cmo: guestfs_inspector.cmi +guestfs_inspector.cmx: guestfs_inspector.cmi diff --git a/ocaml/Makefile.am b/ocaml/Makefile.am index c89296b..a9938c8 100644 --- a/ocaml/Makefile.am +++ b/ocaml/Makefile.am @@ -18,6 +18,7 @@ EXTRA_DIST = \ guestfs.mli guestfs.ml \ guestfs_c.c guestfs_c.h guestfs_c_actions.c \ + guestfs_inspector.mli guestfs_inspector.ml \ .depend META.in \ bindtests.ml \ run-bindtests \ -- 1.6.2.5
Richard W.M. Jones
2009-Oct-13 16:27 UTC
[Libguestfs] [PATCH v2] inspector: Generate language bindings for OCaml.
Better patch attached. Rich. -- Richard Jones, Virtualization Group, Red Hat http://people.redhat.com/~rjones virt-p2v converts physical machines to virtual machines. Boot with a live CD or over the network (PXE) and turn machines into Xen guests. http://et.redhat.com/~rjones/virt-p2v -------------- next part -------------->From e2ec67829282e6ed1761a9f68da3cb10e4323dd3 Mon Sep 17 00:00:00 2001From: Richard Jones <rjones at trick.home.annexia.org> Date: Fri, 2 Oct 2009 15:42:14 +0100 Subject: [PATCH] inspector: Generate language bindings for OCaml. This commit adds a generic mechanism for deriving language bindings for virt-inspector, and implements one concrete binding, for OCaml. The bindings are generated from the RELAX NG schema (virt-inspector.rng) which is supposed to be a correct and always up to date description of the XML that the virt-inspector program can generate.>From the RNG we generate a set of types to describe the output ofvirt-inspector for the language, plus an XML parser, plus some glue code to actually run an external instance of virt-inspector and parse the resulting XML. At runtime, an external 'virt-inspector --xml <name>' command runs and the XML is parsed into language-specific structures. This has been tested on the four example files (inspector/example?.xml) The only particular difficulty about the OCaml binding is the use of Obj.magic, which is naughty but works because of the isomorphism between the representation of tuples and records in OCaml. This seems to cause no problems in my test program. Apart from this, the OCaml binding is straightforward and could be adapted easily for any other languages that want type-safe virt-inspector bindings. It's important to keep virt-inspector.rng up to date with changes to virt-inspector's XML output format. --- .gitignore | 3 + README | 3 + configure.ac | 8 + inspector/Makefile.am | 14 +- inspector/inspector_generator.ml | 622 ++++++++++++++++++++++++++++++++++++++ ocaml/.depend | 3 + ocaml/META.in | 3 +- ocaml/Makefile.am | 28 +- 8 files changed, 671 insertions(+), 13 deletions(-) create mode 100644 inspector/inspector_generator.ml diff --git a/.gitignore b/.gitignore index 634da99..6237ebc 100644 --- a/.gitignore +++ b/.gitignore @@ -90,6 +90,7 @@ images/test-grep.txt.gz initramfs initramfs.timestamp inspector/virt-inspector.1 +inspector/stamp-inspector-generator install-sh *.jar java/api @@ -136,6 +137,8 @@ ocaml/examples/lvs ocaml/examples/throbber.ml ocaml/examples/viewer ocaml/guestfs_c_actions.c +ocaml/guestfs_inspector.ml +ocaml/guestfs_inspector.mli ocaml/guestfs.ml ocaml/guestfs.mli ocaml/META diff --git a/README b/README index 644a76e..5e00e4e 100644 --- a/README +++ b/README @@ -65,6 +65,9 @@ Requirements - (Optional) OCaml if you want to rebuild the generated files, and also to build the OCaml bindings +- (Optional) OCaml xml-light, only needed if you want to rebuild the + virt-inspector bindings from virt-inspector.rng. + - (Optional) local Fedora mirror - (Optional) Perl if you want to build the perl bindings diff --git a/configure.ac b/configure.ac index d1697e7..c88d51b 100644 --- a/configure.ac +++ b/configure.ac @@ -420,6 +420,14 @@ AC_PROG_OCAML AC_PROG_FINDLIB AM_CONDITIONAL([HAVE_OCAML],[test "x$OCAMLC" != "xno" -a "x$OCAMLFIND" != "xno"]) +dnl Optional xml-light for building virt-inspector language bindings +dnl from the virt-inspector.rng file. +OCAML_PKG_xml_light=no +if test "x$OCAMLC" != "xno" -a "x$OCAMLFIND" != "xno"; then + AC_CHECK_OCAML_PKG([xml-light]) +fi +AM_CONDITIONAL([HAVE_XML_LIGHT],[test "x$OCAML_PKG_xml_light" != "xno"]) + dnl Build the OCaml viewer example. This has a lengthy list of dnl dependencies and we don't attempt to detect them all. Read dnl the top of ocaml/examples/viewer.ml before enabling this. diff --git a/inspector/Makefile.am b/inspector/Makefile.am index d41c42b..09a144c 100644 --- a/inspector/Makefile.am +++ b/inspector/Makefile.am @@ -28,7 +28,8 @@ if HAVE_INSPECTOR bin_SCRIPTS = virt-inspector man_MANS = virt-inspector.1 -noinst_DATA = $(top_builddir)/html/virt-inspector.1.html +noinst_DATA = \ + $(top_builddir)/html/virt-inspector.1.html stamp-inspector-generator virt-inspector.1: virt-inspector $(POD2MAN) \ @@ -53,4 +54,15 @@ TESTS_ENVIRONMENT = $(XMLLINT) --noout --relaxng virt-inspector.rng endif +if HAVE_XML_LIGHT +stamp-inspector-generator: inspector_generator.ml + cd $(top_srcdir) && \ + ocaml -warn-error A \ + inspector/inspector_generator.ml + touch $@ +else +stamp-inspector-generator: + touch $@ +endif + endif diff --git a/inspector/inspector_generator.ml b/inspector/inspector_generator.ml new file mode 100644 index 0000000..2e244d2 --- /dev/null +++ b/inspector/inspector_generator.ml @@ -0,0 +1,622 @@ +#!/usr/bin/env ocaml +(* libguestfs + * Copyright (C) 2009 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 + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * 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 program generates language bindings for virt-inspector, so + * you can use it from programs (other than Perl programs). + * + * At compile time, the bindings are generated from the file + * [virt-inspector.rng], which is the RELAX NG schema that describes + * the output of the [virt-inspector --xml] command. + * + * At run time, code using these bindings runs the external + * [virt-inspector --xml] command, and parses the XML that this + * generates into language-specific structures. + *) + +(* Unlike src/generator.ml, we allow ourselves to go wild here and use + * a reasonable number of OCaml libraries. NOTE TO DEVELOPERS: You + * still have to detect the libraries in configure.ac and add them to + * inspector/Makefile.am. + *) +#load "unix.cma";; +#directory "+xml-light";; +#load "xml-light.cma";; + +open Printf + +module StringMap = Map.Make (String) + +let failwithf fs = ksprintf failwith fs +let unique = let i = ref 0 in fun () -> incr i; !i + +(* Check we're running from the right directory. *) +let () + if not (Sys.file_exists "HACKING") then ( + eprintf "You are probably running this from the wrong directory.\n"; + exit 1 + ) + +let 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 (* <element name=name/> *) + | Attribute of string * rng list (* <attribute name=name/> *) + | Interleave of rng list (* <interleave/> *) + | ZeroOrMore of rng (* <zeroOrMore/> *) + | OneOrMore of rng (* <oneOrMore/> *) + | Optional of rng (* <optional/> *) + | Choice of string list (* <choice><value/>*</choice> *) + | Value of string (* <value>str</value> *) + | Text (* <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: <zeroOrMore> 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: <oneOrMore> 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: <optional> 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 <value> in <choice>" + 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 <ref> yet. You can only + * use <ref> from inside <start>. + *) + (match defines with + | None -> + failwithf "%s: contains <ref>, 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 input in + match xml with + | Xml.Element ("grammar", _, + Xml.Element ("start", _, gram) :: defines) -> + (* The <define/> elements are referenced in the <start> 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 <define name=name/>" input + ) StringMap.empty defines in + let defines = StringMap.mapi parse_rng defines in + + (* Parse the <start> clause, passing the defines. *) + parse_rng ~defines "<start>" gram + | _ -> + failwithf "%s: input is not <grammar><start/><define>*</grammar>" input + +(* '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 | HaskellStyle +type license = GPLv2 | LGPLv2 + +let generate_header comment license + 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 'inspector/inspector_generator.ml'\n" c; + pr "%s FROM THE RELAX NG SCHEMA AT '%s'.\n" c input; + 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\n" c; + (match license with + | GPLv2 -> + pr "%s This program is free software; you can redistribute it and/or modify\n" c; + pr "%s it under the terms of the GNU General Public License as published by\n" c; + pr "%s the Free Software Foundation; either version 2 of the License, or\n" c; + pr "%s (at your option) any later version.\n" c; + pr "%s\n" c; + pr "%s This program is distributed in the hope that it will be useful,\n" c; + pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c; + pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n" c; + pr "%s GNU General Public License for more details.\n" c; + pr "%s\n" c; + pr "%s You should have received a copy of the GNU General Public License along\n" c; + pr "%s with this program; if not, write to the Free Software Foundation, Inc.,\n" c; + pr "%s 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n" c; + + | LGPLv2 -> + pr "%s This library is free software; you can redistribute it and/or\n" c; + pr "%s modify it under the terms of the GNU Lesser General Public\n" c; + pr "%s License as published by the Free Software Foundation; either\n" c; + pr "%s version 2 of the License, or (at your option) any later version.\n" c; + pr "%s\n" c; + pr "%s This library is distributed in the hope that it will be useful,\n" c; + pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c; + pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU\n" c; + pr "%s Lesser General Public License for more details.\n" c; + pr "%s\n" c; + pr "%s You should have received a copy of the GNU Lesser General Public\n" c; + pr "%s License along with this library; if not, write to the Free Software\n" c; + pr "%s Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA\n" c; + ); + (match comment with + | CStyle -> pr " */\n" + | HashStyle -> () + | OCamlStyle -> pr " *)\n" + | HaskellStyle -> pr "-}\n" + ); + pr "\n" + +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 -> (* <rng> list *) + let t, is_simple = generate_type rng in + t ^ " list (* 0 or more *)", is_simple + | OneOrMore rng -> (* <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 -> (* <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 -> (* <rng> list *) + let pa = generate_parser rng in + sprintf "(fun x -> List.map %s (Xml.children x))" pa + | OneOrMore rng -> (* <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 -> (* <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 <interleave> 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_mli () + generate_header 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 -> 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. + + 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_ml () + generate_header 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 names + 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) + ); + parse_operatingsystems xml +" + +let files_equal n1 n2 + let cmd = sprintf "cmp -s %s %s" (Filename.quote n1) (Filename.quote n2) in + match Sys.command cmd with + | 0 -> true + | 1 -> false + | i -> failwithf "%s: failed with error code %d" cmd i + +let output_to filename + let filename_new = filename ^ ".new" in + chan := open_out filename_new; + let close () + close_out !chan; + chan := stdout; + + (* Is the new file different from the current file? *) + if Sys.file_exists filename && files_equal filename filename_new then + Unix.unlink filename_new (* same, so skip it *) + else ( + (* different, overwrite old one *) + (try Unix.chmod filename 0o644 with Unix.Unix_error _ -> ()); + Unix.rename filename_new filename; + Unix.chmod filename 0o444; + printf "written %s\n%!" filename; + ) + in + close + +(* Output. *) +let () + let close = output_to "ocaml/guestfs_inspector.mli" in + generate_ocaml_mli (); + close (); + + let close = output_to "ocaml/guestfs_inspector.ml" in + generate_ocaml_ml (); + close () diff --git a/ocaml/.depend b/ocaml/.depend index 2a582db..8ed7c5b 100644 --- a/ocaml/.depend +++ b/ocaml/.depend @@ -1,5 +1,8 @@ guestfs.cmi: +guestfs_inspector.cmi: bindtests.cmo: guestfs.cmi bindtests.cmx: guestfs.cmx guestfs.cmo: guestfs.cmi guestfs.cmx: guestfs.cmi +guestfs_inspector.cmo: guestfs_inspector.cmi +guestfs_inspector.cmx: guestfs_inspector.cmi diff --git a/ocaml/META.in b/ocaml/META.in index 43af4ad..7d6e52e 100644 --- a/ocaml/META.in +++ b/ocaml/META.in @@ -1,5 +1,6 @@ name="guestfs" version="@PACKAGE_VERSION@" -description="libguestfs bindings for OCaml" +description="libguestfs and virt-inspector bindings for OCaml" +requires="xml-light,unix" archive(byte)="mlguestfs.cma" archive(native)="mlguestfs.cmxa" diff --git a/ocaml/Makefile.am b/ocaml/Makefile.am index c89296b..5d85e71 100644 --- a/ocaml/Makefile.am +++ b/ocaml/Makefile.am @@ -18,6 +18,7 @@ EXTRA_DIST = \ guestfs.mli guestfs.ml \ guestfs_c.c guestfs_c.h guestfs_c_actions.c \ + guestfs_inspector.mli guestfs_inspector.ml \ .depend META.in \ bindtests.ml \ run-bindtests \ @@ -31,13 +32,17 @@ AM_CPPFLAGS = -I$(top_builddir) -I$(OCAMLLIB) -I$(top_srcdir)/ocaml \ $(WARN_CFLAGS) $(WERROR_CFLAGS) if HAVE_OCAML +if HAVE_XML_LIGHT noinst_DATA = mlguestfs.cma mlguestfs.cmxa META -mlguestfs.cma: guestfs_c.o guestfs_c_actions.o guestfs.cmo +OBJS = guestfs_c.o guestfs_c_actions.o guestfs.cmo guestfs_inspector.cmo +XOBJS = $(OBJS:.cmo=.cmx) + +mlguestfs.cma: $(OBJS) $(OCAMLMKLIB) -o mlguestfs $^ -L$(top_builddir)/src/.libs -lguestfs -mlguestfs.cmxa: guestfs_c.o guestfs_c_actions.o guestfs.cmx +mlguestfs.cmxa: $(XOBJS) $(OCAMLMKLIB) -o mlguestfs $^ -L$(top_builddir)/src/.libs -lguestfs guestfs_c.o: guestfs_c.c @@ -60,35 +65,35 @@ noinst_DATA += bindtests \ bindtests: bindtests.cmx mlguestfs.cmxa mkdir -p t - $(OCAMLFIND) ocamlopt -cclib -L$(top_builddir)/src/.libs -I . unix.cmxa mlguestfs.cmxa $< -o $@ + $(OCAMLFIND) ocamlopt -cclib -L$(top_builddir)/src/.libs -I . -package xml-light,unix -linkpkg mlguestfs.cmxa $< -o $@ t/guestfs_005_load: t/guestfs_005_load.cmx mlguestfs.cmxa mkdir -p t - $(OCAMLFIND) ocamlopt -cclib -L$(top_builddir)/src/.libs -I . unix.cmxa mlguestfs.cmxa $< -o $@ + $(OCAMLFIND) ocamlopt -cclib -L$(top_builddir)/src/.libs -I . -package xml-light,unix -linkpkg mlguestfs.cmxa $< -o $@ t/guestfs_010_launch: t/guestfs_010_launch.cmx mlguestfs.cmxa mkdir -p t - $(OCAMLFIND) ocamlopt -cclib -L$(top_builddir)/src/.libs -I . unix.cmxa mlguestfs.cmxa $< -o $@ + $(OCAMLFIND) ocamlopt -cclib -L$(top_builddir)/src/.libs -I . -package xml-light,unix -linkpkg mlguestfs.cmxa $< -o $@ t/guestfs_050_lvcreate: t/guestfs_050_lvcreate.cmx mlguestfs.cmxa mkdir -p t - $(OCAMLFIND) ocamlopt -cclib -L$(top_builddir)/src/.libs -I . unix.cmxa mlguestfs.cmxa $< -o $@ + $(OCAMLFIND) ocamlopt -cclib -L$(top_builddir)/src/.libs -I . -package xml-light,unix -linkpkg mlguestfs.cmxa $< -o $@ t/guestfs_060_readdir: t/guestfs_060_readdir.cmx mlguestfs.cmxa mkdir -p t - $(OCAMLFIND) ocamlopt -cclib -L$(top_builddir)/src/.libs -I . unix.cmxa mlguestfs.cmxa $< -o $@ + $(OCAMLFIND) ocamlopt -cclib -L$(top_builddir)/src/.libs -I . -package xml-light,unix -linkpkg mlguestfs.cmxa $< -o $@ # Need to rebuild the tests from source if the main library has # changed at all, otherwise we get inconsistent assumptions. t/%.cmx: t/%.ml mlguestfs.cmxa - $(OCAMLFIND) ocamlopt -c $< -o $@ + $(OCAMLFIND) ocamlopt -package xml-light,unix -linkpkg -c $< -o $@ .mli.cmi: - $(OCAMLFIND) ocamlc -c $< -o $@ + $(OCAMLFIND) ocamlc -package xml-light,unix -c $< -o $@ .ml.cmo: - $(OCAMLFIND) ocamlc -c $< -o $@ + $(OCAMLFIND) ocamlc -package xml-light,unix -c $< -o $@ .ml.cmx: - $(OCAMLFIND) ocamlopt -c $< -o $@ + $(OCAMLFIND) ocamlopt -package xml-light,unix -c $< -o $@ depend: .depend @@ -113,6 +118,7 @@ install-data-hook: CLEANFILES += $(noinst_DATA) endif +endif # Tell version 3.79 and up of GNU make to not build goals in this # directory in parallel. (Possible solution for RHBZ#502309). -- 1.6.2.5
Possibly Parallel Threads
- [PATCH 0/3] Three code cleanups
- [PATCH febootstrap 0/8] Add support for building an ext2-based appliance
- Some more Virt-P2V CD results - screenshot attached as promised
- [PATCH] Improved error if virt-inspector cannot find OSes in image (RHBZ#591142).
- [PATCH febootstrap 0/2] febootstrap-supermin-helper should visit directory entries in order and ignore backup files