X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=window.ml;h=baa63b2b78808ebb41e219ba26e4d08e78b3708a;hb=23a1eac79ffcbab1801b89430fc0354e44cf7599;hp=f58d76fc926c0fd5db5bc51c82885adfb3393379;hpb=e2e705307171a21a413f6ea47baf52d2fb44a6b3;p=guestfs-browser.git diff --git a/window.ml b/window.ml index f58d76f..baa63b2 100644 --- a/window.ml +++ b/window.ml @@ -19,379 +19,333 @@ open Printf open Utils +open Slave_types module G = Guestfs -let (//) = Filename.concat - -(* Display state. *) -type display_state = { - window : GWindow.window; - throbber_busy : unit -> unit; - throbber_idle : unit -> unit; - set_statusbar : string -> unit; - clear_statusbar : unit -> unit; - set_vmlist : string list -> unit; - clear_vmlist : unit -> unit; - clear_notebook : unit -> unit; - filesystem : GPack.box; - notebook : GPack.notebook; +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; } -let rec open_main_window () = +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 - (* Do the menus. *) + (* 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 ()); ())); - - (* Top status area. *) - let hbox = GPack.hbox ~border_width:4 ~packing:vbox#pack () in - hbox#pack (mklabel "Guest: "); - - (* List of VMs. *) + + 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. *) let vmcombo = GEdit.combo_box_text ~packing:hbox#pack () in - let set_vmlist names = + + (* Refresh button. + * http://stackoverflow.com/questions/2188659/stock-icons-not-shown-on-buttons + *) + let refresh_button = + let image = GMisc.image ~stock:`REFRESH () in + let b = GButton.button ~packing:hbox#pack () in + b#set_image (image :> GObj.widget); + b in + + (* Throbber. *) + 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:throbber_static ~packing:(hbox#pack ~from) () in + + (* Main part of display is the file tree. *) + (* Create the filetree inside a scrolled window. *) + 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 + + (* 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 (); + + (* 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. + *) + 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) + + (* Return the filetree. *) + method tree = tree + + (* Connect to the given URI. *) + method connect_to uri () = + tree#clear (); + 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 name -> + fun { dom_name = name } -> let row = model#append () in model#set ~row ~column name - ) names - in - let clear_vmlist () = set_vmlist [] in - - (* Throbber, http://faq.pygtk.org/index.py?req=show&file=faq23.037.htp *) - let static = Throbber.static () in - (*let animation = Throbber.animation () in*) - let throbber = - GMisc.image ~pixbuf:static ~packing:(hbox#pack ~from:`END) () in - let throbber_busy () = - (*throbber#set_pixbuf animation*) - (* Workaround because no binding for GdkPixbufAnimation: *) - let file = Filename.dirname Sys.argv.(0) // "Throbber.gif" in - throbber#set_file file - and throbber_idle () = - throbber#set_pixbuf static - in - - (* Tabbed pane ("notebook") filling the main window. *) - let nb = GPack.notebook ~scrollable:true - ~packing:(vbox#pack ~expand:true ~fill:true) () in - let filesystem = GPack.vbox () in - filesystem#add (intro_label () :> GObj.widget); - ignore (nb#append_page - ~tab_label:(mklabel "Filesystem") (filesystem :> GObj.widget)); - let clear_notebook () = - nb#goto_page 0; - (* Remove all tabs except the first ("Filesystem") tab ... *) - List.iter nb#remove (List.tl nb#all_children); - (* ... and clear out the filesystem tab. *) - List.iter filesystem#remove filesystem#all_children - in - - (* Status bar at the bottom of the screen. *) - let set_statusbar = - let statusbar = GMisc.statusbar ~packing:vbox#pack () in - let context = statusbar#new_context ~name:"Standard" in - ignore (context#push title); - fun msg -> - context#pop (); - ignore (context#push msg) - in - let clear_statusbar () = set_statusbar "" in - - window#show (); - window#add_accel_group accel_group; - - (* display_state which is threaded through all the other callbacks, - * allowing callbacks to update the window. + ) doms + + (* When a new domain is selected by the user, eg through vmcombo. *) + method private open_domain name = + tree#clear (); + 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 open_disk_images images = + match images with + | [] -> () + | images -> + tree#clear (); + 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 + + (* 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. *) + 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; + + tree#add_os name data + + (* Public callbacks. *) + method throbber_busy () = + throbber#set_pixbuf throbber_animation + + 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. *) - 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 () -> - Option.may (fun row -> open_domain ds (model#get ~row ~column)) - combo#active_iter - ) - ); - - ignore (connect_kvm_item#connect#activate - ~callback:(fun () -> connect ds (Some "qemu:///system"))); - ignore (connect_xen_item#connect#activate - ~callback:(fun () -> connect ds (Some "xen:///"))); - ignore (connect_none_item#connect#activate - ~callback:(fun () -> connect ds None)); - ignore (connect_uri_item#connect#activate ~callback:(connect_uri_dialog ds)); - ignore (open_image_item#connect#activate ~callback:(open_image_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 - -(* Perform action to open the named libvirt URI. *) -and connect ds uri = - (match uri with - | None -> ds.set_statusbar "Connecting to default libvirt ..."; - | Some uri -> ds.set_statusbar (sprintf "Connecting to %s ..." uri)); - ds.clear_notebook (); - Slave.discard_command_queue (); - Slave.connect uri (connected ds uri) - -(* 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 - -(* Perform action to open the named domain. *) -and open_domain ds name = - ds.set_statusbar (sprintf "Opening %s ..." name); - ds.clear_notebook (); - Slave.discard_command_queue (); - Slave.open_domain name (opened_domain ds) - -(* 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 - -(* Perform action of opening disk image(s). *) -and open_images ds images = - ds.set_statusbar (sprintf "Opening disk image %s ..." - (String.concat " " images)); - ds.clear_notebook (); - Slave.discard_command_queue (); - Slave.open_images images (opened_images ds) - -(* 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.set_statusbar ("Opening filesystems ..."); - 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 = - ds.clear_statusbar (); - - 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 = "" ^ text ^ "" 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) + 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 -> + 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 (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 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 combo, _ = vmcombo in + combo#set_active i - 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_uri_dialog ds () = - debug "connect_uri_dialog"; - let title = "Choose a libvirt URI" in - let ok = "Connect to libvirt" in - let text = "NB: Remote storage cannot be accessed, so entering -a libvirt remote URI here will probably not work." in - let uri = GToolbox.input_string ~title ~ok text in - match uri with - | None -> debug "connect_uri_dialog cancelled"; () - | Some "" -> debug "connect to default"; connect ds None - | (Some s) as uri -> debug "connect to %s" s; connect ds uri - -(* Open the disk images dialog. - * XXX This can only deal with a single disk image at the moment, but - * underlying code can deal with multiple. - *) -and open_image_dialog ds () = - let title = "Choose a disk image" in - let dlg = GWindow.file_chooser_dialog ~action:`OPEN ~title ~modal:true () in - dlg#add_button "Open disk image" `OPEN_IMAGE; - dlg#add_button "Close" `DELETE_EVENT; - - let callback = function - | `DELETE_EVENT -> debug "DELETE_EVENT response"; dlg#destroy () - | `OPEN_IMAGE -> - match dlg#filename with - | None -> () (* nothing selected in dialog, keep dialog open *) - | Some filename -> - debug "OPEN_IMAGE response, filename = %s" filename; - dlg#destroy (); - open_images ds [filename] - in - ignore (dlg#connect#response ~callback); - - dlg#show () - -(* The introductory text which appears in the tabbed notebook to - * tell the user how to start. XXX We should add images. - *) -and intro_label () = - let text = - sprintf "Open a disk image (Connect %s Open disk image), connect to libvirt (Connect %s Connect to libvirt), or choose a guest from the \"Guest\" menu above." - utf8_rarrow utf8_rarrow in - let label = GMisc.label ~text () in - label#set_line_wrap true; - label - -let run_cli_request ds = function - | Cmdline.Empty_window -> () - | Cmdline.Connect_to_libvirt uri -> connect ds uri - | Cmdline.Open_disk_image images -> open_images ds images +end