mlvirtmanager/mlvirtmanager_mainwindow.ml

   1 (* virt-manager-like graphical management tool.
   2    (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
   3    http://libvirt.org/
   4 *)
   5
   6 open Printf
   7
   8 let title = "Virtual Machine Manager"
   9
  10 let utf8_copyright = "\194\169"
  11
  12 let help_about () =
  13   let gtk_version =
  14     let gtk_major, gtk_minor, gtk_micro = GMain.Main.version in
  15     sprintf "%d.%d.%d" gtk_major gtk_minor gtk_micro in
  16   let virt_version = string_of_int (fst (Libvirt.get_version ())) in
  17   let title = "About " ^ title in
  18   let icon = GMisc.image () in
  19   icon#set_stock `DIALOG_INFO;
  20   icon#set_icon_size `DIALOG;
  21   GToolbox.message_box
  22     ~title
  23     ~icon
  24     ("Virtual machine manager (OCaml version) by\n" ^
  25      "Richard W.M. Jones (rjones@redhat.com).\n\n" ^
  26      "Copyright " ^ utf8_copyright ^ " 2007 Red Hat Inc.\n\n" ^
  27      "Libvirt version: " ^ virt_version ^ "\n" ^
  28      "Gtk toolkit version: " ^ gtk_version)
  29
  30 (* Catch any exception and throw up a dialog. *)
  31 let () =
  32   (* A nicer exception printing function. *)
  33   let string_of_exn = function
  34     | Libvirt.Virterror err ->
  35         "Virtualisation error: " ^ (Libvirt.Virterror.to_string err)
  36     | Failure msg -> msg
  37     | exn -> Printexc.to_string exn
  38   in
  39   GtkSignal.user_handler :=
  40     fun exn ->
  41       let label = string_of_exn exn in
  42       let title = "Error" in
  43       let icon = GMisc.image () in
  44       icon#set_stock `DIALOG_ERROR;
  45       icon#set_icon_size `DIALOG;
  46       GToolbox.message_box ~title ~icon label
  47
  48 let make ~open_connection
  49     ~start_domain ~pause_domain ~resume_domain ~shutdown_domain =
  50   (* Create the main window. *)
  51   let window = GWindow.window ~width:800 ~height:600 ~title () in
  52   let vbox = GPack.vbox ~packing:window#add () in
  53
  54   (* Menu bar. *)
  55   let menubar = GMenu.menu_bar ~packing:vbox#pack () in
  56   let factory = new GMenu.factory menubar in
  57   let accel_group = factory#accel_group in
  58   let file_menu = factory#add_submenu "File" in
  59   let help_menu = factory#add_submenu "Help" in
  60
  61   (* File menu. *)
  62   let factory = new GMenu.factory file_menu ~accel_group in
  63   let open_item = factory#add_item "Open connection ..."
  64     ~key:GdkKeysyms._O in
  65   ignore (factory#add_separator ());
  66   let quit_item = factory#add_item "Quit" ~key:GdkKeysyms._Q in
  67
  68   ignore (open_item#connect#activate ~callback:open_connection);
  69
  70   (* Help menu. *)
  71   let factory = new GMenu.factory help_menu ~accel_group in
  72   let help_item = factory#add_item "Help" in
  73   let help_about_item = factory#add_item "About ..." in
  74
  75   ignore (help_about_item#connect#activate ~callback:help_about);
  76
  77   (* The toolbar. *)
  78   let toolbar = GButton.toolbar ~packing:vbox#pack () in
  79   let connect_button =
  80     GButton.tool_button ~label:"Connect ..." ~stock:`CONNECT
  81       ~packing:toolbar#insert () in
  82   let start_button =
  83     GButton.tool_button ~label:"Start" ~stock:`ADD
  84       ~packing:toolbar#insert () in
  85   let pause_button =
  86     GButton.tool_button ~label:"Pause" ~stock:`MEDIA_PAUSE
  87       ~packing:toolbar#insert () in
  88   let resume_button =
  89     GButton.tool_button ~label:"Resume" ~stock:`MEDIA_PLAY
  90       ~packing:toolbar#insert () in
  91   let shutdown_button =
  92     GButton.tool_button ~label:"Shutdown" ~stock:`STOP
  93       ~packing:toolbar#insert () in
  94   ignore (connect_button#connect#clicked ~callback:open_connection);
  95
  96   (* The treeview. *)
  97   let (tree, model, columns, initial_state) =
  98     Mlvirtmanager_connections.make_treeview
  99       ~packing:(vbox#pack ~expand:true ~fill:true) () in
 100
 101   ignore (start_button#connect#clicked
 102             ~callback:(start_domain tree model columns));
 103   ignore (pause_button#connect#clicked
 104             ~callback:(pause_domain tree model columns));
 105   ignore (resume_button#connect#clicked
 106             ~callback:(resume_domain tree model columns));
 107   ignore (shutdown_button#connect#clicked
 108             ~callback:(shutdown_domain tree model columns));
 109
 110   (* Make a timeout function which is called once per second. *)
 111   let state = ref initial_state in
 112   let callback () =
 113     state := Mlvirtmanager_connections.repopulate tree model columns !state;
 114     true
 115   in
 116   let timeout_id = GMain.Timeout.add ~ms:1000 ~callback in
 117
 118   (* Quit. *)
 119   let quit _ =
 120     GMain.Timeout.remove timeout_id;
 121     GMain.Main.quit ();
 122     false
 123   in
 124
 125   ignore (window#connect#destroy ~callback:GMain.quit);
 126   ignore (window#event#connect#delete ~callback:quit);
 127   ignore (quit_item#connect#activate
 128             ~callback:(fun () -> ignore (quit ()); ()));
 129
 130   window#add_accel_group accel_group;
 131
 132   (* Display the window. *)
 133   window#show ()