Ruby bindings.
tools/
- Command line tools like virt-cat, virt-df, virt-edit and more.
- In versions <= 1.0.73 these were all in separate directories
- like cat/, df/, edit/, but since then we moved them all into
- one directory to simplify builds.
+ Command line tools like virt-cat, virt-df, virt-edit and more.
+ In versions <= 1.0.73 these were all in separate directories
+ like cat/, df/, edit/, but since then we moved them all into
+ one directory to simplify builds.
src/
Source code to the C library.
sort_strings (res, size-1);
- return res; /* caller frees */
+ return res; /* caller frees */
}
/* The code below assumes each path returned can fit into a protocol
if (ferror (fp)) {
perror (dir);
- send_file_end (1); /* Cancel. */
+ send_file_end (1); /* Cancel. */
pclose (fp);
return -1;
}
if (pclose (fp) != 0) {
perror (dir);
- send_file_end (1); /* Cancel. */
+ send_file_end (1); /* Cancel. */
return -1;
}
- if (send_file_end (0)) /* Normal end of file. */
+ if (send_file_end (0)) /* Normal end of file. */
return -1;
return 0;
}
-
* 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/> *)
+ | 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) ->
(match rng with
| [child] -> ZeroOrMore child :: parse_rng ?defines context rest
| _ ->
- failwithf "%s: <zeroOrMore> contains more than one child element"
- context
+ 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
+ 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
+ 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
+ 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
*)
(match defines with
| None ->
- failwithf "%s: contains <ref>, but no refs are defined yet" context
+ 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
+ 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 xml = Xml.parse_file input in
match xml with
| Xml.Element ("grammar", _,
- Xml.Element ("start", _, gram) :: defines) ->
+ 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
+ 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
* 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 *)
+ | 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
+ "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 *)
+ 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
+ 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)
+ failwithf "generate_type failed at: %s" (string_of_rng rng)
and is_attrs_interleave = function
| [Interleave _] -> true
| [Interleave fields] -> fields
| ((Attribute _) as field) :: fields
| ((Optional (Attribute _)) as field) :: fields ->
- field :: get_attrs_interleave fields
+ field :: get_attrs_interleave fields
| _ -> assert false
and generate_types xs =
*)
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
+ 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
+ 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
* 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 *)
+ | 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
+ 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
+ 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)
+ 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)
+ failwithf "generate_parser failed at: %s" (string_of_rng rng)
and is_attrs_interleave = function
| [Interleave _] -> true
| [Interleave fields] -> [], fields
| ((Attribute _) as field) :: fields
| ((Optional (Attribute _)) as field) :: fields ->
- let attrs, interleaves = get_attrs_interleave fields in
- (field :: attrs), interleaves
+ let attrs, interleaves = get_attrs_interleave fields in
+ (field :: attrs), interleaves
| _ -> assert false
and generate_parsers xs =
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
+ 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 " t\n"
| _ ->
- pr " (Obj.magic t : %s)\n" name
+ 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"
+ 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
(* 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 *)
+ Unix.unlink filename_new (* same, so skip it *)
else (
(* different, overwrite old one *)
(try Unix.chmod filename 0o644 with Unix.Unix_error _ -> ());
}
if ($os->{kernels}) {
- $xml->startTag("kernels");
- my @kernels = @{$os->{kernels}};
- foreach (@kernels) {
- $xml->startTag("kernel",
- "version" => $_->{version},
- "arch" => $_->{arch});
- $xml->startTag("modules");
- my @modules = @{$_->{modules}};
- foreach (@modules) {
- $xml->dataElement("module", $_);
- }
- $xml->endTag("modules");
- $xml->dataElement("path", $_->{path}) if(defined($_->{path}));
- $xml->dataElement("package", $_->{package}) if(defined($_->{package}));
- $xml->endTag("kernel");
- }
- $xml->endTag("kernels");
+ $xml->startTag("kernels");
+ my @kernels = @{$os->{kernels}};
+ foreach (@kernels) {
+ $xml->startTag("kernel",
+ "version" => $_->{version},
+ "arch" => $_->{arch});
+ $xml->startTag("modules");
+ my @modules = @{$_->{modules}};
+ foreach (@modules) {
+ $xml->dataElement("module", $_);
+ }
+ $xml->endTag("modules");
+ $xml->dataElement("path", $_->{path}) if(defined($_->{path}));
+ $xml->dataElement("package", $_->{package}) if(defined($_->{package}));
+ $xml->endTag("kernel");
+ }
+ $xml->endTag("kernels");
}
if (exists $os->{root}->{registry}) {
<start>
<element name="operatingsystems">
<oneOrMore>
- <element name="operatingsystem">
- <interleave>
-
- <!-- required fields for an operating system -->
- <element name="name">
- <choice>
- <value>linux</value>
- <value>windows</value>
- </choice>
- </element>
- <element name="arch"><text/></element>
- <element name="root"><text/></element>
-
- <!-- optional fields for an operating system -->
- <optional><element name="distro"><text/></element></optional>
- <optional><element name="major_version"><text/></element></optional>
- <optional><element name="minor_version"><text/></element></optional>
- <optional><element name="package_format"><text/></element></optional>
- <optional><element name="package_management"><text/></element></optional>
-
- <ref name="mountpoints"/>
- <ref name="filesystems"/>
- <optional><ref name="applications"/></optional>
- <optional><ref name="modprobealiases"/></optional>
- <optional><ref name="initrds"/></optional>
- <optional><ref name="kernels"/></optional>
- <optional><ref name="boot"/></optional>
-
- </interleave>
- </element>
+ <element name="operatingsystem">
+ <interleave>
+
+ <!-- required fields for an operating system -->
+ <element name="name">
+ <choice>
+ <value>linux</value>
+ <value>windows</value>
+ </choice>
+ </element>
+ <element name="arch"><text/></element>
+ <element name="root"><text/></element>
+
+ <!-- optional fields for an operating system -->
+ <optional><element name="distro"><text/></element></optional>
+ <optional><element name="major_version"><text/></element></optional>
+ <optional><element name="minor_version"><text/></element></optional>
+ <optional><element name="package_format"><text/></element></optional>
+ <optional><element name="package_management"><text/></element></optional>
+
+ <ref name="mountpoints"/>
+ <ref name="filesystems"/>
+ <optional><ref name="applications"/></optional>
+ <optional><ref name="modprobealiases"/></optional>
+ <optional><ref name="initrds"/></optional>
+ <optional><ref name="kernels"/></optional>
+ <optional><ref name="boot"/></optional>
+
+ </interleave>
+ </element>
</oneOrMore>
</element>
</start>
<define name="mountpoints">
<element name="mountpoints">
<oneOrMore>
- <element name="mountpoint">
- <attribute name="dev"><text/></attribute>
- <text/>
- </element>
+ <element name="mountpoint">
+
<attribute name="dev"><text/></attribute>
+ <text/>
+ </element>
</oneOrMore>
</element>
</define>
<define name="filesystems">
<element name="filesystems">
<oneOrMore>
- <element name="filesystem">
- <attribute name="dev"><text/></attribute>
- <interleave>
- <element name="type"><text/></element>
- <optional><element name="content"><text/></element></optional>
- <optional><element name="label"><text/></element></optional>
- <optional><element name="uuid"><text/></element></optional>
- <optional><element name="spec"><text/></element></optional>
- </interleave>
- </element>
+ <element name="filesystem">
+
<attribute name="dev"><text/></attribute>
+ <interleave>
+ <element name="type"><text/></element>
+ <optional><element name="content"><text/></element></optional>
+ <optional><element name="label"><text/></element></optional>
+ <optional><element name="uuid"><text/></element></optional>
+ <optional><element name="spec"><text/></element></optional>
+ </interleave>
+ </element>
</oneOrMore>
</element>
</define>
<define name="applications">
<element name="applications">
<zeroOrMore>
- <element name="application">
- <element name="name"><text/></element>
- <element name="version"><text/></element>
- </element>
+ <element name="application">
+ <element name="name"><text/></element>
+ <element name="version"><text/></element>
+ </element>
</zeroOrMore>
</element>
</define>
<define name="modprobealiases">
<element name="modprobealiases">
<zeroOrMore>
- <element name="alias">
- <attribute name="device"><text/></attribute>
- <interleave>
- <element name="modulename"><text/></element>
- <optional><element name="augeas"><text/></element></optional>
- <element name="file"><text/></element>
- </interleave>
- </element>
+ <element name="alias">
+
<attribute name="device"><text/></attribute>
+ <interleave>
+ <element name="modulename"><text/></element>
+ <optional><element name="augeas"><text/></element></optional>
+ <element name="file"><text/></element>
+ </interleave>
+ </element>
</zeroOrMore>
</element>
</define>
<define name="initrds">
<element name="initrds">
<zeroOrMore>
- <element name="initrd">
- <attribute name="version"><text/></attribute>
- <zeroOrMore>
- <element name="module"><text/></element>
- </zeroOrMore>
- </element>
+ <element name="initrd">
+
<attribute name="version"><text/></attribute>
+ <zeroOrMore>
+ <element name="module"><text/></element>
+ </zeroOrMore>
+ </element>
</zeroOrMore>
</element>
</define>
<define name="boot">
<element name="boot">
<zeroOrMore>
- <element name="config">
- <optional>
- <attribute name="default"><value>1</value></attribute>
- </optional>
- <interleave>
- <element name="title"><text/></element>
- <element name="kernel"><text/></element>
- <element name="cmdline"><text/></element>
- </interleave>
- </element>
+ <element name="config">
+ <optional>
+
<attribute name="default"><value>1</value></attribute>
+ </optional>
+ <interleave>
+ <element name="title"><text/></element>
+ <element name="kernel"><text/></element>
+ <element name="cmdline"><text/></element>
+ </interleave>
+ </element>
</zeroOrMore>
</element>
</define>
<define name="kernels">
<element name="kernels">
<zeroOrMore>
- <element name="kernel">
- <attribute name="version"><text/></attribute>
- <attribute name="arch"><text/></attribute>
- <interleave>
- <element name="modules">
- <zeroOrMore>
- <element name="module"><text/></element>
- </zeroOrMore>
- </element>
- <optional><element name="path"><text/></element></optional>
- <optional><element name="package"><text/></element></optional>
- </interleave>
- </element>
+ <element name="kernel">
+
<attribute name="version"><text/></attribute>
+
<attribute name="arch"><text/></attribute>
+ <interleave>
+ <element name="modules">
+ <zeroOrMore>
+ <element name="module"><text/></element>
+ </zeroOrMore>
+ </element>
+ <optional><element name="path"><text/></element></optional>
+ <optional><element name="package"><text/></element></optional>
+ </interleave>
+ </element>
</zeroOrMore>
</element>
</define>
module M = Mutex
module Q = Queue
-let verbose = ref false (* Verbose mode. *)
+let verbose = ref false (* Verbose mode. *)
let debug fs =
let f str = if !verbose then ( prerr_string str; prerr_newline () ) in
type 'a callback = 'a -> unit
type partinfo = {
- pt_name : string; (** device / LV name *)
- pt_size : int64; (** in bytes *)
- pt_content : string; (** the output of the 'file' command *)
+ pt_name : string; (** device / LV name *)
+ pt_size : int64; (** in bytes *)
+ pt_content : string; (** the output of the 'file' command *)
pt_statvfs : G.statvfs option; (** None if not mountable *)
}
val set_failure_callback : exn callback -> unit
(** Set the function that is called in the main thread whenever
- there is a command failure in the slave. The command queue
- is cleared before this is sent. [exn] is the exception
- associated with the failure. *)
+ there is a command failure in the slave. The command queue
+ is cleared before this is sent. [exn] is the exception
+ associated with the failure. *)
val set_busy_callback : [`Busy|`Idle] callback -> unit
(** Set the function that is called in the main thread whenever
- the slave thread goes busy or idle. *)
+ the slave thread goes busy or idle. *)
val exit_thread : unit -> unit
(** [exit_thread ()] causes the slave thread to exit. *)
val connect : string option -> string option callback -> unit
(** [connect uri cb] connects to libvirt [uri], and calls [cb]
- if it completes successfully. Any previous connection is
- automatically cleaned up and disconnected. *)
+ if it completes successfully. Any previous connection is
+ automatically cleaned up and disconnected. *)
val get_domains : string list callback -> unit
(** [get_domains cb] gets the list of active domains from libvirt,
- and calls [cb domains] with the names of those domains. *)
+ and calls [cb domains] with the names of those domains. *)
val open_domain : string -> partinfo list callback -> unit
(** [open_domain dom cb] sets the domain [dom] as the current
- domain, and launches a libguestfs handle for it. Any previously
- current domain and libguestfs handle is closed. Once the
- libguestfs handle is opened (which usually takes some time),
- callback [cb] is called with the list of partitions found
- in the guest. *)
+ domain, and launches a libguestfs handle for it. Any previously
+ current domain and libguestfs handle is closed. Once the
+ libguestfs handle is opened (which usually takes some time),
+ callback [cb] is called with the list of partitions found
+ in the guest. *)
val slave_loop : unit -> unit
(** The slave thread's main loop, running in the slave thread. *)
| Either r -> r
| Or exn -> raise exn
- let q = Q.create () (* queue of commands *)
+ let q = Q.create () (* queue of commands *)
let q_lock = M.create ()
let q_cond = Cd.create ()
debug "sending to slave: %s" (string_of_command c);
with_lock q_lock (
fun () ->
- Q.push c q;
- Cd.signal q_cond
+ Q.push c q;
+ Cd.signal q_cond
)
let exit_thread () =
* any references to these objects to escape from the slave
* thread.
*)
- let conn = ref None (* libvirt connection *)
- let dom = ref None (* libvirt domain *)
- let g = ref None (* libguestfs handle *)
+ let conn = ref None (* libvirt connection *)
+ let dom = ref None (* libvirt domain *)
+ let g = ref None (* libguestfs handle *)
let quit = ref false
debug "Slave.slave_loop: waiting for a command";
let c =
with_lock q_lock (
- fun () ->
- while Q.is_empty q do
- Cd.wait q_cond q_lock
- done;
- Q.pop q
+ fun () ->
+ while Q.is_empty q do
+ Cd.wait q_cond q_lock
+ done;
+ Q.pop q
) in
(try
debug "Slave.slave_loop: command succeeded";
with exn ->
(* If an exception is thrown, it means the command failed. In
- * this case we clear the command queue and deliver the failure
- * callback in the main thread.
- *)
+ * this case we clear the command queue and deliver the failure
+ * callback in the main thread.
+ *)
debug "Slave.slave_loop: command failed";
!busy_cb `Idle;
and exec_command = function
| Exit_thread ->
- quit := true; (* quit first in case disconnect_all throws an exn *)
- disconnect_all ()
+ quit := true; (* quit first in case disconnect_all throws an exn *)
+ disconnect_all ()
| Connect (name, cb) ->
- disconnect_all ();
- conn := Some (C.connect_readonly ?name ());
- cb name
+ disconnect_all ();
+ conn := Some (C.connect_readonly ?name ());
+ cb name
| Get_domains cb ->
- let conn = Option.get !conn in
- let doms = D.get_domains conn [D.ListAll] in
- (* Only return the names, so that the libvirt objects
- * aren't leaked outside the slave thread.
- *)
- let doms = List.map D.get_name doms in
- cb doms
+ let conn = Option.get !conn in
+ let doms = D.get_domains conn [D.ListAll] in
+ (* Only return the names, so that the libvirt objects
+ * aren't leaked outside the slave thread.
+ *)
+ let doms = List.map D.get_name doms in
+ cb doms
| Open_domain (domname, cb) ->
- let conn = Option.get !conn in
- disconnect_dom ();
- dom := Some (D.lookup_by_name conn domname);
- let dom = Option.get !dom in
-
- (* Get the devices. *)
- let xml = D.get_xml_desc dom in
- let devs = get_devices_from_xml xml in
-
- (* Create the libguestfs handle and launch it. *)
- let g' = G.create () in
- List.iter (G.add_drive_ro g') devs;
- G.launch g';
- g := Some g';
-
- (* Get the list of partitions. *)
- let parts = Array.to_list (G.list_partitions g') in
- (* Remove any which are PVs. *)
- let pvs = Array.to_list (G.pvs g') in
- let parts = List.filter (fun part -> not (List.mem part pvs)) parts in
- let lvs = Array.to_list (G.lvs g') in
- let parts = parts @ lvs in
-
- let parts = List.map (
- fun part ->
- (* Find out the size of each partition. *)
- let size = G.blockdev_getsize64 g' part in
-
- (* Find out what's on each partition. *)
- let content = G.file g' part in
-
- (* Try to mount it. *)
- let statvfs =
- try
- G.mount_ro g' part "/";
- Some (G.statvfs g' "/")
- with _ -> None in
- G.umount_all g';
-
- { pt_name = part; pt_size = size; pt_content = content;
- pt_statvfs = statvfs }
- ) parts in
-
- (* Call the callback. *)
- cb parts
+ let conn = Option.get !conn in
+ disconnect_dom ();
+ dom := Some (D.lookup_by_name conn domname);
+ let dom = Option.get !dom in
+
+ (* Get the devices. *)
+ let xml = D.get_xml_desc dom in
+ let devs = get_devices_from_xml xml in
+
+ (* Create the libguestfs handle and launch it. *)
+ let g' = G.create () in
+ List.iter (G.add_drive_ro g') devs;
+ G.launch g';
+ g := Some g';
+
+ (* Get the list of partitions. *)
+ let parts = Array.to_list (G.list_partitions g') in
+ (* Remove any which are PVs. *)
+ let pvs = Array.to_list (G.pvs g') in
+ let parts = List.filter (fun part -> not (List.mem part pvs)) parts in
+ let lvs = Array.to_list (G.lvs g') in
+ let parts = parts @ lvs in
+
+ let parts = List.map (
+ fun part ->
+ (* Find out the size of each partition. *)
+ let size = G.blockdev_getsize64 g' part in
+
+ (* Find out what's on each partition. *)
+ let content = G.file g' part in
+
+ (* Try to mount it. *)
+ let statvfs =
+ try
+ G.mount_ro g' part "/";
+ Some (G.statvfs g' "/")
+ with _ -> None in
+ G.umount_all g';
+
+ { pt_name = part; pt_size = size; pt_content = content;
+ pt_statvfs = statvfs }
+ ) parts in
+
+ (* Call the callback. *)
+ cb parts
(* Close all libvirt/libguestfs handles. *)
and disconnect_all () =
let xs = {{ [xml] }} in
let xs = {{ (((xs.(<domain..>_)) / .(<devices..>_)) / .(<disk..>_)) / }} in
let xs = {{ map xs with
- | <source dev=(Latin1 & s) ..>_
+ | <source dev=(Latin1 & s) ..>_
| <source file=(Latin1 & s) ..>_ -> [s]
| _ -> [] }} in
{: xs :}
ignore (window#connect#destroy ~callback:GMain.quit);
ignore (window#event#connect#delete ~callback:quit);
ignore (quit_item#connect#activate
- ~callback:(fun () -> ignore (quit ()); ()));
+ ~callback:(fun () -> ignore (quit ()); ()));
(* Top status area. *)
let hbox = GPack.hbox ~border_width:4 ~packing:vbox#pack () in
model#clear ();
List.iter (
fun name ->
- let row = model#append () in
- model#set ~row ~column name
+ let row = model#append () in
+ model#set ~row ~column name
) names
in
GMisc.image ~pixbuf:static ~packing:(hbox#pack ~from:`END) () in
let throbber_set = function
| `Busy -> (*throbber#set_pixbuf animation*)
- (* Workaround because no binding for GdkPixbufAnimation: *)
- let file = Filename.dirname Sys.argv.(0) // "Throbber.gif" in
- throbber#set_file file
+ (* Workaround because no binding for GdkPixbufAnimation: *)
+ let file = Filename.dirname Sys.argv.(0) // "Throbber.gif" in
+ throbber#set_file file
| `Idle -> throbber#set_pixbuf static
in
let combo, (model, column) = vmcombo in
combo#connect#changed
~callback:(
- fun () ->
- match combo#active_iter with
- | None -> ()
- | Some row ->
- let name = model#get ~row ~column in
- ds.set_statusbar (sprintf "Opening %s ..." name);
- Slave.open_domain name (opened_domain ds))
+ fun () ->
+ match combo#active_iter with
+ | None -> ()
+ | Some row ->
+ let name = model#get ~row ~column in
+ ds.set_statusbar (sprintf "Opening %s ..." name);
+ Slave.open_domain name (opened_domain ds))
);
ignore (da#event#connect#expose ~callback:(repaint ds));
let parts =
List.map (
fun ({ Slave.pt_size = size } as part) ->
- let h = scale *. Int64.to_float size in
- (h, part)
+ let h = scale *. Int64.to_float size in
+ (h, part)
) parts in
(*
eprintf "real_repaint: before borrowing:\n";
List.iter (
fun (h, part) ->
- eprintf "%s\t%g pix\n" part.Slave.pt_name h
+ eprintf "%s\t%g pix\n" part.Slave.pt_name h
) parts
);
*)
let rec borrow needed = function
| [] -> 0., []
| (h, part) :: parts ->
- let spare = h -. min_h in
- if spare >= needed then (
- needed, (h -. needed, part) :: parts
- ) else if spare > 0. then (
- let needed = needed -. spare in
- let spare', parts = borrow needed parts in
- spare +. spare', (h -. spare, part) :: parts
- ) else (
- let spare', parts = borrow needed parts in
- spare', (h, part) :: parts
- )
+ let spare = h -. min_h in
+ if spare >= needed then (
+ needed, (h -. needed, part) :: parts
+ ) else if spare > 0. then (
+ let needed = needed -. spare in
+ let spare', parts = borrow needed parts in
+ spare +. spare', (h -. spare, part) :: parts
+ ) else (
+ let spare', parts = borrow needed parts in
+ spare', (h, part) :: parts
+ )
in
let rec loop = function
| parts, [] -> List.rev parts
| prev, ((h, part) :: parts) ->
- let needed = min_h -. h in
- let h, prev, parts =
- if needed > 0. then (
- (* Find some spare height in a succeeding partition(s). *)
- let spare, parts = borrow needed parts in
- (* Or if not, in a preceeding partition(s). *)
- let spare, prev =
- if spare = 0. then borrow needed prev else spare, prev in
- h +. spare, prev, parts
- ) else (
- h, prev, parts
- ) in
- loop (((h, part) :: prev), parts)
+ let needed = min_h -. h in
+ let h, prev, parts =
+ if needed > 0. then (
+ (* Find some spare height in a succeeding partition(s). *)
+ let spare, parts = borrow needed parts in
+ (* Or if not, in a preceeding partition(s). *)
+ let spare, prev =
+ if spare = 0. then borrow needed prev else spare, prev in
+ h +. spare, prev, parts
+ ) else (
+ h, prev, parts
+ ) in
+ loop (((h, part) :: prev), parts)
in
let parts = loop ([], parts) in
eprintf "real_repaint: after borrowing:\n";
List.iter (
fun (h, part) ->
- eprintf "%s\t%g pix\n" part.Slave.pt_name h
+ eprintf "%s\t%g pix\n" part.Slave.pt_name h
) parts
);
*)
let parts = List.map (
fun (h, part) ->
let used =
- match part.Slave.pt_statvfs with
- | None -> 0.
- | Some { G.bavail = bavail; blocks = blocks } ->
- let num = Int64.to_float (Int64.sub blocks bavail) in
- let denom = Int64.to_float blocks in
- num /. denom in
+ match part.Slave.pt_statvfs with
+ | None -> 0.
+ | Some { G.bavail = bavail; blocks = blocks } ->
+ let num = Int64.to_float (Int64.sub blocks bavail) in
+ let denom = Int64.to_float blocks in
+ num /. denom in
(h, used, part)
) parts in
ignore (
List.fold_left (
fun y (h, used, part) ->
- (* This partition occupies pixels 8+y .. 8+y+h-1 *)
- let yb = 8 + int_of_float y
- and yt = 8 + int_of_float (y +. h) in
-
- ds.draw#set_foreground `WHITE;
- ds.draw#rectangle ~x:8 ~y:yb ~width:(width-16) ~height:(yt-yb)
- ~filled:true ();
-
- let col =
- if used < 0.6 then `NAME "grey"
- else if used < 0.8 then `NAME "pink"
- else if used < 0.9 then `NAME "hot pink"
- else `NAME "red" in
- ds.draw#set_foreground col;
- let w = int_of_float (used *. (float width -. 16.)) in
- ds.draw#rectangle ~x:8 ~y:yb ~width:w ~height:(yt-yb) ~filled:true ();
-
- ds.draw#set_foreground `BLACK;
- ds.draw#rectangle ~x:8 ~y:yb ~width:(width-16) ~height:(yt-yb) ();
-
- (* Large text - the device name. *)
- let txt = ds.pango_large_context#create_layout in
- Pango.Layout.set_text txt part.Slave.pt_name;
- let fore = `NAME "dark slate grey" in
- ds.draw#put_layout ~x:12 ~y:(yb+4) ~fore txt;
-
- let { Pango.height = txtheight; Pango.width = txtwidth } =
- Pango.Layout.get_pixel_extent txt in
-
- (* Small text below - the content. *)
- let txt = ds.pango_small_context#create_layout in
- Pango.Layout.set_text txt part.Slave.pt_content;
- let fore = `BLACK in
- ds.draw#put_layout ~x:12 ~y:(yb+4+txtheight) ~fore txt;
-
- (* Small text right - size. *)
- let size =
- match part.Slave.pt_statvfs with
- | None -> printable_size part.Slave.pt_size
- | Some { G.blocks = blocks; bsize = bsize } ->
- let bytes = Int64.mul blocks bsize in
- let pc = 100. *. used in
- sprintf "%s (%.1f%% used)" (printable_size bytes) pc in
- let txt = ds.pango_small_context#create_layout in
- Pango.Layout.set_text txt size;
- ds.draw#put_layout ~x:(16+txtwidth) ~y:(yb+4) ~fore txt;
-
- (y +. h)
+ (* This partition occupies pixels 8+y .. 8+y+h-1 *)
+ let yb = 8 + int_of_float y
+ and yt = 8 + int_of_float (y +. h) in
+
+ ds.draw#set_foreground `WHITE;
+ ds.draw#rectangle ~x:8 ~y:yb ~width:(width-16) ~height:(yt-yb)
+ ~filled:true ();
+
+ let col =
+ if used < 0.6 then `NAME "grey"
+ else if used < 0.8 then `NAME "pink"
+ else if used < 0.9 then `NAME "hot pink"
+ else `NAME "red" in
+ ds.draw#set_foreground col;
+ let w = int_of_float (used *. (float width -. 16.)) in
+ ds.draw#rectangle ~x:8 ~y:yb ~width:w ~height:(yt-yb) ~filled:true ();
+
+ ds.draw#set_foreground `BLACK;
+ ds.draw#rectangle ~x:8 ~y:yb ~width:(width-16) ~height:(yt-yb) ();
+
+ (* Large text - the device name. *)
+ let txt = ds.pango_large_context#create_layout in
+ Pango.Layout.set_text txt part.Slave.pt_name;
+ let fore = `NAME "dark slate grey" in
+ ds.draw#put_layout ~x:12 ~y:(yb+4) ~fore txt;
+
+ let { Pango.height = txtheight; Pango.width = txtwidth } =
+ Pango.Layout.get_pixel_extent txt in
+
+ (* Small text below - the content. *)
+ let txt = ds.pango_small_context#create_layout in
+ Pango.Layout.set_text txt part.Slave.pt_content;
+ let fore = `BLACK in
+ ds.draw#put_layout ~x:12 ~y:(yb+4+txtheight) ~fore txt;
+
+ (* Small text right - size. *)
+ let size =
+ match part.Slave.pt_statvfs with
+ | None -> printable_size part.Slave.pt_size
+ | Some { G.blocks = blocks; bsize = bsize } ->
+ let bytes = Int64.mul blocks bsize in
+ let pc = 100. *. used in
+ sprintf "%s (%.1f%% used)" (printable_size bytes) pc in
+ let txt = ds.pango_small_context#create_layout in
+ Pango.Layout.set_text txt size;
+ ds.draw#put_layout ~x:(16+txtwidth) ~y:(yb+4) ~fore txt;
+
+ (y +. h)
) 0. parts
)
let anon_fun _ =
failwith (sprintf "%s: unknown command line argument"
- (Filename.basename Sys.executable_name))
+ (Filename.basename Sys.executable_name))
let usage_msg =
sprintf "\
let l = make ?ns () in
let rec aux = function
| Element (tag, attrs, child) ->
- start_elem l tag attrs; List.iter aux child; end_elem l ()
+ start_elem l tag attrs; List.iter aux child; end_elem l ()
| PCData s ->
- text l s in
+ text l s in
aux xml;
get l
my $r;
my $line;
while (($r = read (F, $line, 1024)) > 0) {
- $line =~ tr{\0}{\n};
- print $line;
+ $line =~ tr{\0}{\n};
+ print $line;
}
close F;
}
git.annexia.org / libguestfs.git / commitdiff