From: Richard Jones Date: Thu, 31 Dec 2009 11:20:56 +0000 (+0000) Subject: Remove separate inspector_generator.ml, combine this with generator.ml. X-Git-Tag: 1.0.81~17 X-Git-Url: http://git.annexia.org/?p=libguestfs.git;a=commitdiff_plain;h=2e2eb15df010bbcc605c86b0714ad1ca796fc96d Remove separate inspector_generator.ml, combine this with generator.ml. This commit combines the previously separate "inspector_generator.ml" program which generated bindings for virt-inspector. Having two separate programs caused no end of troubles for developers, so we now combine them into a single program. NOTE: OCaml xml-light is now *required* in order to rebuild the generated code. --- diff --git a/README b/README index 0877775..8e8be59 100644 --- a/README +++ b/README @@ -66,11 +66,9 @@ Requirements - (Optional) xmllint to validate virt-inspector RELAX NG schema -- (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 + OCaml library xml-light if you want to rebuild + the generated files, and also to build the OCaml bindings + (http://tech.motion-twin.com/xmllight.html) - (Optional) local Fedora mirror diff --git a/configure.ac b/configure.ac index 88154ac..9a781c7 100644 --- a/configure.ac +++ b/configure.ac @@ -433,8 +433,7 @@ 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. +dnl Optional xml-light for running the generator. OCAML_PKG_xml_light=no if test "x$OCAMLC" != "xno" -a "x$OCAMLFIND" != "xno"; then AC_CHECK_OCAML_PKG([xml-light]) diff --git a/inspector/Makefile.am b/inspector/Makefile.am index 0878725..dadbeee 100644 --- a/inspector/Makefile.am +++ b/inspector/Makefile.am @@ -19,8 +19,7 @@ include $(top_srcdir)/subdir-rules.mk EXTRA_DIST = \ run-inspector-locally \ - virt-inspector \ - inspector_generator.ml + virt-inspector dist_doc_DATA = \ virt-inspector.rng \ @@ -32,7 +31,7 @@ bin_SCRIPTS = virt-inspector man_MANS = virt-inspector.1 noinst_DATA = \ - $(top_builddir)/html/virt-inspector.1.html stamp-inspector-generator + $(top_builddir)/html/virt-inspector.1.html virt-inspector.1: virt-inspector $(POD2MAN) \ @@ -57,15 +56,4 @@ 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 deleted file mode 100644 index 20d2b01..0000000 --- a/inspector/inspector_generator.ml +++ /dev/null @@ -1,634 +0,0 @@ -#!/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 (* *) - | Attribute of string * rng list (* *) - | Interleave of rng list (* *) - | ZeroOrMore of rng (* *) - | OneOrMore of rng (* *) - | Optional of rng (* *) - | Choice of string list (* * *) - | Value of string (* str *) - | Text (* *) - -let rec string_of_rng = function - | Element (name, xs) -> - "Element (\"" ^ name ^ "\", (" ^ string_of_rng_list xs ^ "))" - | Attribute (name, xs) -> - "Attribute (\"" ^ name ^ "\", (" ^ string_of_rng_list xs ^ "))" - | Interleave xs -> "Interleave (" ^ string_of_rng_list xs ^ ")" - | ZeroOrMore rng -> "ZeroOrMore (" ^ string_of_rng rng ^ ")" - | OneOrMore rng -> "OneOrMore (" ^ string_of_rng rng ^ ")" - | Optional rng -> "Optional (" ^ string_of_rng rng ^ ")" - | Choice values -> "Choice [" ^ String.concat ", " values ^ "]" - | Value value -> "Value \"" ^ value ^ "\"" - | Text -> "Text" - -and string_of_rng_list xs = - String.concat ", " (List.map string_of_rng xs) - -let rec parse_rng ?defines context = function - | [] -> [] - | Xml.Element ("element", ["name", name], children) :: rest -> - Element (name, parse_rng ?defines context children) - :: parse_rng ?defines context rest - | Xml.Element ("attribute", ["name", name], children) :: rest -> - Attribute (name, parse_rng ?defines context children) - :: parse_rng ?defines context rest - | Xml.Element ("interleave", [], children) :: rest -> - Interleave (parse_rng ?defines context children) - :: parse_rng ?defines context rest - | Xml.Element ("zeroOrMore", [], [child]) :: rest -> - let rng = parse_rng ?defines context [child] in - (match rng with - | [child] -> ZeroOrMore child :: parse_rng ?defines context rest - | _ -> - failwithf "%s: contains more than one child element" - context - ) - | Xml.Element ("oneOrMore", [], [child]) :: rest -> - let rng = parse_rng ?defines context [child] in - (match rng with - | [child] -> OneOrMore child :: parse_rng ?defines context rest - | _ -> - failwithf "%s: contains more than one child element" - context - ) - | Xml.Element ("optional", [], [child]) :: rest -> - let rng = parse_rng ?defines context [child] in - (match rng with - | [child] -> Optional child :: parse_rng ?defines context rest - | _ -> - failwithf "%s: contains more than one child element" - context - ) - | Xml.Element ("choice", [], children) :: rest -> - let values = List.map ( - function Xml.Element ("value", [], [Xml.PCData value]) -> value - | _ -> - failwithf "%s: can't handle anything except in " - context - ) children in - Choice values - :: parse_rng ?defines context rest - | Xml.Element ("value", [], [Xml.PCData value]) :: rest -> - Value value :: parse_rng ?defines context rest - | Xml.Element ("text", [], []) :: rest -> - Text :: parse_rng ?defines context rest - | Xml.Element ("ref", ["name", name], []) :: rest -> - (* Look up the reference. Because of limitations in this parser, - * we can't handle arbitrarily nested yet. You can only - * use from inside . - *) - (match defines with - | None -> - failwithf "%s: contains , but no refs are defined yet" context - | Some map -> - let rng = StringMap.find name map in - rng @ parse_rng ?defines context rest - ) - | x :: _ -> - failwithf "%s: can't handle '%s' in schema" context (Xml.to_string x) - -let grammar = - let xml = Xml.parse_file input in - match xml with - | Xml.Element ("grammar", _, - Xml.Element ("start", _, gram) :: defines) -> - (* The elements are referenced in the section, - * so build a map of those first. - *) - let defines = List.fold_left ( - fun map -> - function Xml.Element ("define", ["name", name], defn) -> - StringMap.add name defn map - | _ -> - failwithf "%s: expected " input - ) StringMap.empty defines in - let defines = StringMap.mapi parse_rng defines in - - (* Parse the clause, passing the defines. *) - parse_rng ~defines "" gram - | _ -> - failwithf "%s: input is not *" 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 -> (* list *) - let t, is_simple = generate_type rng in - t ^ " list (* 0 or more *)", is_simple - | OneOrMore rng -> (* list *) - let t, is_simple = generate_type rng in - t ^ " list (* 1 or more *)", is_simple - (* virt-inspector hack: bool *) - | Optional (Attribute (name, [Value "1"])) -> - "bool", true - | Optional rng -> (* list *) - let t, is_simple = generate_type rng in - t ^ " option", is_simple - (* type name = { fields ... } *) - | Element (name, fields) when is_attrs_interleave fields -> - generate_type_struct name (get_attrs_interleave fields) - | Element (name, [field]) (* type name = field *) - | Attribute (name, [field]) -> - let t, is_simple = generate_type field in - if is_simple then (t, true) - else ( - pr "type %s = %s\n" name t; - name, false - ) - | Element (name, fields) -> (* type name = { fields ... } *) - generate_type_struct name fields - | rng -> - failwithf "generate_type failed at: %s" (string_of_rng rng) - - and is_attrs_interleave = function - | [Interleave _] -> true - | Attribute _ :: fields -> is_attrs_interleave fields - | Optional (Attribute _) :: fields -> is_attrs_interleave fields - | _ -> false - - and get_attrs_interleave = function - | [Interleave fields] -> fields - | ((Attribute _) as field) :: fields - | ((Optional (Attribute _)) as field) :: fields -> - field :: get_attrs_interleave fields - | _ -> assert false - - and generate_types xs = - List.iter (fun x -> ignore (generate_type x)) xs - - and generate_type_struct name fields = - (* Calculate the types of the fields first. We have to do this - * before printing anything so we are still in BOL context. - *) - let types = List.map fst (List.map generate_type fields) in - - (* Special case of a struct containing just a string and another - * field. Turn it into an assoc list. - *) - match types with - | ["string"; other] -> - let fname1, fname2 = - match fields with - | [f1; f2] -> name_of_field f1, name_of_field f2 - | _ -> assert false in - pr "type %s = string * %s (* %s -> %s *)\n" name other fname1 fname2; - name, false - - | types -> - pr "type %s = {\n" name; - List.iter ( - fun (field, ftype) -> - let fname = name_of_field field in - pr " %s_%s : %s;\n" name fname ftype - ) (List.combine fields types); - pr "}\n"; - (* Return the name of this type, and - * false because it's not a simple type. - *) - name, false - in - - generate_types xs - -let generate_parsers xs = - (* As for generate_type above, generate_parser makes a parser for - * some type, and returns the name of the parser it has generated. - * Because it (may) need to print something, it should always be - * called in BOL context. - *) - let rec generate_parser = function - | Text -> (* string *) - "string_child_or_empty" - | Choice values -> (* [`val1|`val2|...] *) - sprintf "(fun x -> match Xml.pcdata (first_child x) with %s | str -> failwith (\"unexpected field value: \" ^ str))" - (String.concat "|" - (List.map (fun v -> sprintf "%S -> `%s" v v) values)) - | ZeroOrMore rng -> (* list *) - let pa = generate_parser rng in - sprintf "(fun x -> List.map %s (Xml.children x))" pa - | OneOrMore rng -> (* list *) - let pa = generate_parser rng in - sprintf "(fun x -> List.map %s (Xml.children x))" pa - (* virt-inspector hack: bool *) - | Optional (Attribute (name, [Value "1"])) -> - sprintf "(fun x -> try ignore (Xml.attrib x %S); true with Xml.No_attribute _ -> false)" name - | Optional rng -> (* list *) - let pa = generate_parser rng in - sprintf "(function None -> None | Some x -> Some (%s x))" pa - (* type name = { fields ... } *) - | Element (name, fields) when is_attrs_interleave fields -> - generate_parser_struct name (get_attrs_interleave fields) - | Element (name, [field]) -> (* type name = field *) - let pa = generate_parser field in - let parser_name = sprintf "parse_%s_%d" name (unique ()) in - pr "let %s =\n" parser_name; - pr " %s\n" pa; - pr "let parse_%s = %s\n" name parser_name; - parser_name - | Attribute (name, [field]) -> - let pa = generate_parser field in - let parser_name = sprintf "parse_%s_%d" name (unique ()) in - pr "let %s =\n" parser_name; - pr " %s\n" pa; - pr "let parse_%s = %s\n" name parser_name; - parser_name - | Element (name, fields) -> (* type name = { fields ... } *) - generate_parser_struct name ([], fields) - | rng -> - failwithf "generate_parser failed at: %s" (string_of_rng rng) - - and is_attrs_interleave = function - | [Interleave _] -> true - | Attribute _ :: fields -> is_attrs_interleave fields - | Optional (Attribute _) :: fields -> is_attrs_interleave fields - | _ -> false - - and get_attrs_interleave = function - | [Interleave fields] -> [], fields - | ((Attribute _) as field) :: fields - | ((Optional (Attribute _)) as field) :: fields -> - let attrs, interleaves = get_attrs_interleave fields in - (field :: attrs), interleaves - | _ -> assert false - - and generate_parsers xs = - List.iter (fun x -> ignore (generate_parser x)) xs - - and generate_parser_struct name (attrs, interleaves) = - (* Generate parsers for the fields first. We have to do this - * before printing anything so we are still in BOL context. - *) - let fields = attrs @ interleaves in - let pas = List.map generate_parser fields in - - (* Generate an intermediate tuple from all the fields first. - * If the type is just a string + another field, then we will - * return this directly, otherwise it is turned into a record. - * - * RELAX NG note: This code treats and plain lists of - * fields the same. In other words, it doesn't bother enforcing - * any ordering of fields in the XML. - *) - pr "let parse_%s x =\n" name; - pr " let t = (\n "; - let comma = ref false in - List.iter ( - fun x -> - if !comma then pr ",\n "; - comma := true; - match x with - | Optional (Attribute (fname, [field])), pa -> - pr "%s x" pa - | Optional (Element (fname, [field])), pa -> - pr "%s (optional_child %S x)" pa fname - | Attribute (fname, [Text]), _ -> - pr "attribute %S x" fname - | (ZeroOrMore _ | OneOrMore _), pa -> - pr "%s x" pa - | Text, pa -> - pr "%s x" pa - | (field, pa) -> - let fname = name_of_field field in - pr "%s (child %S x)" pa fname - ) (List.combine fields pas); - pr "\n ) in\n"; - - (match fields with - | [Element (_, [Text]) | Attribute (_, [Text]); _] -> - pr " t\n" - - | _ -> - pr " (Obj.magic t : %s)\n" name -(* - List.iter ( - function - | (Optional (Attribute (fname, [field])), pa) -> - pr " %s_%s =\n" name fname; - pr " %s x;\n" pa - | (Optional (Element (fname, [field])), pa) -> - pr " %s_%s =\n" name fname; - pr " (let x = optional_child %S x in\n" fname; - pr " %s x);\n" pa - | (field, pa) -> - let fname = name_of_field field in - pr " %s_%s =\n" name fname; - pr " (let x = child %S x in\n" fname; - pr " %s x);\n" pa - ) (List.combine fields pas); - pr "}\n" -*) - ); - sprintf "parse_%s" name - in - - generate_parsers xs - -(* Generate ocaml/guestfs_inspector.mli. *) -let generate_ocaml_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/java/Makefile.inc b/java/Makefile.inc index c76184f..1f98ef2 100644 --- a/java/Makefile.inc +++ b/java/Makefile.inc @@ -1,5 +1,6 @@ # libguestfs generated file -# WARNING: THIS FILE IS GENERATED BY 'src/generator.ml'. +# WARNING: THIS FILE IS GENERATED FROM: +# src/generator.ml # ANY CHANGES YOU MAKE TO THIS FILE WILL BE LOST. # # Copyright (C) 2009 Red Hat Inc. diff --git a/ocaml/Makefile.am b/ocaml/Makefile.am index 5b51497..38238f6 100644 --- a/ocaml/Makefile.am +++ b/ocaml/Makefile.am @@ -20,6 +20,8 @@ include $(top_srcdir)/subdir-rules.mk generator_built = \ guestfs.mli \ guestfs.ml \ + guestfs_inspector.mli \ + guestfs_inspector.ml \ guestfs_c_actions.c \ bindtests.ml diff --git a/src/generator.ml b/src/generator.ml index 2243609..b3e397e 100755 --- a/src/generator.ml +++ b/src/generator.ml @@ -41,6 +41,8 @@ #load "unix.cma";; #load "str.cma";; +#directory "+xml-light";; +#load "xml-light.cma";; open Unix open Printf @@ -4457,8 +4459,12 @@ let pod2text_memo_updated () = * Note we don't want to use any external OCaml libraries which * makes this a bit harder than it should be. *) +module StringMap = Map.Make (String) + let failwithf fs = ksprintf failwith fs +let unique = let i = ref 0 in fun () -> incr i; !i + let replace_char s c1 c2 = let s2 = String.copy s in let r = ref false in @@ -4808,14 +4814,16 @@ let pr fs = ksprintf (output_string !chan) fs type comment_style = CStyle | HashStyle | OCamlStyle | HaskellStyle type license = GPLv2 | LGPLv2 -let generate_header comment license = +let generate_header ?(extra_inputs = []) comment license = + let inputs = "src/generator.ml" :: extra_inputs in let c = match comment with | CStyle -> pr "/* "; " *" | HashStyle -> pr "# "; "#" | OCamlStyle -> pr "(* "; " *" | HaskellStyle -> pr "{- "; " " in pr "libguestfs generated file\n"; - pr "%s WARNING: THIS FILE IS GENERATED BY 'src/generator.ml'.\n" c; + pr "%s WARNING: THIS FILE IS GENERATED FROM:\n" c; + List.iter (pr "%s %s\n" c) inputs; pr "%s ANY CHANGES YOU MAKE TO THIS FILE WILL BE LOST.\n" c; pr "%s\n" c; pr "%s Copyright (C) 2009 Red Hat Inc.\n" c; @@ -10313,6 +10321,494 @@ and generate_lang_bindtests call = (* XXX Add here tests of the return and error functions. *) +(* Code to generator bindings for virt-inspector. Currently only + * implemented for OCaml code (for virt-p2v 2.0). + *) +let rng_input = "inspector/virt-inspector.rng" + +(* Read the input file and parse it into internal structures. This is + * by no means a complete RELAX NG parser, but is just enough to be + * able to parse the specific input file. + *) +type rng = + | Element of string * rng list (* *) + | Attribute of string * rng list (* *) + | Interleave of rng list (* *) + | ZeroOrMore of rng (* *) + | OneOrMore of rng (* *) + | Optional of rng (* *) + | Choice of string list (* * *) + | Value of string (* str *) + | Text (* *) + +let rec string_of_rng = function + | Element (name, xs) -> + "Element (\"" ^ name ^ "\", (" ^ string_of_rng_list xs ^ "))" + | Attribute (name, xs) -> + "Attribute (\"" ^ name ^ "\", (" ^ string_of_rng_list xs ^ "))" + | Interleave xs -> "Interleave (" ^ string_of_rng_list xs ^ ")" + | ZeroOrMore rng -> "ZeroOrMore (" ^ string_of_rng rng ^ ")" + | OneOrMore rng -> "OneOrMore (" ^ string_of_rng rng ^ ")" + | Optional rng -> "Optional (" ^ string_of_rng rng ^ ")" + | Choice values -> "Choice [" ^ String.concat ", " values ^ "]" + | Value value -> "Value \"" ^ value ^ "\"" + | Text -> "Text" + +and string_of_rng_list xs = + String.concat ", " (List.map string_of_rng xs) + +let rec parse_rng ?defines context = function + | [] -> [] + | Xml.Element ("element", ["name", name], children) :: rest -> + Element (name, parse_rng ?defines context children) + :: parse_rng ?defines context rest + | Xml.Element ("attribute", ["name", name], children) :: rest -> + Attribute (name, parse_rng ?defines context children) + :: parse_rng ?defines context rest + | Xml.Element ("interleave", [], children) :: rest -> + Interleave (parse_rng ?defines context children) + :: parse_rng ?defines context rest + | Xml.Element ("zeroOrMore", [], [child]) :: rest -> + let rng = parse_rng ?defines context [child] in + (match rng with + | [child] -> ZeroOrMore child :: parse_rng ?defines context rest + | _ -> + failwithf "%s: contains more than one child element" + context + ) + | Xml.Element ("oneOrMore", [], [child]) :: rest -> + let rng = parse_rng ?defines context [child] in + (match rng with + | [child] -> OneOrMore child :: parse_rng ?defines context rest + | _ -> + failwithf "%s: contains more than one child element" + context + ) + | Xml.Element ("optional", [], [child]) :: rest -> + let rng = parse_rng ?defines context [child] in + (match rng with + | [child] -> Optional child :: parse_rng ?defines context rest + | _ -> + failwithf "%s: contains more than one child element" + context + ) + | Xml.Element ("choice", [], children) :: rest -> + let values = List.map ( + function Xml.Element ("value", [], [Xml.PCData value]) -> value + | _ -> + failwithf "%s: can't handle anything except in " + context + ) children in + Choice values + :: parse_rng ?defines context rest + | Xml.Element ("value", [], [Xml.PCData value]) :: rest -> + Value value :: parse_rng ?defines context rest + | Xml.Element ("text", [], []) :: rest -> + Text :: parse_rng ?defines context rest + | Xml.Element ("ref", ["name", name], []) :: rest -> + (* Look up the reference. Because of limitations in this parser, + * we can't handle arbitrarily nested yet. You can only + * use from inside . + *) + (match defines with + | None -> + failwithf "%s: contains , but no refs are defined yet" context + | Some map -> + let rng = StringMap.find name map in + rng @ parse_rng ?defines context rest + ) + | x :: _ -> + failwithf "%s: can't handle '%s' in schema" context (Xml.to_string x) + +let grammar = + let xml = Xml.parse_file rng_input in + match xml with + | Xml.Element ("grammar", _, + Xml.Element ("start", _, gram) :: defines) -> + (* The elements are referenced in the section, + * so build a map of those first. + *) + let defines = List.fold_left ( + fun map -> + function Xml.Element ("define", ["name", name], defn) -> + StringMap.add name defn map + | _ -> + failwithf "%s: expected " rng_input + ) StringMap.empty defines in + let defines = StringMap.mapi parse_rng defines in + + (* Parse the clause, passing the defines. *) + parse_rng ~defines "" gram + | _ -> + failwithf "%s: input is not *" + rng_input + +let name_of_field = function + | Element (name, _) | Attribute (name, _) + | ZeroOrMore (Element (name, _)) + | OneOrMore (Element (name, _)) + | Optional (Element (name, _)) -> name + | Optional (Attribute (name, _)) -> name + | Text -> (* an unnamed field in an element *) + "data" + | rng -> + failwithf "name_of_field failed at: %s" (string_of_rng rng) + +(* At the moment this function only generates OCaml types. However we + * should parameterize it later so it can generate types/structs in a + * variety of languages. + *) +let generate_types xs = + (* A simple type is one that can be printed out directly, eg. + * "string option". A complex type is one which has a name and has + * to be defined via another toplevel definition, eg. a struct. + * + * generate_type generates code for either simple or complex types. + * In the simple case, it returns the string ("string option"). In + * the complex case, it returns the name ("mountpoint"). In the + * complex case it has to print out the definition before returning, + * so it should only be called when we are at the beginning of a + * new line (BOL context). + *) + let rec generate_type = function + | Text -> (* string *) + "string", true + | Choice values -> (* [`val1|`val2|...] *) + "[" ^ String.concat "|" (List.map ((^)"`") values) ^ "]", true + | ZeroOrMore rng -> (* list *) + let t, is_simple = generate_type rng in + t ^ " list (* 0 or more *)", is_simple + | OneOrMore rng -> (* list *) + let t, is_simple = generate_type rng in + t ^ " list (* 1 or more *)", is_simple + (* virt-inspector hack: bool *) + | Optional (Attribute (name, [Value "1"])) -> + "bool", true + | Optional rng -> (* list *) + let t, is_simple = generate_type rng in + t ^ " option", is_simple + (* type name = { fields ... } *) + | Element (name, fields) when is_attrs_interleave fields -> + generate_type_struct name (get_attrs_interleave fields) + | Element (name, [field]) (* type name = field *) + | Attribute (name, [field]) -> + let t, is_simple = generate_type field in + if is_simple then (t, true) + else ( + pr "type %s = %s\n" name t; + name, false + ) + | Element (name, fields) -> (* type name = { fields ... } *) + generate_type_struct name fields + | rng -> + failwithf "generate_type failed at: %s" (string_of_rng rng) + + and is_attrs_interleave = function + | [Interleave _] -> true + | Attribute _ :: fields -> is_attrs_interleave fields + | Optional (Attribute _) :: fields -> is_attrs_interleave fields + | _ -> false + + and get_attrs_interleave = function + | [Interleave fields] -> fields + | ((Attribute _) as field) :: fields + | ((Optional (Attribute _)) as field) :: fields -> + field :: get_attrs_interleave fields + | _ -> assert false + + and generate_types xs = + List.iter (fun x -> ignore (generate_type x)) xs + + and generate_type_struct name fields = + (* Calculate the types of the fields first. We have to do this + * before printing anything so we are still in BOL context. + *) + let types = List.map fst (List.map generate_type fields) in + + (* Special case of a struct containing just a string and another + * field. Turn it into an assoc list. + *) + match types with + | ["string"; other] -> + let fname1, fname2 = + match fields with + | [f1; f2] -> name_of_field f1, name_of_field f2 + | _ -> assert false in + pr "type %s = string * %s (* %s -> %s *)\n" name other fname1 fname2; + name, false + + | types -> + pr "type %s = {\n" name; + List.iter ( + fun (field, ftype) -> + let fname = name_of_field field in + pr " %s_%s : %s;\n" name fname ftype + ) (List.combine fields types); + pr "}\n"; + (* Return the name of this type, and + * false because it's not a simple type. + *) + name, false + in + + generate_types xs + +let generate_parsers xs = + (* As for generate_type above, generate_parser makes a parser for + * some type, and returns the name of the parser it has generated. + * Because it (may) need to print something, it should always be + * called in BOL context. + *) + let rec generate_parser = function + | Text -> (* string *) + "string_child_or_empty" + | Choice values -> (* [`val1|`val2|...] *) + sprintf "(fun x -> match Xml.pcdata (first_child x) with %s | str -> failwith (\"unexpected field value: \" ^ str))" + (String.concat "|" + (List.map (fun v -> sprintf "%S -> `%s" v v) values)) + | ZeroOrMore rng -> (* list *) + let pa = generate_parser rng in + sprintf "(fun x -> List.map %s (Xml.children x))" pa + | OneOrMore rng -> (* list *) + let pa = generate_parser rng in + sprintf "(fun x -> List.map %s (Xml.children x))" pa + (* virt-inspector hack: bool *) + | Optional (Attribute (name, [Value "1"])) -> + sprintf "(fun x -> try ignore (Xml.attrib x %S); true with Xml.No_attribute _ -> false)" name + | Optional rng -> (* list *) + let pa = generate_parser rng in + sprintf "(function None -> None | Some x -> Some (%s x))" pa + (* type name = { fields ... } *) + | Element (name, fields) when is_attrs_interleave fields -> + generate_parser_struct name (get_attrs_interleave fields) + | Element (name, [field]) -> (* type name = field *) + let pa = generate_parser field in + let parser_name = sprintf "parse_%s_%d" name (unique ()) in + pr "let %s =\n" parser_name; + pr " %s\n" pa; + pr "let parse_%s = %s\n" name parser_name; + parser_name + | Attribute (name, [field]) -> + let pa = generate_parser field in + let parser_name = sprintf "parse_%s_%d" name (unique ()) in + pr "let %s =\n" parser_name; + pr " %s\n" pa; + pr "let parse_%s = %s\n" name parser_name; + parser_name + | Element (name, fields) -> (* type name = { fields ... } *) + generate_parser_struct name ([], fields) + | rng -> + failwithf "generate_parser failed at: %s" (string_of_rng rng) + + and is_attrs_interleave = function + | [Interleave _] -> true + | Attribute _ :: fields -> is_attrs_interleave fields + | Optional (Attribute _) :: fields -> is_attrs_interleave fields + | _ -> false + + and get_attrs_interleave = function + | [Interleave fields] -> [], fields + | ((Attribute _) as field) :: fields + | ((Optional (Attribute _)) as field) :: fields -> + let attrs, interleaves = get_attrs_interleave fields in + (field :: attrs), interleaves + | _ -> assert false + + and generate_parsers xs = + List.iter (fun x -> ignore (generate_parser x)) xs + + and generate_parser_struct name (attrs, interleaves) = + (* Generate parsers for the fields first. We have to do this + * before printing anything so we are still in BOL context. + *) + let fields = attrs @ interleaves in + let pas = List.map generate_parser fields in + + (* Generate an intermediate tuple from all the fields first. + * If the type is just a string + another field, then we will + * return this directly, otherwise it is turned into a record. + * + * RELAX NG note: This code treats and plain lists of + * fields the same. In other words, it doesn't bother enforcing + * any ordering of fields in the XML. + *) + pr "let parse_%s x =\n" name; + pr " let t = (\n "; + let comma = ref false in + List.iter ( + fun x -> + if !comma then pr ",\n "; + comma := true; + match x with + | Optional (Attribute (fname, [field])), pa -> + pr "%s x" pa + | Optional (Element (fname, [field])), pa -> + pr "%s (optional_child %S x)" pa fname + | Attribute (fname, [Text]), _ -> + pr "attribute %S x" fname + | (ZeroOrMore _ | OneOrMore _), pa -> + pr "%s x" pa + | Text, pa -> + pr "%s x" pa + | (field, pa) -> + let fname = name_of_field field in + pr "%s (child %S x)" pa fname + ) (List.combine fields pas); + pr "\n ) in\n"; + + (match fields with + | [Element (_, [Text]) | Attribute (_, [Text]); _] -> + pr " t\n" + + | _ -> + pr " (Obj.magic t : %s)\n" name +(* + List.iter ( + function + | (Optional (Attribute (fname, [field])), pa) -> + pr " %s_%s =\n" name fname; + pr " %s x;\n" pa + | (Optional (Element (fname, [field])), pa) -> + pr " %s_%s =\n" name fname; + pr " (let x = optional_child %S x in\n" fname; + pr " %s x);\n" pa + | (field, pa) -> + let fname = name_of_field field in + pr " %s_%s =\n" name fname; + pr " (let x = child %S x in\n" fname; + pr " %s x);\n" pa + ) (List.combine fields pas); + pr "}\n" +*) + ); + sprintf "parse_%s" name + in + + generate_parsers xs + +(* Generate ocaml/guestfs_inspector.mli. *) +let generate_ocaml_inspector_mli () = + generate_header ~extra_inputs:[rng_input] OCamlStyle LGPLv2; + + pr "\ +(** This is an OCaml language binding to the external [virt-inspector] + program. + + For more information, please read the man page [virt-inspector(1)]. +*) + +"; + + generate_types grammar; + pr "(** The nested information returned from the {!inspect} function. *)\n"; + pr "\n"; + + pr "\ +val inspect : ?connect:string -> ?xml:string -> string list -> operatingsystems +(** To inspect a libvirt domain called [name], pass a singleton + list: [inspect [name]]. When using libvirt only, you may + optionally pass a libvirt URI using [inspect ~connect:uri ...]. + + To inspect a disk image or images, pass a list of the filenames + of the disk images: [inspect filenames] + + This function inspects the given guest or disk images and + returns a list of operating system(s) found and a large amount + of information about them. In the vast majority of cases, + a virtual machine only contains a single operating system. + + If the optional [~xml] parameter is given, then this function + skips running the external virt-inspector program and just + parses the given XML directly (which is expected to be XML + produced from a previous run of virt-inspector). The list of + names and connect URI are ignored in this case. + + This function can throw a wide variety of exceptions, for example + if the external virt-inspector program cannot be found, or if + it doesn't generate valid XML. +*) +" + +(* Generate ocaml/guestfs_inspector.ml. *) +let generate_ocaml_inspector_ml () = + generate_header ~extra_inputs:[rng_input] OCamlStyle LGPLv2; + + pr "open Unix\n"; + pr "\n"; + + generate_types grammar; + pr "\n"; + + pr "\ +(* Misc functions which are used by the parser code below. *) +let first_child = function + | Xml.Element (_, _, c::_) -> c + | Xml.Element (name, _, []) -> + failwith (\"expected <\" ^ name ^ \"/> to have a child node\") + | Xml.PCData str -> + failwith (\"expected XML tag, but read PCDATA '\" ^ str ^ \"' instead\") + +let string_child_or_empty = function + | Xml.Element (_, _, [Xml.PCData s]) -> s + | Xml.Element (_, _, []) -> \"\" + | Xml.Element (x, _, _) -> + failwith (\"expected XML tag with a single PCDATA child, but got \" ^ + x ^ \" instead\") + | Xml.PCData str -> + failwith (\"expected XML tag, but read PCDATA '\" ^ str ^ \"' instead\") + +let optional_child name xml = + let children = Xml.children xml in + try + Some (List.find (function + | Xml.Element (n, _, _) when n = name -> true + | _ -> false) children) + with + Not_found -> None + +let child name xml = + match optional_child name xml with + | Some c -> c + | None -> + failwith (\"mandatory field <\" ^ name ^ \"/> missing in XML output\") + +let attribute name xml = + try Xml.attrib xml name + with Xml.No_attribute _ -> + failwith (\"mandatory attribute \" ^ name ^ \" missing in XML output\") + +"; + + generate_parsers grammar; + pr "\n"; + + pr "\ +(* Run external virt-inspector, then use parser to parse the XML. *) +let inspect ?connect ?xml names = + let xml = + match xml with + | None -> + if names = [] then invalid_arg \"inspect: no names given\"; + let cmd = [ \"virt-inspector\"; \"--xml\" ] @ + (match connect with None -> [] | Some uri -> [ \"--connect\"; uri ]) @ + names in + let cmd = List.map Filename.quote cmd in + let cmd = String.concat \" \" cmd in + let chan = open_process_in cmd in + let xml = Xml.parse_in chan in + (match close_process_in chan with + | WEXITED 0 -> () + | WEXITED _ -> failwith \"external virt-inspector command failed\" + | WSIGNALED i | WSTOPPED i -> + failwith (\"external virt-inspector command died or stopped on sig \" ^ + string_of_int i) + ); + xml + | Some doc -> + Xml.parse_string doc in + parse_operatingsystems xml +" + (* This is used to generate the src/MAX_PROC_NR file which * contains the maximum procedure number, a surrogate for the * ABI version number. See src/Makefile.am for the details. @@ -10468,6 +10964,14 @@ Run it from the top source directory using the command generate_ocaml_bindtests (); close (); + let close = output_to "ocaml/guestfs_inspector.mli" in + generate_ocaml_inspector_mli (); + close (); + + let close = output_to "ocaml/guestfs_inspector.ml" in + generate_ocaml_inspector_ml (); + close (); + let close = output_to "perl/Guestfs.xs" in generate_perl_xs (); close ();