- 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 () ->
- match combo#active_iter with
- | None -> ()
- | Some row ->
- let name = model#get ~row ~column in
- ds.set_statusbar (sprintf "Opening %s ..." name);
- ds.clear_notebook ();
- Slave.open_domain name (opened_domain ds))
- );
-
- ignore (connect_item#connect#activate ~callback:(connect_dialog ds));
- ignore (open_item#connect#activate ~callback:(open_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
-
-(* 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
-
-(* 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
-
-(* 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.clear_statusbar ();
- 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 =
- 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)
- in
-
- let stats = GPack.table ~columns:4 ~rows:5
- ~homogeneous:true ~col_spacings:4 ~row_spacings:4
- ~packing:vbox#pack () in
- stats#attach ~top:0 ~left:0 (mklabelh "1K-blocks");
- stats#attach ~top:0 ~left:1 (mklabelh "Used");
- stats#attach ~top:0 ~left:2 (mklabelh "Available");
- stats#attach ~top:0 ~left:3 (mklabelh "Use%");
- let blocks = st.G.blocks *^ factor in
- stats#attach ~top:1 ~left:0 (mklabelr (sprintf "%Ld" blocks));
- let used = (st.G.blocks -^ st.G.bfree) *^ factor in
- stats#attach ~top:1 ~left:1 (mklabelr (sprintf "%Ld" used));
- let available = st.G.bavail *^ factor in
- stats#attach ~top:1 ~left:2 (mklabelr (sprintf "%Ld" available));
- stats#attach ~top:1 ~left:3
- (mklabelr (sprintf "%Ld%%" (100L -^ 100L *^ st.G.bfree /^ st.G.blocks)));
- stats#attach ~top:2 ~left:0 (mklabelr ("= " ^ human_size_1k blocks));
- stats#attach ~top:2 ~left:1 (mklabelr ("= " ^ human_size_1k used));
- stats#attach ~top:2 ~left:2 (mklabelr ("= " ^ human_size_1k available));
- stats#attach ~top:3 ~left:0 (mklabelh "Inodes");
- stats#attach ~top:3 ~left:1 (mklabelh "IUsed");
- stats#attach ~top:3 ~left:2 (mklabelh "IFree");
- stats#attach ~top:3 ~left:3 (mklabelh "IUse%");
- stats#attach ~top:4 ~left:0 (mklabelr (sprintf "%Ld" st.G.files));
- stats#attach ~top:4 ~left:1
- (mklabelr (sprintf "%Ld" (st.G.files -^ st.G.ffree)));
- stats#attach ~top:4 ~left:2 (mklabelr (sprintf "%Ld" st.G.ffree));
- stats#attach ~top:4 ~left:3
- (mklabelr (sprintf "%Ld%%" (100L -^ 100L *^ st.G.ffree /^ st.G.files)));
-
- (* Info table. *)
-
- (* Left- and right-aligned labels, for info table. *)
- let mklabelr text =
- let label = GMisc.label ~text ~xalign:1. () in
- label#set_width_chars 9;
- (label :> GObj.widget)
- and mklabell text =
- let label = GMisc.label ~text ~selectable:true ~xalign:0. () in
- (label :> GObj.widget)
- in
-
- let info = GPack.table ~columns:4 ~rows:2
- ~col_spacings:4 ~row_spacings:4
- ~packing:vbox#pack () in
- info#attach ~top:0 ~left:0 (mklabelr "FS label:");
- info#attach ~top:0 ~left:1 (mklabell vol.Slave.vol_label);
- info#attach ~top:1 ~left:0 (mklabelr "FS type:");
- info#attach ~top:1 ~left:1 (mklabell vol.Slave.vol_type);
- info#attach ~top:0 ~left:2 (mklabelr "FS UUID:");
- info#attach ~top:0 ~left:3 (mklabell vol.Slave.vol_uuid);
- info#attach ~top:1 ~left:2 (mklabelr "Device:");
- info#attach ~top:1 ~left:3 (mklabell dev);
-
- (* Files display. *)
- let sw = GBin.scrolled_window
- ~packing:(vbox#pack ~expand:true ~fill:true)
- ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC () in
- let view = Filetree.filetree dev rw in
- sw#add (view :> GObj.widget);
-
- vbox in
- ignore (
- ds.notebook#append_page ~tab_label:(mklabel tab) (page :> GObj.widget)
- )
-
-(* Open the connect to libvirt dialog. *)
-and connect_dialog ds () =
- debug "connect menu";
- (*ds.clear_notebook ();*)
- failwith "XXX CONNECT DLG NOT IMPL"
-
-(* Open the disk images dialog. *)
-and open_dialog ds () =
- debug "open menu";
- (*ds.clear_notebook ();*)
- failwith "XXX OPEN DLG NOT IMPL"