From 1d7c4274827064c684d831c9ef51b198ba8798a2 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Thu, 28 Jul 2011 22:47:51 +0100 Subject: [PATCH] Make window into an object. This refactors the code so that the main window is an object. This will allow us to use signals for the menu functions instead of direct callbacks. --- main.ml | 14 +-- window.ml | 413 +++++++++++++++++++++++++++++-------------------------------- window.mli | 55 ++++---- 3 files changed, 230 insertions(+), 252 deletions(-) diff --git a/main.ml b/main.ml index 82e4603..93e2a3a 100644 --- a/main.ml +++ b/main.ml @@ -33,15 +33,15 @@ let () = debug "libvirt %s" (libvirt_version_string ()); ); - let ws = Window.open_main_window () in - Slave.set_failure_hook (Window.failure ws); - Slave.set_busy_hook (Window.throbber_busy ws); - Slave.set_idle_hook (Window.throbber_idle ws); - Slave.set_status_hook (Window.set_statusbar ws); - Slave.set_progress_hook (Window.progress ws); + let w = new Window.window in + Slave.set_failure_hook w#failure; + Slave.set_busy_hook w#throbber_busy; + Slave.set_idle_hook w#throbber_idle; + Slave.set_status_hook w#set_statusbar; + Slave.set_progress_hook w#progress; (* What did the user request on the command line? *) - Window.run_cli_request ws cli_request; + w#run_cli_request cli_request; (* Run the main display thread. When this returns, the application * has been closed. diff --git a/window.ml b/window.ml index 2dd32cd..6ede415 100644 --- a/window.ml +++ b/window.ml @@ -23,203 +23,7 @@ open Slave_types module G = Guestfs -(* Main window state. *) -type window_state = { - window : GWindow.window; - view : Filetree.tree; - 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 = - ws.view#clear () - -(* 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; - - ws.view#add_os 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 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 - -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 @@ -309,28 +113,203 @@ and make_filetree ~packing () = tree -(* Do what the user asked on the command line. *) -let rec run_cli_request ws = function +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 diff --git a/window.mli b/window.mli index b2877bb..0b2acb5 100644 --- a/window.mli +++ b/window.mli @@ -19,31 +19,30 @@ (** The Window module handles all aspects of the main window, menus, dialogs and so on. *) -type window_state - -val open_main_window : unit -> window_state - (** Open the main Gtk window, set up the menus, callbacks and so on. *) - -val failure : window_state -> exn -> unit - (** This is the global error handling function. It is invoked in - the main thread for failures in the slave thread (see - {!Slave.set_failure_hook}). *) - -val throbber_busy : window_state -> unit -> unit -val throbber_idle : window_state -> unit -> unit - (** These are callbacks from the slave thread (invoked in the main - thread) which are called whenever the throbber should be - animated/busy or idle. *) - -val set_statusbar : window_state -> string -> unit - (** This callback from the slave thread (invoked in the main thread) - updates the status bar when some slave operation starts or - stops. *) - -val progress : window_state -> int64 * int64 -> unit - (** This called whenever the progress bar should move. *) - -val run_cli_request : window_state -> Cmdline.cli_request -> unit - (** This function performs the {!Cmdline.cli_request} operation. - The actual operation happens asynchronously after this function - has returned. *) +class window : +object + method failure : exn -> unit + (** This is the global error handling function. It is invoked in + the main thread for failures in the slave thread (see + {!Slave.set_failure_hook}). *) + + method throbber_busy : unit -> unit + method throbber_idle : unit -> unit + (** These are callbacks from the slave thread (invoked in the main + thread) which are called whenever the throbber should be + animated/busy or idle. *) + + method set_statusbar : string -> unit + (** This callback from the slave thread (invoked in the main thread) + updates the status bar when some slave operation starts or + stops. *) + + method progress : int64 * int64 -> unit + (** This called whenever the progress bar should move. *) + + method run_cli_request : Cmdline.cli_request -> unit + (** This function performs the {!Cmdline.cli_request} operation. + The actual operation happens asynchronously after this function + has returned. *) + +end -- 1.8.3.1