window.ml

   1 (* Virt resize UI.
   2  * Copyright (C) 2011 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 Printf
  20
  21 open Utils
  22
  23 type file_menu = {
  24   quit_item : GMenu.menu_item;
  25 }
  26
  27 type help_menu = {
  28   about_item : GMenu.menu_item;
  29 }
  30
  31 type tabs = {
  32   source_tab : Source_tab.tab;
  33   destination_tab : Destination_tab.tab;
  34   partitions_tab : Partitions_tab.tab;
  35   logvols_tab : Logvols_tab.tab;
  36 }
  37
  38 type buttons = {
  39   prev_button : GButton.button;
  40   next_button : GButton.button;
  41   go_button : GButton.button;
  42   exit_button : GButton.button;
  43 }
  44
  45 class window =
  46   let title = "Resize a virtual machine - virt-resize-ui" in
  47 object (self)
  48   val mutable tabs = None
  49   val mutable statusbar_context = None
  50   val mutable progress_bar : GRange.progress_bar option = None
  51
  52   method source_tab = (Option.get tabs).source_tab
  53
  54   method set_statusbar msg =
  55     Option.may (
  56       fun c ->
  57         c#pop ();
  58         ignore (c#push msg)
  59     ) statusbar_context
  60
  61   method progress (position, total) =
  62     Option.may (
  63       fun pb ->
  64         if position = 0L && total = 1L then
  65           pb#pulse ()
  66         else (
  67           let frac = Int64.to_float position /. Int64.to_float total in
  68           if frac < 0. || frac > 1. then
  69             eprintf "warning: progress bar out of range: %Ld / %Ld (%g)\n"
  70               position total frac;
  71           let frac = if frac < 0. then 0. else if frac > 1. then 1. else frac in
  72           pb#set_fraction frac
  73         )
  74     ) progress_bar
  75
  76   initializer
  77   (* Window. *)
  78   let window = GWindow.window ~width:700 ~height:700 ~title () in
  79   let vbox = GPack.vbox ~packing:window#add () in
  80
  81   (* Menus. *)
  82   let menubar = GMenu.menu_bar ~packing:vbox#pack () in
  83   let factory = new GMenu.factory menubar in
  84   let accel_group = factory#accel_group in
  85
  86   let file_menu =
  87     let menu = factory#add_submenu "_File" in
  88     let factory = new GMenu.factory menu ~accel_group in
  89     let quit = factory#add_item "E_xit" ~key:GdkKeysyms._Q in
  90     { quit_item = quit } in
  91
  92   let help_menu =
  93     let menu = factory#add_submenu "_Help" in
  94     let factory = new GMenu.factory menu ~accel_group in
  95     let about = factory#add_item "About virt-resize-ui ..." in
  96     { about_item = about } in
  97
  98   ignore help_menu;
  99
 100   (* Tabbed notebook for main part of the display. *)
 101   tabs <- (
 102     let nb = GPack.notebook ~packing:(vbox#pack ~expand:true ~fill:true) () in
 103
 104     let src = Source_tab.tab () in
 105     let tab_label = (GMisc.label ~text:"Source" () :> GObj.widget) in
 106     ignore (nb#append_page ~tab_label (src :> GObj.widget));
 107
 108     let dest = Destination_tab.tab () in
 109     let tab_label = (GMisc.label ~text:"Destination" () :> GObj.widget) in
 110     ignore (nb#append_page ~tab_label (dest :> GObj.widget));
 111
 112     let parts = Partitions_tab.tab () in
 113     let tab_label =
 114       (GMisc.label ~text:"Resize partitions" () :> GObj.widget) in
 115     ignore (nb#append_page ~tab_label (parts :> GObj.widget));
 116
 117     let lvs = Logvols_tab.tab () in
 118     let tab_label =
 119       (GMisc.label ~text:"Expand logical volumes" () :> GObj.widget) in
 120     ignore (nb#append_page ~tab_label (lvs :> GObj.widget));
 121
 122     Some { source_tab = src; destination_tab = dest;
 123            partitions_tab = parts; logvols_tab = lvs });
 124
 125   (* Status bar and progress bar. *)
 126   let hbox = GPack.hbox ~spacing:4 ~packing:vbox#pack () in
 127   progress_bar <- Some (GRange.progress_bar ~packing:hbox#pack ());
 128   let statusbar = GMisc.statusbar ~packing:(hbox#pack ~expand:true) () in
 129   statusbar_context <- Some (statusbar#new_context ~name:"Standard");
 130   ignore ((Option.get statusbar_context)#push title);
 131
 132   (* Buttons. *)
 133   let buttons =
 134     let bbox = GPack.button_box `HORIZONTAL ~packing:vbox#pack () in
 135     bbox#set_border_width 8;
 136
 137     let ex = GButton.button ~stock:`QUIT ~packing:bbox#pack () in
 138     ex#misc#set_sensitive true;
 139     let prev = GButton.button ~stock:`GO_BACK ~packing:bbox#pack () in
 140     prev#misc#set_sensitive false;
 141     let next = GButton.button ~stock:`GO_FORWARD ~packing:bbox#pack () in
 142     next#misc#set_sensitive true;
 143     let go = GButton.button ~stock:`APPLY ~packing:bbox#pack () in
 144     go#misc#set_sensitive false;
 145     { prev_button = prev; next_button = next; go_button = go;
 146       exit_button = ex } in
 147
 148   (* Quit button. *)
 149   let quit _ = GMain.quit (); false in
 150   ignore (window#connect#destroy ~callback:GMain.quit);
 151   ignore (window#event#connect#delete ~callback:quit);
 152   ignore (file_menu.quit_item#connect#activate
 153             ~callback:(fun () -> ignore (quit ()); ()));
 154   ignore (buttons.exit_button#connect#clicked
 155             ~callback:(fun () -> ignore (quit ()); ()));
 156
 157   (* Accel_group. *)
 158   window#add_accel_group accel_group;
 159
 160   window#show ()
 161 end