diff options
Diffstat (limited to 'inspector')
| -rw-r--r-- | inspector/Makefile.am | 14 | ||||
| -rw-r--r-- | inspector/inspector_generator.ml | 634 |
2 files changed, 647 insertions, 1 deletions
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 () |