-(* Set the statusbar text. *)
-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 } ->
- 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)
-
-(* 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. *)
-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)
-
-(* Called back when disk image(s) were opened successfully. *)
-and when_opened_disk_images ws images data =
- match images with
- | [] -> ()
- | (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;
- List.iter (
- fun { Slave.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;
-
- Filetree.add ws.view name data
-
-let throbber_busy ws () =
- (*throbber#set_pixbuf animation*)
- (* XXX Workaround because no binding for GdkPixbufAnimation: *)
- let file = Filename.dirname Sys.argv.(0) // "Throbber.gif" in
- ws.throbber#set_file file
-
-let throbber_idle ws () =
- ws.throbber#set_pixbuf ws.throbber_static
-
-let progress ws (position, total) =
- ws.progress_bar#set_fraction
- (Int64.to_float position /. Int64.to_float total)
-
-(* 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.
- *)
-let failure ws exn =
- let title = "Error" in
- let msg = Printexc.to_string exn in
- debug "failure hook: %s" msg;
- let icon = GMisc.image () in
- icon#set_stock `DIALOG_ERROR;
- icon#set_icon_size `DIALOG;
- GToolbox.message_box ~title ~icon msg
-
-let rec open_main_window () =
- (* I prototyped the basic window layout using Glade, but have
- * implemented it by hand to give us more flexibility.
- *)