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

diff --git a/window.ml b/window.ml
index 6ede415..baa63b2 100644
--- a/window.ml
+++ b/window.ml
@@ -23,43 +23,75 @@ open Slave_types
 
 module G = Guestfs
 
-let make_menubar window (vbox : GPack.box) ~packing () =
+type connect_menu = {
+  connect_menu : GMenu.menu;
+  connect_kvm_item : GMenu.menu_item;
+  connect_xen_item : GMenu.menu_item;
+  connect_none_item : GMenu.menu_item;
+  connect_uri_item : GMenu.menu_item;
+  open_disk_item : GMenu.menu_item;
+  reopen_item : GMenu.menu_item;
+  quit_item : GMenu.menu_item;
+}
+
+type guest_menu = {
+  guest_menu : GMenu.menu;
+  guest_inspection_item : GMenu.menu_item;
+}
+
+type help_menu = {
+  help_menu : GMenu.menu;
+  about_item : GMenu.menu_item;
+}
+
+class window =
+  (* Window. *)
+  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 menubar = GMenu.menu_bar ~packing:vbox#pack () in
   let factory = new GMenu.factory menubar in
   let accel_group = factory#accel_group in
-  let connect_menu = factory#add_submenu "_Connect" in
-
-  let factory = new GMenu.factory connect_menu ~accel_group in
-  let connect_kvm_item = factory#add_item "Connect to local _KVM hypervisor" in
-  let connect_xen_item = factory#add_item "Connect to local _Xen hypervisor" in
-  let connect_none_item = factory#add_item "_Connect to default hypervisor" in
-  let connect_uri_item = factory#add_item "Connect to a _libvirt URI ..." in
-  ignore (factory#add_separator ());
-  let open_image_item =
-    factory#add_item "_Open disk image ..." ~key:GdkKeysyms._O in
-  ignore (factory#add_separator ());
-  let quit_item = factory#add_item "E_xit" ~key:GdkKeysyms._Q in
-
-  (* Quit. *)
-  let quit _ = GMain.quit (); false in
-  ignore (window#connect#destroy ~callback:GMain.quit);
-  ignore (window#event#connect#delete ~callback:quit);
-  ignore (quit_item#connect#activate
-            ~callback:(fun () -> ignore (quit ()); ()));
-
-  window#add_accel_group accel_group;
-
-  connect_kvm_item, connect_xen_item, connect_none_item,
-  connect_uri_item, open_image_item
-
-(* Top toolbar.  In fact, not a toolbar because you don't seem to be
- * able to put a combo box into a toolbar, so it's just an hbox for now.
- *)
-and make_toolbar ~packing () =
-  let hbox = GPack.hbox ~border_width:4 ~packing () in
+
+  let connect_menu =
+    let menu = factory#add_submenu "_Connect" in
+    let factory = new GMenu.factory menu ~accel_group in
+    let kvm = factory#add_item "Connect to local _KVM hypervisor" in
+    let xen = factory#add_item "Connect to local _Xen hypervisor" in
+    let none = factory#add_item "_Connect to default hypervisor" in
+    let uri = factory#add_item "Connect to a _libvirt URI ..." in
+    ignore (factory#add_separator ());
+    let opend = factory#add_item "_Open disk image ..." ~key:GdkKeysyms._O in
+    ignore (factory#add_separator ());
+    let reopen = factory#add_item "Reopen current guest" in
+    ignore (factory#add_separator ());
+    let quit = factory#add_item "E_xit" ~key:GdkKeysyms._Q in
+    { connect_menu = menu; connect_kvm_item = kvm;
+      connect_xen_item = xen; connect_none_item = none;
+      connect_uri_item = uri;
+      open_disk_item = opend; reopen_item = reopen; quit_item = quit } in
+
+  let guest_menu =
+    let menu = factory#add_submenu "_Guest" in
+    let factory = new GMenu.factory menu ~accel_group in
+    let inspection = factory#add_item "Operating system information ..." in
+    { guest_menu = menu; guest_inspection_item = inspection } in
+
+  let help_menu =
+    let menu = factory#add_submenu "_Help" in
+    let factory = new GMenu.factory menu ~accel_group in
+    let about = factory#add_item "About guest filesystem browser ..." in
+    { help_menu = menu; about_item = about } in
+
+  (* Top toolbar. *)
+  let hbox =
+    let hbox = GPack.hbox ~border_width:4 ~packing:vbox#pack () in
+    hbox#pack (mklabel "Guest: ");
+    hbox in
 
   (* Combo box for displaying virtual machine names. *)
-  hbox#pack (mklabel "Guest: ");
   let vmcombo = GEdit.combo_box_text ~packing:hbox#pack () in
 
   (* Refresh button.
@@ -72,88 +104,86 @@ and make_toolbar ~packing () =
     b in
 
   (* Throbber. *)
-  let static = Throbber.static () in
-  (*let animation = Throbber.animation () in*)
+  let throbber_static = Throbber.static () in
+  let throbber_animation = Throbber.animation () in
   let throbber =
     (* 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
+    GMisc.image ~pixbuf:throbber_static ~packing:(hbox#pack ~from) () in
 
-  vmcombo, refresh_button, throbber, static
-
-and make_filetree ~packing () =
+  (* Main part of display is the file tree. *)
   (* Create the filetree inside a scrolled window. *)
-  let sw =
-    GBin.scrolled_window ~packing ~hpolicy:`AUTOMATIC ~vpolicy:`ALWAYS () in
+  let sw = GBin.scrolled_window
+    ~hpolicy:`AUTOMATIC ~vpolicy:`ALWAYS
+    ~packing:(vbox#pack ~expand:true ~fill:true) () in
   let tree = new Filetree.tree ~packing:sw#add () in
 
-  (* 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. *)
+  (* Status bar and progress bar at the bottom. *)
   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
 
+  (* Signals. *)
+  let connect_kvm_signal = new GUtil.signal () in
+  let connect_xen_signal = new GUtil.signal () in
+  let connect_none_signal = new GUtil.signal () in
+  let connect_uri_signal = new GUtil.signal () in
+  let open_disk_signal = new GUtil.signal () in
+  let reopen_signal = new GUtil.signal () in
+  let inspection_signal = new GUtil.signal () in
+  let about_signal = new GUtil.signal () in
+
 object (self)
+  inherit GUtil.ml_signals [connect_kvm_signal#disconnect;
+                            connect_xen_signal#disconnect;
+                            connect_none_signal#disconnect;
+                            connect_uri_signal#disconnect;
+                            open_disk_signal#disconnect;
+                            reopen_signal#disconnect;
+                            inspection_signal#disconnect;
+                            about_signal#disconnect]
+
+  method connect_kvm_signal = connect_kvm_signal#connect ~after
+  method connect_xen_signal = connect_xen_signal#connect ~after
+  method connect_none_signal = connect_none_signal#connect ~after
+  method connect_uri_signal = connect_uri_signal#connect ~after
+  method open_disk_signal = open_disk_signal#connect ~after
+  method reopen_signal = reopen_signal#connect ~after
+  method inspection_signal = inspection_signal#connect ~after
+  method about_signal = about_signal#connect ~after
+
   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));
+    (* Quit. *)
+    let quit _ = GMain.quit (); false in
+    ignore (window#connect#destroy ~callback:GMain.quit);
+    ignore (window#event#connect#delete ~callback:quit);
+    ignore (connect_menu.quit_item#connect#activate
+              ~callback:(fun () -> ignore (quit ()); ()));
+
+    (* Accel_group. *)
+    window#add_accel_group accel_group;
+
+    (* Menu entries emit signals. *)
+    ignore (connect_menu.connect_kvm_item#connect#activate
+              ~callback:connect_kvm_signal#call);
+    ignore (connect_menu.connect_xen_item#connect#activate
+              ~callback:connect_xen_signal#call);
+    ignore (connect_menu.connect_none_item#connect#activate
+              ~callback:connect_none_signal#call);
+    ignore (connect_menu.connect_uri_item#connect#activate
+              ~callback:connect_uri_signal#call);
+    ignore (connect_menu.open_disk_item#connect#activate
+              ~callback:open_disk_signal#call);
+    ignore (connect_menu.reopen_item#connect#activate
+              ~callback:reopen_signal#call);
+    ignore (guest_menu.guest_inspection_item#connect#activate
+              ~callback:inspection_signal#call);
+    ignore (help_menu.about_item#connect#activate
+              ~callback:about_signal#call);
 
     (* VM combo box when changed by the user.
      * The refresh button acts like changing the VM combo too.
@@ -183,13 +213,12 @@ object (self)
     statusbar_context#pop ();
     ignore (statusbar_context#push msg)
 
-  (* Clear the filetree. *)
-  method private clear_view () =
-    view#clear ()
+  (* Return the filetree. *)
+  method tree = tree
 
-  (* Callback from Connect -> ... menu items. *)
-  method private connect_to uri =
-    self#clear_view ();
+  (* Connect to the given URI. *)
+  method connect_to uri () =
+    tree#clear ();
     Slave.discard_command_queue ();
     Slave.connect uri (self#when_connected uri)
 
@@ -209,7 +238,7 @@ object (self)
 
   (* When a new domain is selected by the user, eg through vmcombo. *)
   method private open_domain name =
-    self#clear_view ();
+    tree#clear ();
     Slave.discard_command_queue ();
     Slave.open_domain name (self#when_opened_domain name)
 
@@ -219,11 +248,11 @@ object (self)
     self#when_opened_common name data
 
   (* When a set of disk images is selected by the user. *)
-  method private open_disk_images images =
+  method open_disk_images images =
     match images with
     | [] -> ()
     | images ->
-        self#clear_view ();
+        tree#clear ();
         Slave.discard_command_queue ();
         Slave.open_images images (self#when_opened_disk_images images)
 
@@ -235,6 +264,16 @@ object (self)
         debug "when_opened_disk_images callback";
         self#when_opened_common image data
 
+  (* Called to reopen the handle. *)
+  method reopen () =
+    tree#clear ();
+    Slave.discard_command_queue ();
+    Slave.reopen self#when_reopened
+
+  method private when_reopened data =
+    debug "when_reopened callback";
+    self#when_opened_common "Reopened"(*XXX we lost the original name*) 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. *)
@@ -246,14 +285,11 @@ object (self)
         debug "root device %s contains %s %s %d.%d" root typ distro major minor;
     ) data.insp_oses;
 
-    view#add_os name data
+    tree#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
+    throbber#set_pixbuf throbber_animation
 
   method throbber_idle () =
     throbber#set_pixbuf throbber_static