- let ds = {
- window = window;
- throbber_busy = throbber_busy; throbber_idle = throbber_idle;
- set_statusbar = set_statusbar; clear_statusbar = clear_statusbar;
- set_vmlist = set_vmlist; clear_vmlist = clear_vmlist;
- clear_notebook = clear_notebook;
- filesystem = filesystem; notebook = nb;
- } in
-
- (* Set up some callbacks which require access to the display_state. *)
- ignore (
- let combo, (model, column) = vmcombo in
- combo#connect#changed
- ~callback:(
- fun () ->
- Option.may (fun row -> open_domain ds (model#get ~row ~column))
- combo#active_iter
- )
- );
-
- ignore (connect_kvm_item#connect#activate
- ~callback:(fun () -> connect ds (Some "qemu:///system")));
- ignore (connect_xen_item#connect#activate
- ~callback:(fun () -> connect ds (Some "xen:///")));
- ignore (connect_none_item#connect#activate
- ~callback:(fun () -> connect ds None));
- ignore (connect_uri_item#connect#activate ~callback:(connect_uri_dialog ds));
- ignore (open_image_item#connect#activate ~callback:(open_image_dialog ds));
-
- (* Return the display state. *)
- ds
-
-(* Convenience function to make a label containing some text. It is
- * returned as a generic widget.
- *)
-and mklabel text =
- (GMisc.label ~text () :> GObj.widget)
-
-(* 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
- * necessary to turn the exception into an error message.
- *)
-and failure ds exn =
- let title = "Error" in
- let msg = Printexc.to_string exn in
- debug "thread id %d: failure hook: %s" (Thread.id (Thread.self ())) msg;
- let icon = GMisc.image () in
- icon#set_stock `DIALOG_ERROR;
- icon#set_icon_size `DIALOG;
- GToolbox.message_box ~title ~icon msg
-
-(* Perform action to open the named libvirt URI. *)
-and connect ds uri =
- (match uri with
- | None -> ds.set_statusbar "Connecting to default libvirt ...";
- | Some uri -> ds.set_statusbar (sprintf "Connecting to %s ..." uri));
- ds.clear_notebook ();
- Slave.discard_command_queue ();
- Slave.connect uri (connected ds uri)
-
-(* This is called in the main thread when we've connected to libvirt. *)
-and connected ds uri () =
- debug "thread id %d: connected callback" (Thread.id (Thread.self ()));
- let msg =
- match uri with
- | None -> "Connected to libvirt"
- | Some uri -> sprintf "Connected to %s" uri in
- ds.set_statusbar msg;
- Slave.get_domains (got_domains ds)
-
-(* This is called in the main thread when we've got the list of domains. *)
-and got_domains ds doms =
- let doms = List.map (fun { Slave.dom_name = name } -> name) doms in
- debug "thread id %d: got_domains callback: (%s)"
- (Thread.id (Thread.self ())) (String.concat " " doms);
- ds.set_vmlist doms
-
-(* Perform action to open the named domain. *)
-and open_domain ds name =
- ds.set_statusbar (sprintf "Opening %s ..." name);
- ds.clear_notebook ();
- Slave.discard_command_queue ();
- Slave.open_domain name (opened_domain ds)
-
-(* This callback indicates that the domain was opened successfully. *)
-and opened_domain ds rw =
- debug "thread id %d: opened_domain callback" (Thread.id (Thread.self ()));
- _opened ds rw
-
-(* Perform action of opening disk image(s). *)
-and open_images ds images =
- ds.set_statusbar (sprintf "Opening disk image %s ..."
- (String.concat " " images));
- ds.clear_notebook ();
- Slave.discard_command_queue ();
- Slave.open_images images (opened_images ds)
-
-(* This callback indicates that local disk image(s) were opened successfully.*)
-and opened_images ds rw =
- debug "thread id %d: opened_images callback" (Thread.id (Thread.self ()));
- _opened ds rw
-
-and _opened ds rw =
- ds.set_statusbar ("Opening filesystems ...");
- ds.clear_notebook ();
-
- (* Get the list of mountable filesystems. *)
- Slave.get_volumes (got_volume ds rw)
-
-(* This callback is called once for each mountable filesystem that is
- * found in a guest.
- *)
-and got_volume ds rw vol =
- ds.clear_statusbar ();
-
- let dev = vol.Slave.vol_device in
- debug "thread id %d: got_volume callback: %s"
- (Thread.id (Thread.self ())) dev;
-
- (* What's on the tab. *)
- let tab =
- match vol.Slave.vol_label with
- | "" -> sprintf "%s" dev
- | label -> sprintf "%s (%s)" dev label in
-
- (* What's on the notebook page. *)
- let page =
- let vbox = GPack.vbox () in
-
- (* VFS stats table. *)
-
- (* For calculations, see libguestfs/tools/virt-df. *)
- let st = vol.Slave.vol_statvfs in
- let factor = st.G.bsize /^ 1024L in
-
- (* Right-aligned label with width, for stats table. *)
- let mklabelh text =
- let markup = "<b>" ^ text ^ "</b>" in
- let label = GMisc.label ~markup ~xalign:1. () in
- label#set_width_chars 12;
- (label :> GObj.widget)
- and mklabelr text =
- let label = GMisc.label ~text ~selectable:true ~xalign:1. () in
- label#set_width_chars 12;
- (label :> GObj.widget)
+ method failure exn =
+ let raw_msg = Printexc.to_string exn in
+ debug "failure hook: %s" raw_msg;
+
+ let title, msg = pretty_string_of_exn exn in
+ let icon = GMisc.image () in
+ icon#set_stock `DIALOG_ERROR;
+ icon#set_icon_size `DIALOG;
+ GToolbox.message_box ~title ~icon msg
+
+ (* Do what the user asked on the command line. *)
+ method run_cli_request = function
+ | Cmdline.Empty_window -> ()
+ | Cmdline.Open_images images ->
+ self#open_disk_images images
+ | Cmdline.Open_guest guest ->
+ (* Open libvirt connection, and in the callback open the guest. *)
+ let uri = connect_uri () in
+ Slave.connect uri (self#when_connected_cli_request guest)
+
+ method private when_connected_cli_request guest doms =
+ self#populate_vmcombo 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