From de64183f3d0d04127c2e7690c87435e6649d30a6 Mon Sep 17 00:00:00 2001 From: Richard Jones Date: Tue, 20 Oct 2009 15:03:16 +0100 Subject: [PATCH] Tab to space fixes, now passes 'make syntax-check' --- HACKING | 8 +- daemon/find.c | 9 +- inspector/inspector_generator.ml | 286 ++++++++++++++--------------- inspector/virt-inspector | 34 ++-- inspector/virt-inspector.rng | 170 +++++++++--------- ocaml/examples/viewer.ml | 368 +++++++++++++++++++------------------- ocaml/examples/xmllight_loader.ml | 4 +- tools/virt-ls | 4 +- 8 files changed, 441 insertions(+), 442 deletions(-) diff --git a/HACKING b/HACKING index ca5b9a9..d4e030c 100644 --- a/HACKING +++ b/HACKING @@ -120,10 +120,10 @@ ruby/ 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. diff --git a/daemon/find.c b/daemon/find.c index c5d26d7..98895ab 100644 --- a/daemon/find.c +++ b/daemon/find.c @@ -128,7 +128,7 @@ do_find (const char *dir) 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 @@ -212,20 +212,19 @@ do_find0 (const char *dir) 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; } - diff --git a/inspector/inspector_generator.ml b/inspector/inspector_generator.ml index a1d1aa5..20d2b01 100644 --- a/inspector/inspector_generator.ml +++ b/inspector/inspector_generator.ml @@ -59,15 +59,15 @@ let input = "inspector/virt-inspector.rng" * 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 (* *) + | 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) -> @@ -101,31 +101,31 @@ let rec parse_rng ?defines context = function (match rng with | [child] -> ZeroOrMore child :: parse_rng ?defines context rest | _ -> - failwithf "%s: contains more than one child element" - context + 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 + 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 + 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 + 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 @@ -140,10 +140,10 @@ let rec parse_rng ?defines context = function *) (match defines with | None -> - failwithf "%s: contains , but no refs are defined yet" context + 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 + 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) @@ -152,16 +152,16 @@ let grammar = let xml = Xml.parse_file input in match xml with | Xml.Element ("grammar", _, - Xml.Element ("start", _, gram) :: defines) -> + 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 + 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 @@ -258,37 +258,37 @@ let generate_types xs = * 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 *) + | 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 + "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 *) + 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 @@ -300,7 +300,7 @@ let generate_types xs = | [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 = @@ -317,25 +317,25 @@ let 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 @@ -347,45 +347,45 @@ let generate_parsers 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 -> (* 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 *) + | 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 + 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 + 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 @@ -397,8 +397,8 @@ let generate_parsers xs = | [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 = @@ -424,48 +424,48 @@ let 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 @@ -612,7 +612,7 @@ let output_to filename = (* 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 _ -> ()); diff --git a/inspector/virt-inspector b/inspector/virt-inspector index 13673af..071f0b0 100755 --- a/inspector/virt-inspector +++ b/inspector/virt-inspector @@ -550,23 +550,23 @@ sub output_xml_os } 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}) { diff --git a/inspector/virt-inspector.rng b/inspector/virt-inspector.rng index 1da58fc..c8f6075 100644 --- a/inspector/virt-inspector.rng +++ b/inspector/virt-inspector.rng @@ -20,36 +20,36 @@ - - - - - - - linux - windows - - - - - - - - - - - - - - - - - - - - - - + + + + + + + linux + windows + + + + + + + + + + + + + + + + + + + + + + @@ -58,10 +58,10 @@ - - - - + + + + @@ -70,16 +70,16 @@ - - - - - - - - - - + + + + + + + + + + @@ -88,10 +88,10 @@ - - - - + + + + @@ -100,14 +100,14 @@ - - - - - - - - + + + + + + + + @@ -116,12 +116,12 @@ - - - - - - + + + + + + @@ -130,16 +130,16 @@ - - - 1 - - - - - - - + + + 1 + + + + + + + @@ -148,19 +148,19 @@ - - - - - - - - - - - - - + + + + + + + + + + + + + diff --git a/ocaml/examples/viewer.ml b/ocaml/examples/viewer.ml index eeff525..6cd465a 100644 --- a/ocaml/examples/viewer.ml +++ b/ocaml/examples/viewer.ml @@ -63,7 +63,7 @@ module G = Guestfs 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 @@ -78,9 +78,9 @@ module Slave : sig 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 *) } @@ -89,33 +89,33 @@ module Slave : sig 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. *) @@ -168,7 +168,7 @@ end = struct | 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 () @@ -177,8 +177,8 @@ end = struct 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 () = @@ -198,9 +198,9 @@ end = struct * 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 @@ -208,11 +208,11 @@ end = struct 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 @@ -223,9 +223,9 @@ end = struct 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; @@ -238,69 +238,69 @@ end = struct 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 () = @@ -323,7 +323,7 @@ end = struct let xs = {{ [xml] }} in let xs = {{ (((xs.(_)) / .(_)) / .(_)) / }} in let xs = {{ map xs with - | _ + | _ | _ -> [s] | _ -> [] }} in {: xs :} @@ -384,7 +384,7 @@ let main_window opened_domain repaint = 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 @@ -397,8 +397,8 @@ let main_window opened_domain repaint = 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 @@ -409,9 +409,9 @@ let main_window opened_domain repaint = 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 @@ -460,13 +460,13 @@ let main_window opened_domain repaint = 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)); @@ -523,8 +523,8 @@ and real_repaint ds parts = 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 (* @@ -532,7 +532,7 @@ and real_repaint ds parts = 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 ); *) @@ -544,34 +544,34 @@ and real_repaint ds 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 @@ -580,7 +580,7 @@ and real_repaint ds parts = 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 ); *) @@ -589,12 +589,12 @@ and real_repaint ds 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 @@ -602,54 +602,54 @@ and real_repaint ds parts = 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 ) @@ -671,7 +671,7 @@ let argspec = Arg.align [ let anon_fun _ = failwith (sprintf "%s: unknown command line argument" - (Filename.basename Sys.executable_name)) + (Filename.basename Sys.executable_name)) let usage_msg = sprintf "\ diff --git a/ocaml/examples/xmllight_loader.ml b/ocaml/examples/xmllight_loader.ml index 46dd77f..6f0c536 100644 --- a/ocaml/examples/xmllight_loader.ml +++ b/ocaml/examples/xmllight_loader.ml @@ -6,9 +6,9 @@ let from_xml ?ns xml = 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 diff --git a/tools/virt-ls b/tools/virt-ls index a55f6c3..6ab6021 100755 --- a/tools/virt-ls +++ b/tools/virt-ls @@ -202,8 +202,8 @@ unless ($mode) { 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; } -- 1.8.3.1