X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=window.ml;h=6ede415e361fa64a22660a38c559e4972cb44c97;hb=1d7c4274827064c684d831c9ef51b198ba8798a2;hp=6e720b7b4b4e4ffcf98d73c317bec4c4f3a78794;hpb=de4375caa0eeb27e8f8e341747e2f99359df745b;p=guestfs-browser.git

diff --git a/window.ml b/window.ml
index 6e720b7..6ede415 100644
--- a/window.ml
+++ b/window.ml
@@ -23,202 +23,7 @@ open Slave_types
 
 module G = Guestfs
 
-(* Main window state. *)
-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;
-  statusbar_context : GMisc.statusbar_context;
-  progress_bar : GRange.progress_bar;
-}
-
-(* Set the statusbar text. *)
-let set_statusbar ws msg =
-  ws.statusbar_context#pop ();
-  ignore (ws.statusbar_context#push msg)
-
-(* Clear the filetree. *)
-let clear_view ws =
-  Filetree.clear ws.view
-
-(* Callback from Connect -> ... menu items. *)
-let rec connect_to ws 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 =
-  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 { 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 =
-  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";
-  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 ->
-      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";
-      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.insp_all_filesystems;
-  List.iter (
-    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.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) =
-  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
- * 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.
-   *)
-  let title = "Guest Filesystem Browser" in
-  let window = GWindow.window ~width:700 ~height:700 ~title () in
-  let vbox = GPack.vbox ~packing:window#add () in
-
-  (* Menus. *)
-  let connect_kvm_item, connect_xen_item, connect_none_item, _, _ =
-    make_menubar window vbox ~packing:vbox#pack () in
-
-  (* Top toolbar. *)
-  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 ~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
-  ignore (statusbar_context#push title);
-
-  window#show ();
-
-  (* Construct the window_state struct. *)
-  let ws = {
-    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
-  } in
-
-  (* Connect up the callback for menu entries etc.  These require the
-   * window_state struct in callbacks.
-   *)
-
-  (* Connect to different hypervisors. *)
-  ignore (connect_kvm_item#connect#activate
-            ~callback:(fun () -> connect_to ws (Some "qemu:///system")));
-  ignore (connect_xen_item#connect#activate
-            ~callback:(fun () -> connect_to ws (Some "xen:///")));
-  ignore (connect_none_item#connect#activate
-            ~callback:(fun () -> connect_to ws None));
-
-  (* 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
-      ~callback:(
-        fun () ->
-          match combo#active_iter with
-          | None -> () (* nothing selected *)
-          | 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 () =
+let make_menubar window (vbox : GPack.box) ~packing () =
   let menubar = GMenu.menu_bar ~packing:vbox#pack () in
   let factory = new GMenu.factory menubar in
   let accel_group = factory#accel_group in
@@ -277,32 +82,234 @@ and make_toolbar ~packing () =
   vmcombo, refresh_button, throbber, static
 
 and make_filetree ~packing () =
+  (* Create the filetree inside a scrolled window. *)
   let sw =
     GBin.scrolled_window ~packing ~hpolicy:`AUTOMATIC ~vpolicy:`ALWAYS () in
-  Filetree.create ~packing:sw#add ()
+  let tree = new Filetree.tree ~packing:sw#add () in
 
-(* Do what the user asked on the command line. *)
-let rec run_cli_request ws = function
+  (* Wire up the loosely-coupled external components of the filetree.
+   * See the note about signals in {!Filetree.tree} documentation.
+   *)
+  ignore (tree#op_checksum_file
+            ~callback:(Op_checksum_file.checksum_file tree));
+  ignore (tree#op_copy_regvalue
+            ~callback:(Op_copy_regvalue.copy_regvalue tree));
+  ignore (tree#op_disk_usage
+            ~callback:(Op_disk_usage.disk_usage tree));
+  ignore (tree#op_download_as_reg
+            ~callback:(Op_download_as_reg.download_as_reg tree));
+  ignore (tree#op_download_dir_find0
+            ~callback:(Op_download_dir_find0.download_dir_find0 tree));
+  ignore (tree#op_download_dir_tarball
+            ~callback:(Op_download_dir_tarball.download_dir_tarball tree));
+  ignore (tree#op_download_file
+            ~callback:(Op_download_file.download_file tree));
+  ignore (tree#op_file_information
+            ~callback:(Op_file_information.file_information tree));
+  ignore (tree#op_inspection_dialog
+            ~callback:(Op_inspection_dialog.inspection_dialog tree));
+  ignore (tree#op_view_file
+            ~callback:(Op_view_file.view_file tree));
+
+  tree
+
+class window =
+  (* I prototyped the basic window layout using Glade, but have
+   * implemented it by hand to give us more flexibility.
+   *)
+  let title = "Guest Filesystem Browser" in
+  let window = GWindow.window ~width:700 ~height:700 ~title () in
+  let vbox = GPack.vbox ~packing:window#add () in
+
+  (* Menus. *)
+  let connect_kvm_item, connect_xen_item, connect_none_item, _, _ =
+    make_menubar window vbox ~packing:vbox#pack () in
+
+  (* Top toolbar. *)
+  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 ~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
+
+object (self)
+  initializer
+    ignore (statusbar_context#push title);
+    window#show ();
+
+    (* Connect up the callback for menu entries etc.  These require the
+     * window_state struct in callbacks.
+     *)
+
+    (* Connect to different hypervisors. *)
+    ignore (connect_kvm_item#connect#activate
+              ~callback:(fun () -> self#connect_to (Some "qemu:///system")));
+    ignore (connect_xen_item#connect#activate
+              ~callback:(fun () -> self#connect_to (Some "xen:///")));
+    ignore (connect_none_item#connect#activate
+              ~callback:(fun () -> self#connect_to None));
+
+    (* VM combo box when changed by the user.
+     * The refresh button acts like changing the VM combo too.
+     *)
+    let combo, (model, column) = vmcombo in
+    ignore (
+      combo#connect#changed
+        ~callback:(
+          fun () ->
+            match combo#active_iter with
+            | None -> () (* nothing selected *)
+            | Some row -> self#open_domain (model#get ~row ~column)
+        )
+    );
+    ignore (
+      refresh_button#connect#clicked
+        ~callback:(
+          fun () ->
+            match combo#active_iter with
+            | None -> () (* nothing selected *)
+            | Some row -> self#open_domain (model#get ~row ~column)
+        )
+    )
+
+  (* Set the statusbar text. *)
+  method set_statusbar msg =
+    statusbar_context#pop ();
+    ignore (statusbar_context#push msg)
+
+  (* Clear the filetree. *)
+  method private clear_view () =
+    view#clear ()
+
+  (* Callback from Connect -> ... menu items. *)
+  method private connect_to uri =
+    self#clear_view ();
+    Slave.discard_command_queue ();
+    Slave.connect uri (self#when_connected uri)
+
+  (* Called back when connected to a new hypervisor. *)
+  method private when_connected uri doms =
+    self#populate_vmcombo doms
+
+  (* Populate the VM combo box. *)
+  method private populate_vmcombo doms =
+    let combo, (model, column) = vmcombo in
+    model#clear ();
+    List.iter (
+      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. *)
+  method private open_domain name =
+    self#clear_view ();
+    Slave.discard_command_queue ();
+    Slave.open_domain name (self#when_opened_domain name)
+
+  (* Called back when domain was opened successfully. *)
+  method private when_opened_domain name data =
+    debug "when_opened_domain callback";
+    self#when_opened_common name data
+
+  (* When a set of disk images is selected by the user. *)
+  method private open_disk_images images =
+    match images with
+    | [] -> ()
+    | images ->
+        self#clear_view ();
+        Slave.discard_command_queue ();
+        Slave.open_images images (self#when_opened_disk_images images)
+
+  (* Called back when disk image(s) were opened successfully. *)
+  method private when_opened_disk_images images data =
+    match images with
+    | [] -> ()
+    | (image, _) :: _ ->
+        debug "when_opened_disk_images callback";
+        self#when_opened_common image data
+
+  (* Common code for when_opened_domain/when_opened_disk_images. *)
+  method private when_opened_common name data =
+    (* Dump some of the inspection data in debug messages. *)
+    List.iter (fun (dev, t) -> debug "filesystem: %s: %s" dev t)
+      data.insp_all_filesystems;
+    List.iter (
+      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.insp_oses;
+
+    view#add_os name data
+
+  (* Public callbacks. *)
+  method throbber_busy () =
+    (*throbber#set_pixbuf animation*)
+    (* XXX Workaround because no binding for GdkPixbufAnimation: *)
+    let file = Filename.dirname Sys.argv.(0) // "Throbber.gif" in
+    throbber#set_file file
+
+  method throbber_idle () =
+    throbber#set_pixbuf throbber_static
+
+  method progress (position, total) =
+    if position = 0L && total = 1L then
+      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
+      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
+   * necessary to turn the exception into an error message.
+   *)
+  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 ->
-      open_disk_images ws 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 (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
+      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
+    in
+    let i = loop 0 (List.map (fun { dom_name = name } -> name) doms) in
+
+    let combo, _ = vmcombo in
+    combo#set_active i
+
+end