3 * Copyright (C) 2009 Red Hat Inc.
5 * This program is free software; you can redistribute it and/or modify
6 * it under the terms of the GNU General Public License as published by
7 * the Free Software Foundation; either version 2 of the License, or
8 * (at your option) any later version.
10 * This program is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 * GNU General Public License for more details.
15 * You should have received a copy of the GNU General Public License
16 * along with this program; if not, write to the Free Software
17 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
20 (* This program generates language bindings for virt-inspector, so
21 * you can use it from programs (other than Perl programs).
23 * At compile time, the bindings are generated from the file
24 * [virt-inspector.rng], which is the RELAX NG schema that describes
25 * the output of the [virt-inspector --xml] command.
27 * At run time, code using these bindings runs the external
28 * [virt-inspector --xml] command, and parses the XML that this
29 * generates into language-specific structures.
32 (* Unlike src/generator.ml, we allow ourselves to go wild here and use
33 * a reasonable number of OCaml libraries. NOTE TO DEVELOPERS: You
34 * still have to detect the libraries in configure.ac and add them to
35 * inspector/Makefile.am.
38 #directory "+xml-light";;
39 #load "xml-light.cma";;
43 module StringMap = Map.Make (String)
45 let failwithf fs = ksprintf failwith fs
46 let unique = let i = ref 0 in fun () -> incr i; !i
48 (* Check we're running from the right directory. *)
50 if not (Sys.file_exists "HACKING") then (
51 eprintf "You are probably running this from the wrong directory.\n";
55 let input = "inspector/virt-inspector.rng"
57 (* Read the input file and parse it into internal structures. This is
58 * by no means a complete RELAX NG parser, but is just enough to be
59 * able to parse the specific input file.
62 | Element of string * rng list (* <element name=name/> *)
63 | Attribute of string * rng list (* <attribute name=name/> *)
64 | Interleave of rng list (* <interleave/> *)
65 | ZeroOrMore of rng (* <zeroOrMore/> *)
66 | OneOrMore of rng (* <oneOrMore/> *)
67 | Optional of rng (* <optional/> *)
68 | Choice of string list (* <choice><value/>*</choice> *)
69 | Value of string (* <value>str</value> *)
72 let rec string_of_rng = function
73 | Element (name, xs) ->
74 "Element (\"" ^ name ^ "\", (" ^ string_of_rng_list xs ^ "))"
75 | Attribute (name, xs) ->
76 "Attribute (\"" ^ name ^ "\", (" ^ string_of_rng_list xs ^ "))"
77 | Interleave xs -> "Interleave (" ^ string_of_rng_list xs ^ ")"
78 | ZeroOrMore rng -> "ZeroOrMore (" ^ string_of_rng rng ^ ")"
79 | OneOrMore rng -> "OneOrMore (" ^ string_of_rng rng ^ ")"
80 | Optional rng -> "Optional (" ^ string_of_rng rng ^ ")"
81 | Choice values -> "Choice [" ^ String.concat ", " values ^ "]"
82 | Value value -> "Value \"" ^ value ^ "\""
85 and string_of_rng_list xs =
86 String.concat ", " (List.map string_of_rng xs)
88 let rec parse_rng ?defines context = function
90 | Xml.Element ("element", ["name", name], children) :: rest ->
91 Element (name, parse_rng ?defines context children)
92 :: parse_rng ?defines context rest
93 | Xml.Element ("attribute", ["name", name], children) :: rest ->
94 Attribute (name, parse_rng ?defines context children)
95 :: parse_rng ?defines context rest
96 | Xml.Element ("interleave", [], children) :: rest ->
97 Interleave (parse_rng ?defines context children)
98 :: parse_rng ?defines context rest
99 | Xml.Element ("zeroOrMore", [], [child]) :: rest ->
100 let rng = parse_rng ?defines context [child] in
102 | [child] -> ZeroOrMore child :: parse_rng ?defines context rest
104 failwithf "%s: <zeroOrMore> contains more than one child element"
107 | Xml.Element ("oneOrMore", [], [child]) :: rest ->
108 let rng = parse_rng ?defines context [child] in
110 | [child] -> OneOrMore child :: parse_rng ?defines context rest
112 failwithf "%s: <oneOrMore> contains more than one child element"
115 | Xml.Element ("optional", [], [child]) :: rest ->
116 let rng = parse_rng ?defines context [child] in
118 | [child] -> Optional child :: parse_rng ?defines context rest
120 failwithf "%s: <optional> contains more than one child element"
123 | Xml.Element ("choice", [], children) :: rest ->
124 let values = List.map (
125 function Xml.Element ("value", [], [Xml.PCData value]) -> value
127 failwithf "%s: can't handle anything except <value> in <choice>"
131 :: parse_rng ?defines context rest
132 | Xml.Element ("value", [], [Xml.PCData value]) :: rest ->
133 Value value :: parse_rng ?defines context rest
134 | Xml.Element ("text", [], []) :: rest ->
135 Text :: parse_rng ?defines context rest
136 | Xml.Element ("ref", ["name", name], []) :: rest ->
137 (* Look up the reference. Because of limitations in this parser,
138 * we can't handle arbitrarily nested <ref> yet. You can only
139 * use <ref> from inside <start>.
143 failwithf "%s: contains <ref>, but no refs are defined yet" context
145 let rng = StringMap.find name map in
146 rng @ parse_rng ?defines context rest
149 failwithf "%s: can't handle '%s' in schema" context (Xml.to_string x)
152 let xml = Xml.parse_file input in
154 | Xml.Element ("grammar", _,
155 Xml.Element ("start", _, gram) :: defines) ->
156 (* The <define/> elements are referenced in the <start> section,
157 * so build a map of those first.
159 let defines = List.fold_left (
161 function Xml.Element ("define", ["name", name], defn) ->
162 StringMap.add name defn map
164 failwithf "%s: expected <define name=name/>" input
165 ) StringMap.empty defines in
166 let defines = StringMap.mapi parse_rng defines in
168 (* Parse the <start> clause, passing the defines. *)
169 parse_rng ~defines "<start>" gram
171 failwithf "%s: input is not <grammar><start/><define>*</grammar>" input
173 (* 'pr' prints to the current output file. *)
174 let chan = ref stdout
175 let pr fs = ksprintf (output_string !chan) fs
177 (* Generate a header block in a number of standard styles. *)
178 type comment_style = CStyle | HashStyle | OCamlStyle | HaskellStyle
179 type license = GPLv2 | LGPLv2
181 let generate_header comment license =
182 let c = match comment with
183 | CStyle -> pr "/* "; " *"
184 | HashStyle -> pr "# "; "#"
185 | OCamlStyle -> pr "(* "; " *"
186 | HaskellStyle -> pr "{- "; " " in
187 pr "libguestfs generated file\n";
188 pr "%s WARNING: THIS FILE IS GENERATED BY 'inspector/inspector_generator.ml'\n" c;
189 pr "%s FROM THE RELAX NG SCHEMA AT '%s'.\n" c input;
190 pr "%s ANY CHANGES YOU MAKE TO THIS FILE WILL BE LOST.\n" c;
192 pr "%s Copyright (C) 2009 Red Hat Inc.\n" c;
196 pr "%s This program is free software; you can redistribute it and/or modify\n" c;
197 pr "%s it under the terms of the GNU General Public License as published by\n" c;
198 pr "%s the Free Software Foundation; either version 2 of the License, or\n" c;
199 pr "%s (at your option) any later version.\n" c;
201 pr "%s This program is distributed in the hope that it will be useful,\n" c;
202 pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
203 pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n" c;
204 pr "%s GNU General Public License for more details.\n" c;
206 pr "%s You should have received a copy of the GNU General Public License along\n" c;
207 pr "%s with this program; if not, write to the Free Software Foundation, Inc.,\n" c;
208 pr "%s 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n" c;
211 pr "%s This library is free software; you can redistribute it and/or\n" c;
212 pr "%s modify it under the terms of the GNU Lesser General Public\n" c;
213 pr "%s License as published by the Free Software Foundation; either\n" c;
214 pr "%s version 2 of the License, or (at your option) any later version.\n" c;
216 pr "%s This library is distributed in the hope that it will be useful,\n" c;
217 pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
218 pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU\n" c;
219 pr "%s Lesser General Public License for more details.\n" c;
221 pr "%s You should have received a copy of the GNU Lesser General Public\n" c;
222 pr "%s License along with this library; if not, write to the Free Software\n" c;
223 pr "%s Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA\n" c;
226 | CStyle -> pr " */\n"
228 | OCamlStyle -> pr " *)\n"
229 | HaskellStyle -> pr "-}\n"
233 let name_of_field = function
234 | Element (name, _) | Attribute (name, _)
235 | ZeroOrMore (Element (name, _))
236 | OneOrMore (Element (name, _))
237 | Optional (Element (name, _)) -> name
238 | Optional (Attribute (name, _)) -> name
239 | Text -> (* an unnamed field in an element *)
242 failwithf "name_of_field failed at: %s" (string_of_rng rng)
244 (* At the moment this function only generates OCaml types. However we
245 * should parameterize it later so it can generate types/structs in a
246 * variety of languages.
248 let generate_types xs =
249 (* A simple type is one that can be printed out directly, eg.
250 * "string option". A complex type is one which has a name and has
251 * to be defined via another toplevel definition, eg. a struct.
253 * generate_type generates code for either simple or complex types.
254 * In the simple case, it returns the string ("string option"). In
255 * the complex case, it returns the name ("mountpoint"). In the
256 * complex case it has to print out the definition before returning,
257 * so it should only be called when we are at the beginning of a
258 * new line (BOL context).
260 let rec generate_type = function
261 | Text -> (* string *)
263 | Choice values -> (* [`val1|`val2|...] *)
264 "[" ^ String.concat "|" (List.map ((^)"`") values) ^ "]", true
265 | ZeroOrMore rng -> (* <rng> list *)
266 let t, is_simple = generate_type rng in
267 t ^ " list (* 0 or more *)", is_simple
268 | OneOrMore rng -> (* <rng> list *)
269 let t, is_simple = generate_type rng in
270 t ^ " list (* 1 or more *)", is_simple
271 (* virt-inspector hack: bool *)
272 | Optional (Attribute (name, [Value "1"])) ->
274 | Optional rng -> (* <rng> list *)
275 let t, is_simple = generate_type rng in
276 t ^ " option", is_simple
277 (* type name = { fields ... } *)
278 | Element (name, fields) when is_attrs_interleave fields ->
279 generate_type_struct name (get_attrs_interleave fields)
280 | Element (name, [field]) (* type name = field *)
281 | Attribute (name, [field]) ->
282 let t, is_simple = generate_type field in
283 if is_simple then (t, true)
285 pr "type %s = %s\n" name t;
288 | Element (name, fields) -> (* type name = { fields ... } *)
289 generate_type_struct name fields
291 failwithf "generate_type failed at: %s" (string_of_rng rng)
293 and is_attrs_interleave = function
294 | [Interleave _] -> true
295 | Attribute _ :: fields -> is_attrs_interleave fields
296 | Optional (Attribute _) :: fields -> is_attrs_interleave fields
299 and get_attrs_interleave = function
300 | [Interleave fields] -> fields
301 | ((Attribute _) as field) :: fields
302 | ((Optional (Attribute _)) as field) :: fields ->
303 field :: get_attrs_interleave fields
306 and generate_types xs =
307 List.iter (fun x -> ignore (generate_type x)) xs
309 and generate_type_struct name fields =
310 (* Calculate the types of the fields first. We have to do this
311 * before printing anything so we are still in BOL context.
313 let types = List.map fst (List.map generate_type fields) in
315 (* Special case of a struct containing just a string and another
316 * field. Turn it into an assoc list.
319 | ["string"; other] ->
322 | [f1; f2] -> name_of_field f1, name_of_field f2
323 | _ -> assert false in
324 pr "type %s = string * %s (* %s -> %s *)\n" name other fname1 fname2;
328 pr "type %s = {\n" name;
330 fun (field, ftype) ->
331 let fname = name_of_field field in
332 pr " %s_%s : %s;\n" name fname ftype
333 ) (List.combine fields types);
335 (* Return the name of this type, and
336 * false because it's not a simple type.
343 let generate_parsers xs =
344 (* As for generate_type above, generate_parser makes a parser for
345 * some type, and returns the name of the parser it has generated.
346 * Because it (may) need to print something, it should always be
347 * called in BOL context.
349 let rec generate_parser = function
350 | Text -> (* string *)
351 "string_child_or_empty"
352 | Choice values -> (* [`val1|`val2|...] *)
353 sprintf "(fun x -> match Xml.pcdata (first_child x) with %s | str -> failwith (\"unexpected field value: \" ^ str))"
355 (List.map (fun v -> sprintf "%S -> `%s" v v) values))
356 | ZeroOrMore rng -> (* <rng> list *)
357 let pa = generate_parser rng in
358 sprintf "(fun x -> List.map %s (Xml.children x))" pa
359 | OneOrMore rng -> (* <rng> list *)
360 let pa = generate_parser rng in
361 sprintf "(fun x -> List.map %s (Xml.children x))" pa
362 (* virt-inspector hack: bool *)
363 | Optional (Attribute (name, [Value "1"])) ->
364 sprintf "(fun x -> try ignore (Xml.attrib x %S); true with Xml.No_attribute _ -> false)" name
365 | Optional rng -> (* <rng> list *)
366 let pa = generate_parser rng in
367 sprintf "(function None -> None | Some x -> Some (%s x))" pa
368 (* type name = { fields ... } *)
369 | Element (name, fields) when is_attrs_interleave fields ->
370 generate_parser_struct name (get_attrs_interleave fields)
371 | Element (name, [field]) -> (* type name = field *)
372 let pa = generate_parser field in
373 let parser_name = sprintf "parse_%s_%d" name (unique ()) in
374 pr "let %s =\n" parser_name;
376 pr "let parse_%s = %s\n" name parser_name;
378 | Attribute (name, [field]) ->
379 let pa = generate_parser field in
380 let parser_name = sprintf "parse_%s_%d" name (unique ()) in
381 pr "let %s =\n" parser_name;
383 pr "let parse_%s = %s\n" name parser_name;
385 | Element (name, fields) -> (* type name = { fields ... } *)
386 generate_parser_struct name ([], fields)
388 failwithf "generate_parser failed at: %s" (string_of_rng rng)
390 and is_attrs_interleave = function
391 | [Interleave _] -> true
392 | Attribute _ :: fields -> is_attrs_interleave fields
393 | Optional (Attribute _) :: fields -> is_attrs_interleave fields
396 and get_attrs_interleave = function
397 | [Interleave fields] -> [], fields
398 | ((Attribute _) as field) :: fields
399 | ((Optional (Attribute _)) as field) :: fields ->
400 let attrs, interleaves = get_attrs_interleave fields in
401 (field :: attrs), interleaves
404 and generate_parsers xs =
405 List.iter (fun x -> ignore (generate_parser x)) xs
407 and generate_parser_struct name (attrs, interleaves) =
408 (* Generate parsers for the fields first. We have to do this
409 * before printing anything so we are still in BOL context.
411 let fields = attrs @ interleaves in
412 let pas = List.map generate_parser fields in
414 (* Generate an intermediate tuple from all the fields first.
415 * If the type is just a string + another field, then we will
416 * return this directly, otherwise it is turned into a record.
418 * RELAX NG note: This code treats <interleave> and plain lists of
419 * fields the same. In other words, it doesn't bother enforcing
420 * any ordering of fields in the XML.
422 pr "let parse_%s x =\n" name;
424 let comma = ref false in
427 if !comma then pr ",\n ";
430 | Optional (Attribute (fname, [field])), pa ->
432 | Optional (Element (fname, [field])), pa ->
433 pr "%s (optional_child %S x)" pa fname
434 | Attribute (fname, [Text]), _ ->
435 pr "attribute %S x" fname
436 | (ZeroOrMore _ | OneOrMore _), pa ->
441 let fname = name_of_field field in
442 pr "%s (child %S x)" pa fname
443 ) (List.combine fields pas);
447 | [Element (_, [Text]) | Attribute (_, [Text]); _] ->
451 pr " (Obj.magic t : %s)\n" name
455 | (Optional (Attribute (fname, [field])), pa) ->
456 pr " %s_%s =\n" name fname;
458 | (Optional (Element (fname, [field])), pa) ->
459 pr " %s_%s =\n" name fname;
460 pr " (let x = optional_child %S x in\n" fname;
463 let fname = name_of_field field in
464 pr " %s_%s =\n" name fname;
465 pr " (let x = child %S x in\n" fname;
467 ) (List.combine fields pas);
471 sprintf "parse_%s" name
476 (* Generate ocaml/guestfs_inspector.mli. *)
477 let generate_ocaml_mli () =
478 generate_header OCamlStyle LGPLv2;
481 (** This is an OCaml language binding to the external [virt-inspector]
484 For more information, please read the man page [virt-inspector(1)].
489 generate_types grammar;
490 pr "(** The nested information returned from the {!inspect} function. *)\n";
494 val inspect : ?connect:string -> ?xml:string -> string list -> operatingsystems
495 (** To inspect a libvirt domain called [name], pass a singleton
496 list: [inspect [name]]. When using libvirt only, you may
497 optionally pass a libvirt URI using [inspect ~connect:uri ...].
499 To inspect a disk image or images, pass a list of the filenames
500 of the disk images: [inspect filenames]
502 This function inspects the given guest or disk images and
503 returns a list of operating system(s) found and a large amount
504 of information about them. In the vast majority of cases,
505 a virtual machine only contains a single operating system.
507 If the optional [~xml] parameter is given, then this function
508 skips running the external virt-inspector program and just
509 parses the given XML directly (which is expected to be XML
510 produced from a previous run of virt-inspector). The list of
511 names and connect URI are ignored in this case.
513 This function can throw a wide variety of exceptions, for example
514 if the external virt-inspector program cannot be found, or if
515 it doesn't generate valid XML.
519 (* Generate ocaml/guestfs_inspector.ml. *)
520 let generate_ocaml_ml () =
521 generate_header OCamlStyle LGPLv2;
526 generate_types grammar;
530 (* Misc functions which are used by the parser code below. *)
531 let first_child = function
532 | Xml.Element (_, _, c::_) -> c
533 | Xml.Element (name, _, []) ->
534 failwith (\"expected <\" ^ name ^ \"/> to have a child node\")
536 failwith (\"expected XML tag, but read PCDATA '\" ^ str ^ \"' instead\")
538 let string_child_or_empty = function
539 | Xml.Element (_, _, [Xml.PCData s]) -> s
540 | Xml.Element (_, _, []) -> \"\"
541 | Xml.Element (x, _, _) ->
542 failwith (\"expected XML tag with a single PCDATA child, but got \" ^
545 failwith (\"expected XML tag, but read PCDATA '\" ^ str ^ \"' instead\")
547 let optional_child name xml =
548 let children = Xml.children xml in
550 Some (List.find (function
551 | Xml.Element (n, _, _) when n = name -> true
552 | _ -> false) children)
557 match optional_child name xml with
560 failwith (\"mandatory field <\" ^ name ^ \"/> missing in XML output\")
562 let attribute name xml =
563 try Xml.attrib xml name
564 with Xml.No_attribute _ ->
565 failwith (\"mandatory attribute \" ^ name ^ \" missing in XML output\")
569 generate_parsers grammar;
573 (* Run external virt-inspector, then use parser to parse the XML. *)
574 let inspect ?connect ?xml names =
578 if names = [] then invalid_arg \"inspect: no names given\";
579 let cmd = [ \"virt-inspector\"; \"--xml\" ] @
580 (match connect with None -> [] | Some uri -> [ \"--connect\"; uri ]) @
582 let cmd = List.map Filename.quote cmd in
583 let cmd = String.concat \" \" cmd in
584 let chan = open_process_in cmd in
585 let xml = Xml.parse_in chan in
586 (match close_process_in chan with
588 | WEXITED _ -> failwith \"external virt-inspector command failed\"
589 | WSIGNALED i | WSTOPPED i ->
590 failwith (\"external virt-inspector command died or stopped on sig \" ^
595 Xml.parse_string doc in
596 parse_operatingsystems xml
599 let files_equal n1 n2 =
600 let cmd = sprintf "cmp -s %s %s" (Filename.quote n1) (Filename.quote n2) in
601 match Sys.command cmd with
604 | i -> failwithf "%s: failed with error code %d" cmd i
606 let output_to filename =
607 let filename_new = filename ^ ".new" in
608 chan := open_out filename_new;
613 (* Is the new file different from the current file? *)
614 if Sys.file_exists filename && files_equal filename filename_new then
615 Unix.unlink filename_new (* same, so skip it *)
617 (* different, overwrite old one *)
618 (try Unix.chmod filename 0o644 with Unix.Unix_error _ -> ());
619 Unix.rename filename_new filename;
620 Unix.chmod filename 0o444;
621 printf "written %s\n%!" filename;
628 let close = output_to "ocaml/guestfs_inspector.mli" in
629 generate_ocaml_mli ();
632 let close = output_to "ocaml/guestfs_inspector.ml" in
633 generate_ocaml_ml ();