(* Guestfs Browser.
- * Copyright (C) 2010-2011 Red Hat Inc.
+ * Copyright (C) 2010-2015 Red Hat Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
| Download_dir_tarball of source * string * download_dir_tarball_format * string * unit callback
| Download_file of source * string * string * bool * unit callback
| File_information of source * string * string callback
+ | File_xattrs of source * string * G.xattr array callback
| List_applications of inspection_os * G.application array callback
| Open_domain of string * inspection_data callback
| Open_images of (string * string option) list * inspection_data callback
| Read_directory of source * string * direntry list callback
+ | Reopen of inspection_data callback
| Run_command of string * unit callback
let rec string_of_command = function
(string_of_source src) remotefile localfile check
| File_information (src, pathname, _) ->
sprintf "File_information (%s, %s)" (string_of_source src) pathname
+ | File_xattrs (src, pathname, _) ->
+ sprintf "File_xattrs (%s, %s)" (string_of_source src) pathname
| List_applications (os, _) ->
sprintf "List_applications %s" os.insp_root
| Open_domain (name, _) -> sprintf "Open_domain %s" name
sprintf "Open_images %s" (string_of_images images)
| Read_directory (src, dir, _) ->
sprintf "Read_directory (%s, %s)" (string_of_source src) dir
+ | Reopen _ ->
+ "Reopen"
| Run_command (cmd, _) ->
sprintf "Run_command %s" cmd
send_to_slave ?fail (Download_file (src, remotefile, localfile, true, cb))
let file_information ?fail src pathname cb =
send_to_slave ?fail (File_information (src, pathname, cb))
+let file_xattrs ?fail src pathname cb =
+ send_to_slave ?fail (File_xattrs (src, pathname, cb))
let list_applications ?fail os cb =
send_to_slave ?fail (List_applications (os, cb))
let open_domain ?fail name cb = send_to_slave ?fail (Open_domain (name, cb))
let open_images ?fail images cb = send_to_slave ?fail (Open_images (images, cb))
let read_directory ?fail src path cb =
send_to_slave ?fail (Read_directory (src, path, cb))
+let reopen ?fail cb =
+ send_to_slave ?fail (Reopen cb)
let run_command ?fail cmd cb =
send_to_slave ?fail (Run_command (cmd, cb))
let conn = ref None
let g = ref None
+(* Last Open_domain or Open_images command. This is so we can implement
+ * the Reopen command.
+ *)
+let last_open = ref None
+
(* Run the callback unless someone set the q_discard flag while
* we were running the command.
*)
let g = get_g () in
let f = match format with
- | Tar -> g#tar_out
+ | Tar -> fun a b -> g#tar_out a b
| TGZ -> g#tgz_out
| TXZ -> g#txz_out
in
status "Finished calculating file information for %s" pathname;
callback_if_not_discarded cb r
+ | File_xattrs (src, pathname, cb) ->
+ status "Getting file xattrs for %s ..." pathname;
+
+ let g = get_g () in
+ let r =
+ with_mount_ro g src (
+ fun () ->
+ g#getxattrs pathname
+ ) in
+
+ status "Finished calculating file information for %s" pathname;
+ callback_if_not_discarded cb r
+
| List_applications (os, cb) ->
status "Listing applications ...";
status "Finished listing applications";
callback_if_not_discarded cb r
- | Open_domain (name, cb) ->
+ | Open_domain (name, cb) as cmd ->
status "Opening %s ..." name;
let conn = get_conn () in
let dom = D.lookup_by_name conn name in
let xml = D.get_xml_desc dom in
let images = get_disk_images_from_xml xml in
- open_disk_images images cb
+ open_disk_images images cb cmd
- | Open_images (images, cb) ->
+ | Open_images (images, cb) as cmd ->
status "Opening disk images ...";
- open_disk_images images cb
+ open_disk_images images cb cmd
| Read_directory (src, dir, cb) ->
status "Reading directory %s ..." dir;
status "Finished reading directory %s" dir;
callback_if_not_discarded cb entries
+ | Reopen cb ->
+ (* Execute the last_open command, if there was one. But note
+ * that we have to replace the callback in the saved command with
+ * the new callback passed by the main thread to reopen.
+ *)
+ (match !last_open with
+ | Some (Open_domain (name, _)) ->
+ execute_command (Open_domain (name, cb))
+ | Some (Open_images (images, _)) ->
+ execute_command (Open_images (images, cb))
+ | None ->
+ () (* invalid_arg? *)
+ | _ ->
+ assert false (* should never happen *)
+ )
+
| Run_command (cmd, cb) ->
status "Running %s ..." cmd;
and close_all () =
(match !conn with Some conn -> C.close conn | None -> ());
conn := None;
+ last_open := None;
close_g ()
and close_g () =
(* 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 images cb =
+and open_disk_images images cb cmd =
debug "opening disk image %s" (string_of_images images);
close_g ();
(* Attach progress bar callback. *)
ignore (
g#set_event_callback (
- fun g event handle buf array ->
+ fun event handle buf array ->
if event == G.EVENT_PROGRESS && Array.length array >= 4 then (
let proc_nr = array.(0)
and serial = array.(1)
} in
status "Finished opening disk";
+
+ (* Save the command, in case user does Reopen. *)
+ last_open := Some cmd;
+
callback_if_not_discarded cb data
(* Start up one slave thread. *)
git.annexia.org / guestfs-browser.git / blobdiff