X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=window.ml;h=6e720b7b4b4e4ffcf98d73c317bec4c4f3a78794;hb=d6c7f8f297744436497640e1230d98d4a96229f1;hp=b15c690886efc9e07be54567d23185a1661cf702;hpb=bea873ce68b3e788c2926735fe3d513cbea24f06;p=guestfs-browser.git diff --git a/window.ml b/window.ml index b15c690..6e720b7 100644 --- a/window.ml +++ b/window.ml @@ -19,6 +19,7 @@ open Printf open Utils +open Slave_types module G = Guestfs @@ -27,6 +28,7 @@ type window_state = { window : GWindow.window; view : Filetree.t; vmcombo : GEdit.combo_box GEdit.text_combo; + refresh_button : GButton.button; throbber : GMisc.image; throbber_static : GdkPixbuf.pixbuf; statusbar : GMisc.statusbar; @@ -39,40 +41,32 @@ let set_statusbar ws msg = ws.statusbar_context#pop (); ignore (ws.statusbar_context#push msg) -let clear_statusbar ws = set_statusbar ws "" - (* Clear the filetree. *) let clear_view ws = Filetree.clear ws.view (* Callback from Connect -> ... menu items. *) let rec connect_to ws uri = - (match uri with - | None -> set_statusbar ws "Connecting to default libvirt ..." - | Some uri -> set_statusbar ws (sprintf "Connecting to %s ..." uri) - ); clear_view ws; Slave.discard_command_queue (); Slave.connect uri (when_connected ws uri) (* Called back when connected to a new hypervisor. *) and when_connected ws uri doms = - (match uri with - | None -> set_statusbar ws "Connected to default libvirt" - | Some uri -> set_statusbar ws (sprintf "Connected to %s" uri) - ); + populate_vmcombo ws doms + +and populate_vmcombo ws doms = (* Populate the VM combo box. *) let combo, (model, column) = ws.vmcombo in model#clear (); List.iter ( - fun { Slave.dom_name = name } -> + fun { dom_name = name } -> let row = model#append () in model#set ~row ~column name ) doms (* When a new domain is selected by the user, eg through vmcombo. *) let rec open_domain ws name = - set_statusbar ws (sprintf "Opening %s ..." name); clear_view ws; Slave.discard_command_queue (); Slave.open_domain name (when_opened_domain ws name) @@ -80,7 +74,6 @@ let rec open_domain ws name = (* Called back when domain was opened successfully. *) and when_opened_domain ws name data = debug "when_opened_domain callback"; - set_statusbar ws (sprintf "Opened %s" name); when_opened_common ws name data (* When a set of disk images is selected by the user. *) @@ -88,7 +81,6 @@ and open_disk_images ws images = match images with | [] -> () | images -> - set_statusbar ws "Opening disks ..."; clear_view ws; Slave.discard_command_queue (); Slave.open_images images (when_opened_disk_images ws images) @@ -99,19 +91,18 @@ and when_opened_disk_images ws images data = | [] -> () | (image, _) :: _ -> debug "when_opened_disk_images callback"; - set_statusbar ws "Opened disk"; when_opened_common ws image data (* Common code for when_opened_domain/when_opened_disk_images. *) and when_opened_common ws name data = (* Dump some of the inspection data in debug messages. *) List.iter (fun (dev, t) -> debug "filesystem: %s: %s" dev t) - data.Slave.insp_all_filesystems; + data.insp_all_filesystems; List.iter ( - fun { Slave.insp_root = root; insp_type = typ; insp_distro = distro; + fun { insp_root = root; insp_type = typ; insp_distro = distro; insp_major_version = major; insp_minor_version = minor } -> debug "root device %s contains %s %s %d.%d" root typ distro major minor; - ) data.Slave.insp_oses; + ) data.insp_oses; Filetree.add ws.view name data @@ -124,6 +115,18 @@ let throbber_busy ws () = let throbber_idle ws () = ws.throbber#set_pixbuf ws.throbber_static +let progress ws (position, total) = + if position = 0L && total = 1L then + ws.progress_bar#pulse () + else ( + let frac = Int64.to_float position /. Int64.to_float total in + if frac < 0. || frac > 1. then + eprintf "warning: progress bar out of range: %Ld / %Ld (%g)\n" + position total frac; + let frac = if frac < 0. then 0. else if frac > 1. then 1. else frac in + ws.progress_bar#set_fraction frac + ) + (* This is called in the main thread whenever a command fails in the * slave thread. The command queue has been cleared before this is * called, so our job here is to reset the main window, and if @@ -151,14 +154,14 @@ let rec open_main_window () = make_menubar window vbox ~packing:vbox#pack () in (* Top toolbar. *) - let vmcombo, throbber, throbber_static = + let vmcombo, refresh_button, throbber, throbber_static = make_toolbar ~packing:vbox#pack () in (* Main part of display is the file tree. *) let view = make_filetree ~packing:(vbox#pack ~expand:true ~fill:true) () in (* Status bar and progress bar. *) - let hbox = GPack.hbox ~packing:vbox#pack () in + let hbox = GPack.hbox ~spacing:4 ~packing:vbox#pack () in let progress_bar = GRange.progress_bar ~packing:hbox#pack () in let statusbar = GMisc.statusbar ~packing:(hbox#pack ~expand:true) () in let statusbar_context = statusbar#new_context ~name:"Standard" in @@ -171,6 +174,7 @@ let rec open_main_window () = window = window; view = view; vmcombo = vmcombo; + refresh_button = refresh_button; throbber = throbber; throbber_static = throbber_static; statusbar = statusbar; statusbar_context = statusbar_context; progress_bar = progress_bar @@ -188,7 +192,9 @@ let rec open_main_window () = ignore (connect_none_item#connect#activate ~callback:(fun () -> connect_to ws None)); - (* VM combo box when changed by the user. *) + (* VM combo box when changed by the user. + * The refresh button acts like changing the VM combo too. + *) let combo, (model, column) = ws.vmcombo in ignore ( combo#connect#changed @@ -199,7 +205,17 @@ let rec open_main_window () = | Some row -> open_domain ws (model#get ~row ~column) ) ); + ignore ( + refresh_button#connect#clicked + ~callback:( + fun () -> + match combo#active_iter with + | None -> () (* nothing selected *) + | Some row -> open_domain ws (model#get ~row ~column) + ) + ); + (* Return the window_state struct. *) ws and make_menubar window vbox ~packing () = @@ -241,15 +257,52 @@ and make_toolbar ~packing () = hbox#pack (mklabel "Guest: "); let vmcombo = GEdit.combo_box_text ~packing:hbox#pack () in + (* Refresh button. + * http://stackoverflow.com/questions/2188659/stock-icons-not-shown-on-buttons + *) + let refresh_button = + let image = GMisc.image ~stock:`REFRESH () in + let b = GButton.button ~packing:hbox#pack () in + b#set_image (image :> GObj.widget); + b in + (* Throbber. *) let static = Throbber.static () in (*let animation = Throbber.animation () in*) let throbber = - GMisc.image ~pixbuf:static ~packing:(hbox#pack ~from:`END) () in + (* Workaround for http://caml.inria.fr/mantis/view.php?id=4732 *) + let from = Obj.magic 3448763 (* `END *) in + GMisc.image ~pixbuf:static ~packing:(hbox#pack ~from) () in - vmcombo, throbber, static + vmcombo, refresh_button, throbber, static and make_filetree ~packing () = let sw = GBin.scrolled_window ~packing ~hpolicy:`AUTOMATIC ~vpolicy:`ALWAYS () in Filetree.create ~packing:sw#add () + +(* Do what the user asked on the command line. *) +let rec run_cli_request ws = function + | Cmdline.Empty_window -> () + | Cmdline.Open_images images -> + open_disk_images ws images + | Cmdline.Open_guest guest -> + (* Open libvirt connection, and in the callback open the guest. *) + let uri = connect_uri () in + Slave.connect uri (when_connected_cli_request ws guest) +and when_connected_cli_request ws guest doms = + populate_vmcombo ws doms; + + (* "guest" should match a domain in "doms". Check this and + * get the index of it. + *) + let rec loop i = function + | [] -> + failwith "guest %s not found (do you need to use --connect?)" guest + | d::ds when d = guest -> i + | _::ds -> loop (i+1) ds + in + let i = loop 0 (List.map (fun { dom_name = name } -> name) doms) in + + let combo, _ = ws.vmcombo in + combo#set_active i