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 of
virt-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.

10 files changed, 738 insertions, 21 deletions

diff --git a/.gitignore b/.gitignore
index 634da994..508f13a7 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
@@ -143,6 +146,7 @@ ocaml/t/guestfs_005_load
 ocaml/t/guestfs_010_launch
 ocaml/t/guestfs_050_lvcreate
 ocaml/t/guestfs_060_readdir
+ocaml/t/guestfs_500_inspect
 perl/bindtests.pl
 perl/blib
 perl/Guestfs.bs
diff --git a/Makefile.am b/Makefile.am
index 90c51f1b..a7197d4b 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -20,12 +20,15 @@ ACLOCAL_AMFLAGS = -I m4
 SUBDIRS = gnulib/lib src daemon appliance fish po examples images \
 	gnulib/tests capitests regressions test-tool
 
-if HAVE_OCAML
-SUBDIRS += ocaml ocaml/examples
-endif
 if HAVE_PERL
 SUBDIRS += perl
 endif
+if HAVE_INSPECTOR
+SUBDIRS += inspector
+endif
+if HAVE_OCAML
+SUBDIRS += ocaml ocaml/examples
+endif
 if HAVE_PYTHON
 SUBDIRS += python
 endif
@@ -38,9 +41,6 @@ endif
 if HAVE_HASKELL
 SUBDIRS += haskell
 endif
-if HAVE_INSPECTOR
-SUBDIRS += inspector
-endif
 if HAVE_DF
 SUBDIRS += df
 endif
diff --git a/README b/README
index 644a76ee..5e00e4e4 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 d1697e7e..c88d51b1 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 d41c42ba..09a144cf 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 00000000..a1d1aa5b
--- /dev/null
+++ b/inspector/inspector_generator.ml
@@ -0,0 +1,634 @@
+#!/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 -> ?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_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 ?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
+"
+
+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 2a582db6..8ed7c5be 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 43af4ad2..7d6e52e5 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 c89296b6..032a5517 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
@@ -53,42 +58,46 @@ TESTS_ENVIRONMENT = \
 
 TESTS = run-bindtests \
 	t/guestfs_005_load t/guestfs_010_launch t/guestfs_050_lvcreate \
-	t/guestfs_060_readdir
+	t/guestfs_060_readdir t/guestfs_500_inspect
 noinst_DATA += bindtests \
 	t/guestfs_005_load t/guestfs_010_launch t/guestfs_050_lvcreate \
-	t/guestfs_060_readdir
+	t/guestfs_060_readdir t/guestfs_500_inspect
 
 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 $@
+
+t/guestfs_500_inspect: t/guestfs_500_inspect.cmx mlguestfs.cmxa
+	mkdir -p t
+	$(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 +122,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).
diff --git a/ocaml/t/guestfs_500_inspect.ml b/ocaml/t/guestfs_500_inspect.ml
new file mode 100644
index 00000000..ec1071a9
--- /dev/null
+++ b/ocaml/t/guestfs_500_inspect.ml
@@ -0,0 +1,42 @@
+(* libguestfs OCaml bindings
+ * 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., 675 Mass Ave, Cambridge, MA 02139, USA.
+ *)
+
+open Unix
+
+let (//) = Filename.concat
+let dotdot = Filename.parent_dir_name
+
+let read_file name =
+  let chan = open_in name in
+  let lines = ref [] in
+  let lines =
+    try while true do lines := input_line chan :: !lines done; []
+    with End_of_file -> List.rev !lines in
+  close_in chan;
+  String.concat "" lines
+
+let parse name =
+  let xml = read_file name in
+  let os = Guestfs_inspector.inspect ~xml [] in
+  os
+
+let () =
+  ignore (parse (dotdot // "inspector" // "example1.xml"));
+  ignore (parse (dotdot // "inspector" // "example2.xml"));
+  ignore (parse (dotdot // "inspector" // "example3.xml"));
+  ignore (parse (dotdot // "inspector" // "example4.xml"))