+ conn := None;
+ close_g ()
+
+and close_g () =
+ (match !g with Some g -> G.close g | None -> ());
+ g := None
+
+and get_disk_images_from_xml xml =
+ let xml = Xml.parse_string xml in
+ let devices =
+ match xml with
+ | Xml.Element ("domain", _, children) ->
+ let devices =
+ List.filter_map (
+ function
+ | Xml.Element ("devices", _, devices) -> Some devices
+ | _ -> None
+ ) children in
+ List.concat devices
+ | _ ->
+ failwith "get_xml_desc didn't return <domain/>" in
+ let rec source_of = function (* <source file|dev=...> *)
+ | [] -> None
+ | Xml.Element ("source", attrs, _) :: rest ->
+ (try Some (List.assoc "dev" attrs)
+ with Not_found ->
+ try Some (List.assoc "file" attrs)
+ with Not_found ->
+ source_of rest)
+ | _ :: rest -> source_of rest
+ in
+ let blkdevs =
+ List.filter_map (
+ function
+ | Xml.Element ("disk", _, children) -> source_of children
+ | _ -> None
+ ) devices in
+ blkdevs
+
+(* The common code for Open_domain and Open_images which opens the
+ * libguestfs handle, adds the disks, and launches the appliance.
+ *)
+and open_disk_images rw images cb =
+ debug "opening disk image [%s] in %s mode"
+ (String.concat "; " images) (string_of_rw_flag rw);
+
+ close_g ();
+ let g' = G.create () in
+ g := Some g';
+ let g = g' in
+
+ G.set_verbose g (verbose ());
+
+ let add = (match rw with RO -> G.add_drive_ro | RW -> G.add_drive) g in
+ List.iter add images;
+
+ G.launch g;
+ GtkThread.async cb rw
+
+(* This is the common function implementing Get_volumes. Test if a
+ * particular partition contains a mountable filesystem. We do this
+ * simply by trying to mount it. If it does, get the rest of the
+ * information for the volume, and call the callback.
+ *)
+and if_mountable_vol g cb dev =
+ try
+ with_mount_ro g dev (
+ fun () ->
+ let vol_type = G.vfs_type g dev in
+ let vol_label = G.vfs_label g dev in
+ let vol_uuid = G.vfs_uuid g dev in
+ let vol_statvfs = G.statvfs g "/" in
+ let vol = {
+ vol_device = dev; vol_type = vol_type; vol_label = vol_label;
+ vol_uuid = vol_uuid; vol_statvfs = vol_statvfs
+ } in
+ GtkThread.async cb vol
+ )
+ with G.Error msg ->
+ debug "is_mountable: %s: not mountable because: %s" dev msg
+
+(* guestfs_lstatlist has a "hidden" limit of the protocol message size.
+ * Call this function, but split the list of names into chunks.
+ *)
+and lstatlist_wrapper g dir = function
+ | [] -> []
+ | names ->
+ let names', names = List.take 1000 names, List.drop 1000 names in
+ let xs = G.lstatlist g dir (Array.of_list names') in
+ let xs = Array.to_list xs in
+ xs @ lstatlist_wrapper g dir names
+
+(* Same as above for guestfs_readlinklist. *)
+and readlinklist_wrapper g dir = function
+ | [] -> []
+ | names ->
+ let names', names = List.take 1000 names, List.drop 1000 names in
+ let xs = G.readlinklist g dir (Array.of_list names') in
+ let xs = Array.to_list xs in
+ xs @ readlinklist_wrapper g dir names