main.ml

   1 (* Guestfs Browser.
   2  * Copyright (C) 2010 Red Hat Inc.
   3  *
   4  * This program is free software; you can redistribute it and/or modify
   5  * it under the terms of the GNU General Public License as published by
   6  * the Free Software Foundation; either version 2 of the License, or
   7  * (at your option) any later version.
   8  *
   9  * This program is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12  * GNU General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU General Public License along
  15  * with this program; if not, write to the Free Software Foundation, Inc.,
  16  * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  17  *)
  18
  19 open Utils
  20
  21 (* Display state. *)
  22 type display_state = {
  23   window : GWindow.window;
  24   throbber_busy : unit -> unit;
  25   throbber_idle : unit -> unit;
  26 }
  27
  28 let open_main_window () =
  29   let title = "Guest Filesystem Browser" in
  30   let window = GWindow.window ~width:800 ~height:600 ~title () in
  31   let vbox = GPack.vbox ~packing:window#add () in
  32
  33   (* Do the menus. *)
  34   let menubar = GMenu.menu_bar ~packing:vbox#pack () in
  35   let factory = new GMenu.factory menubar in
  36   let accel_group = factory#accel_group in
  37   let connect_menu = factory#add_submenu "_Connect" in
  38
  39   let factory = new GMenu.factory connect_menu ~accel_group in
  40   let quit_item = factory#add_item "E_xit" ~key:GdkKeysyms._Q in
  41
  42   (* Quit. *)
  43   let quit _ = GMain.quit (); false in
  44   ignore (window#connect#destroy ~callback:GMain.quit);
  45   ignore (window#event#connect#delete ~callback:quit);
  46   ignore (quit_item#connect#activate
  47             ~callback:(fun () -> ignore (quit ()); ()));
  48
  49   (* Top status area. *)
  50   let hbox = GPack.hbox ~border_width:4 ~packing:vbox#pack () in
  51   ignore (GMisc.label ~text:"Guest: " ~packing:hbox#pack ());
  52
  53   (* Throbber, http://faq.pygtk.org/index.py?req=show&file=faq23.037.htp *)
  54   let static = Throbber.static () in
  55   (*let animation = Throbber.animation () in*)
  56   let throbber =
  57     GMisc.image ~pixbuf:static ~packing:(hbox#pack ~from:`END) () in
  58   let throbber_busy () =
  59     (*throbber#set_pixbuf animation*)
  60     (* Workaround because no binding for GdkPixbufAnimation: *)
  61     let file = Filename.dirname Sys.argv.(0) // "Throbber.gif" in
  62     throbber#set_file file
  63   and throbber_idle () =
  64     throbber#set_pixbuf static
  65   in
  66
  67   window#show ();
  68   window#add_accel_group accel_group;
  69
  70   (* display_state which is threaded through all the other callbacks,
  71    * allowing callbacks to update the window.
  72    *)
  73   { window = window;
  74     throbber_busy = throbber_busy; throbber_idle = throbber_idle }
  75
  76 let () =
  77   let ds = open_main_window () in
  78   Slave.set_failure_hook (failure ds);
  79   Slave.set_busy_hook ds.throbber_busy;
  80   Slave.set_idle_hook ds.throbber_idle;
  81
  82   (* Run the main display thread.  When this returns, the application
  83    * has been closed.
  84    *)
  85   GtkThread.main ();
  86   Slave.exit_thread ()