inspector/inspector_generator.ml

   1 #!/usr/bin/env ocaml
   2 (* libguestfs
   3  * Copyright (C) 2009 Red Hat Inc.
   4  *
   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.
   9  *
  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.
  14  *
  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
  18  *)
  19
  20 (* This program generates language bindings for virt-inspector, so
  21  * you can use it from programs (other than Perl programs).
  22  *
  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.
  26  *
  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.
  30  *)
  31
  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.
  36  *)
  37 #load "unix.cma";;
  38 #directory "+xml-light";;
  39 #load "xml-light.cma";;
  40
  41 open Printf
  42
  43 module StringMap = Map.Make (String)
  44
  45 let failwithf fs = ksprintf failwith fs
  46 let unique = let i = ref 0 in fun () -> incr i; !i
  47
  48 (* Check we're running from the right directory. *)
  49 let () =
  50   if not (Sys.file_exists "HACKING") then (
  51     eprintf "You are probably running this from the wrong directory.\n";
  52     exit 1
  53   )
  54
  55 let input = "inspector/virt-inspector.rng"
  56
  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.
  60  *)
  61 type rng =
  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> *)
  70   | Text                                (* <text/> *)
  71
  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 ^ "\""
  83   | Text -> "Text"
  84
  85 and string_of_rng_list xs =
  86   String.concat ", " (List.map string_of_rng xs)
  87
  88 let rec parse_rng ?defines context = function
  89   | [] -> []
  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
 101       (match rng with
 102        | [child] -> ZeroOrMore child :: parse_rng ?defines context rest
 103        | _ ->
 104            failwithf "%s: <zeroOrMore> contains more than one child element"
 105              context
 106       )
 107   | Xml.Element ("oneOrMore", [], [child]) :: rest ->
 108       let rng = parse_rng ?defines context [child] in
 109       (match rng with
 110        | [child] -> OneOrMore child :: parse_rng ?defines context rest
 111        | _ ->
 112            failwithf "%s: <oneOrMore> contains more than one child element"
 113              context
 114       )
 115   | Xml.Element ("optional", [], [child]) :: rest ->
 116       let rng = parse_rng ?defines context [child] in
 117       (match rng with
 118        | [child] -> Optional child :: parse_rng ?defines context rest
 119        | _ ->
 120            failwithf "%s: <optional> contains more than one child element"
 121              context
 122       )
 123   | Xml.Element ("choice", [], children) :: rest ->
 124       let values = List.map (
 125         function Xml.Element ("value", [], [Xml.PCData value]) -> value
 126         | _ ->
 127             failwithf "%s: can't handle anything except <value> in <choice>"
 128               context
 129       ) children in
 130       Choice values
 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>.
 140        *)
 141       (match defines with
 142        | None ->
 143            failwithf "%s: contains <ref>, but no refs are defined yet" context
 144        | Some map ->
 145            let rng = StringMap.find name map in
 146            rng @ parse_rng ?defines context rest
 147       )
 148   | x :: _ ->
 149       failwithf "%s: can't handle '%s' in schema" context (Xml.to_string x)
 150
 151 let grammar =
 152   let xml = Xml.parse_file input in
 153   match xml with
 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.
 158        *)
 159       let defines = List.fold_left (
 160         fun map ->
 161           function Xml.Element ("define", ["name", name], defn) ->
 162             StringMap.add name defn map
 163           | _ ->
 164               failwithf "%s: expected <define name=name/>" input
 165       ) StringMap.empty defines in
 166       let defines = StringMap.mapi parse_rng defines in
 167
 168       (* Parse the <start> clause, passing the defines. *)
 169       parse_rng ~defines "<start>" gram
 170   | _ ->
 171       failwithf "%s: input is not <grammar><start/><define>*</grammar>" input
 172
 173 (* 'pr' prints to the current output file. *)
 174 let chan = ref stdout
 175 let pr fs = ksprintf (output_string !chan) fs
 176
 177 (* Generate a header block in a number of standard styles. *)
 178 type comment_style = CStyle | HashStyle | OCamlStyle | HaskellStyle
 179 type license = GPLv2 | LGPLv2
 180
 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;
 191   pr "%s\n" c;
 192   pr "%s Copyright (C) 2009 Red Hat Inc.\n" c;
 193   pr "%s\n" c;
 194   (match license with
 195    | GPLv2 ->
 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;
 200        pr "%s\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;
 205        pr "%s\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;
 209
 210    | LGPLv2 ->
 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;
 215        pr "%s\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;
 220        pr "%s\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;
 224   );
 225   (match comment with
 226    | CStyle -> pr " */\n"
 227    | HashStyle -> ()
 228    | OCamlStyle -> pr " *)\n"
 229    | HaskellStyle -> pr "-}\n"
 230   );
 231   pr "\n"
 232
 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 *)
 240       "data"
 241   | rng ->
 242       failwithf "name_of_field failed at: %s" (string_of_rng rng)
 243
 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.
 247  *)
 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.
 252    *
 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).
 259    *)
 260   let rec generate_type = function
 261     | Text ->                                (* string *)
 262         "string", true
 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"])) ->
 273         "bool", true
 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)
 284         else (
 285           pr "type %s = %s\n" name t;
 286           name, false
 287         )
 288     | Element (name, fields) ->              (* type name = { fields ... } *)
 289         generate_type_struct name fields
 290     | rng ->
 291         failwithf "generate_type failed at: %s" (string_of_rng rng)
 292
 293   and is_attrs_interleave = function
 294     | [Interleave _] -> true
 295     | Attribute _ :: fields -> is_attrs_interleave fields
 296     | Optional (Attribute _) :: fields -> is_attrs_interleave fields
 297     | _ -> false
 298
 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
 304     | _ -> assert false
 305
 306   and generate_types xs =
 307     List.iter (fun x -> ignore (generate_type x)) xs
 308
 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.
 312      *)
 313     let types = List.map fst (List.map generate_type fields) in
 314
 315     (* Special case of a struct containing just a string and another
 316      * field.  Turn it into an assoc list.
 317      *)
 318     match types with
 319     | ["string"; other] ->
 320         let fname1, fname2 =
 321           match fields with
 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;
 325         name, false
 326
 327     | types ->
 328         pr "type %s = {\n" name;
 329         List.iter (
 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);
 334         pr "}\n";
 335         (* Return the name of this type, and
 336          * false because it's not a simple type.
 337          *)
 338         name, false
 339   in
 340
 341   generate_types xs
 342
 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.
 348    *)
 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))"
 354           (String.concat "|"
 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;
 375         pr "  %s\n" pa;
 376         pr "let parse_%s = %s\n" name parser_name;
 377         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;
 382         pr "  %s\n" pa;
 383         pr "let parse_%s = %s\n" name parser_name;
 384         parser_name
 385     | Element (name, fields) ->              (* type name = { fields ... } *)
 386         generate_parser_struct name ([], fields)
 387     | rng ->
 388         failwithf "generate_parser failed at: %s" (string_of_rng rng)
 389
 390   and is_attrs_interleave = function
 391     | [Interleave _] -> true
 392     | Attribute _ :: fields -> is_attrs_interleave fields
 393     | Optional (Attribute _) :: fields -> is_attrs_interleave fields
 394     | _ -> false
 395
 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
 402     | _ -> assert false
 403
 404   and generate_parsers xs =
 405     List.iter (fun x -> ignore (generate_parser x)) xs
 406
 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.
 410      *)
 411     let fields = attrs @ interleaves in
 412     let pas = List.map generate_parser fields in
 413
 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.
 417      *
 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.
 421      *)
 422     pr "let parse_%s x =\n" name;
 423     pr "  let t = (\n    ";
 424     let comma = ref false in
 425     List.iter (
 426       fun x ->
 427         if !comma then pr ",\n    ";
 428         comma := true;
 429         match x with
 430         | Optional (Attribute (fname, [field])), pa ->
 431             pr "%s x" 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 ->
 437             pr "%s x" pa
 438         | Text, pa ->
 439             pr "%s x" pa
 440         | (field, pa) ->
 441             let fname = name_of_field field in
 442             pr "%s (child %S x)" pa fname
 443     ) (List.combine fields pas);
 444     pr "\n  ) in\n";
 445
 446     (match fields with
 447      | [Element (_, [Text]) | Attribute (_, [Text]); _] ->
 448          pr "  t\n"
 449
 450      | _ ->
 451          pr "  (Obj.magic t : %s)\n" name
 452 (*
 453          List.iter (
 454            function
 455            | (Optional (Attribute (fname, [field])), pa) ->
 456                pr "  %s_%s =\n" name fname;
 457                pr "    %s x;\n" pa
 458            | (Optional (Element (fname, [field])), pa) ->
 459                pr "  %s_%s =\n" name fname;
 460                pr "    (let x = optional_child %S x in\n" fname;
 461                pr "     %s x);\n" pa
 462            | (field, pa) ->
 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;
 466                pr "     %s x);\n" pa
 467          ) (List.combine fields pas);
 468          pr "}\n"
 469 *)
 470     );
 471     sprintf "parse_%s" name
 472   in
 473
 474   generate_parsers xs
 475
 476 (* Generate ocaml/guestfs_inspector.mli. *)
 477 let generate_ocaml_mli () =
 478   generate_header OCamlStyle LGPLv2;
 479
 480   pr "\
 481 (** This is an OCaml language binding to the external [virt-inspector]
 482     program.
 483
 484     For more information, please read the man page [virt-inspector(1)].
 485 *)
 486
 487 ";
 488
 489   generate_types grammar;
 490   pr "(** The nested information returned from the {!inspect} function. *)\n";
 491   pr "\n";
 492
 493   pr "\
 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 ...].
 498
 499     To inspect a disk image or images, pass a list of the filenames
 500     of the disk images: [inspect filenames]
 501
 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.
 506
 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.
 512
 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.
 516 *)
 517 "
 518
 519 (* Generate ocaml/guestfs_inspector.ml. *)
 520 let generate_ocaml_ml () =
 521   generate_header OCamlStyle LGPLv2;
 522
 523   pr "open Unix\n";
 524   pr "\n";
 525
 526   generate_types grammar;
 527   pr "\n";
 528
 529   pr "\
 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\")
 535   | Xml.PCData str ->
 536       failwith (\"expected XML tag, but read PCDATA '\" ^ str ^ \"' instead\")
 537
 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 \" ^
 543                 x ^ \" instead\")
 544   | Xml.PCData str ->
 545       failwith (\"expected XML tag, but read PCDATA '\" ^ str ^ \"' instead\")
 546
 547 let optional_child name xml =
 548   let children = Xml.children xml in
 549   try
 550     Some (List.find (function
 551                      | Xml.Element (n, _, _) when n = name -> true
 552                      | _ -> false) children)
 553   with
 554     Not_found -> None
 555
 556 let child name xml =
 557   match optional_child name xml with
 558   | Some c -> c
 559   | None ->
 560       failwith (\"mandatory field <\" ^ name ^ \"/> missing in XML output\")
 561
 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\")
 566
 567 ";
 568
 569   generate_parsers grammar;
 570   pr "\n";
 571
 572   pr "\
 573 (* Run external virt-inspector, then use parser to parse the XML. *)
 574 let inspect ?connect ?xml names =
 575   let xml =
 576     match xml with
 577     | None ->
 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 ]) @
 581           names in
 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
 587          | WEXITED 0 -> ()
 588          | WEXITED _ -> failwith \"external virt-inspector command failed\"
 589          | WSIGNALED i | WSTOPPED i ->
 590              failwith (\"external virt-inspector command died or stopped on sig \" ^
 591                        string_of_int i)
 592         );
 593         xml
 594     | Some doc ->
 595         Xml.parse_string doc in
 596   parse_operatingsystems xml
 597 "
 598
 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
 602   | 0 -> true
 603   | 1 -> false
 604   | i -> failwithf "%s: failed with error code %d" cmd i
 605
 606 let output_to filename =
 607   let filename_new = filename ^ ".new" in
 608   chan := open_out filename_new;
 609   let close () =
 610     close_out !chan;
 611     chan := stdout;
 612
 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 *)
 616     else (
 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;
 622     )
 623   in
 624   close
 625
 626 (* Output. *)
 627 let () =
 628   let close = output_to "ocaml/guestfs_inspector.mli" in
 629   generate_ocaml_mli ();
 630   close ();
 631
 632   let close = output_to "ocaml/guestfs_inspector.ml" in
 633   generate_ocaml_ml ();
 634   close ()