1
(* This file is part of Marionnet, a virtual network laboratory
2
Copyright (C) 2009, 2010 Jean-Vincent Loddo
3
Copyright (C) 2009 Luca Saiu
4
Copyright (C) 2009, 2010 Université Paris 13
6
This program is free software: you can redistribute it and/or modify
7
it under the terms of the GNU General Public License as published by
8
the Free Software Foundation, either version 2 of the License, or
9
(at your option) any later version.
11
This program is distributed in the hope that it will be useful,
12
but WITHOUT ANY WARRANTY; without even the implied warranty of
13
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14
GNU General Public License for more details.
16
You should have received a copy of the GNU General Public License
17
along with this program. If not, see <http://www.gnu.org/licenses/>. *)
22
(** Gui completion for the menubar_MARIONNET widget defined with glade. *)
25
module EDialog = Talking.EDialog
26
module Msg = Talking.Msg
27
let mkenv = Environment.make_string_env
28
let check_path_name_validity_and_add_extension_if_needed =
29
Talking.check_path_name_validity_and_add_extension_if_needed
34
module Make (State:sig val st:State.globalState end) = struct
38
(* Create the factory linked to the menubar. *)
39
module F = Menu_factory.Make (struct
40
let parent = Menu_factory.Menubar st#mainwin#menubar_MARIONNET
41
let window = st#mainwin#window_MARIONNET
45
(* **************************************** *
47
* **************************************** *)
49
let project = add_menu (s_ "_Project" )
51
module Common_dialogs = struct
53
(* Dialog used both for "New" and "Open" *)
56
then EDialog.ask_question ~help:None ~cancel:true
57
~gen_id:"save_current"
59
~question:(s_ "Do you want to save the current project?") ()
60
else (Some (mkenv [("save_current","no")]))
64
type env = string Environment.string_env
65
let env_to_string (t:env) = t#to_string (fun s->s)
67
module Created_entry_project_new = Menu_factory.Make_entry
70
let to_string = env_to_string
71
let text = (s_ "New" )
77
EDialog.ask_for_fresh_writable_filename
78
~title:(s_ "Name of the new project" )
79
~filter_names:[`MAR;`ALL]
80
~help:(Some Msg.help_nom_pour_le_projet) ()
82
(EDialog.sequence [Common_dialogs.save_current; filename])
84
let reaction r = begin
85
st#shutdown_everything ();
86
let filename = check_path_name_validity_and_add_extension_if_needed (r#get "filename") in
90
st#new_project filename ;
92
if (st#active_project) && ((r#get "save_current") = "yes")
95
Task_runner.the_task_runner#schedule ~name:"new project" actions)
101
let project_new = Created_entry_project_new.item
104
module Created_entry_project_open = Menu_factory.Make_entry
107
let to_string = env_to_string
108
let text = (s_ "Open" )
113
let filename_dialog () =
114
EDialog.ask_for_existing_filename
115
~title:(s_ "Open an existing Marionnet project" )
116
~filter_names:[`MAR; `ALL]
117
~help:(Some Msg.help_nom_pour_le_projet) ()
119
(EDialog.sequence [Common_dialogs.save_current; filename_dialog])
123
st#shutdown_everything ();
124
let filename = (r#get "filename") in
125
let actions () = begin
128
st#open_project filename;
129
with e -> ((Simple_dialogs.error (s_ "Open a project") ((s_ "Failed to open the file ")^filename) ()); raise e)
131
if (st#active_project) && ((r#get "save_current")="yes")
134
Task_runner.the_task_runner#schedule ~name:"open_project" actions)
140
let project_open = Created_entry_project_open.item
144
add_stock_item (s_ "Save" )
147
if st#is_there_something_on_or_sleeping ()
148
then Msg.error_saving_while_something_up ()
149
else st#save_project)
152
module Created_entry_project_save_as = Menu_factory.Make_entry
155
let to_string = env_to_string
156
let text = (s_ "Save as" )
161
EDialog.ask_for_fresh_writable_filename
162
~title:(s_ "Save as" )
163
~filter_names:[`MAR; `ALL]
164
~help:(Some Msg.help_nom_pour_le_projet) ()
167
if st#is_there_something_on_or_sleeping () then Msg.error_saving_while_something_up () else
168
let filename = check_path_name_validity_and_add_extension_if_needed ~extension:"mar" (r#get "filename") in
170
st#save_project_as filename;
171
with _ -> (Simple_dialogs.error (s_ "Save project as") ((s_ "Failed to save the project into the file ")^filename) ())
174
let project_save_as = Created_entry_project_save_as.item
177
module Created_entry_project_copy_to = Menu_factory.Make_entry
180
let to_string = env_to_string
181
let text = (s_ "Copy to" )
186
EDialog.ask_for_fresh_writable_filename
187
~title:(s_ "Copy to" )
188
~filter_names:[`MAR; `ALL]
189
~help:(Some Msg.help_nom_pour_le_projet) ()
192
if st#is_there_something_on_or_sleeping () then Msg.error_saving_while_something_up () else
193
let filename = check_path_name_validity_and_add_extension_if_needed ~extension:"mar" (r#get "filename") in
195
st#copy_project_into filename
196
with _ -> (Simple_dialogs.error (s_ "Project copy to" ) ((s_ "Failed to copy the project into the file ")^filename) ())
199
let project_copy_to = Created_entry_project_copy_to.item
202
module Created_entry_project_close = Menu_factory.Make_entry
205
let to_string = env_to_string
206
let text = (s_ "Close" )
211
EDialog.ask_question ~help:None ~cancel:true
213
~question:(s_ "Do you want to save the current project?") ()
215
let reaction r = begin
216
st#shutdown_everything ();
217
let () = if (st#active_project) && ((r#get "answer") = "yes")
224
let project_close = Created_entry_project_close.item
227
let separator = project#add_separator ()
229
module Created_entry_project_export = Menu_factory.Make_entry
232
let to_string = env_to_string
233
let text = (s_ "Export image" )
239
let (combo_box, get_selected) = Dot_widget.combo_of_working_output_formats ~active:`png () in
240
let widget_reader () =
241
let frm = get_selected () in
242
Dot.string_of_output_format frm
244
let table = GPack.table ~rows:2 ~columns:1 ~row_spacings:10 ~homogeneous:false () in
247
~markup:("<b>"^(s_ "Output format")^"</b>")
248
~packing:(table#attach ~left:0 ~top:0) ()
250
(table#attach ~left:0 ~top:1 combo_box#coerce);
251
(table#coerce, widget_reader)
253
EDialog.ask_for_fresh_writable_filename
254
~title:(s_ "Export network image" )
255
~filters:(Dot_widget.make_all_working_filters ())
261
let output_format = (r#get "extra_widget") in
262
let filename = check_path_name_validity_and_add_extension_if_needed ~extension:output_format (r#get "filename") in
263
let command = Printf.sprintf "dot -T%s -o %s %s" output_format filename st#dotSketchFile in
266
"Export network image"
267
((s_ "Failed to export network image to the file ")^filename^" (format "^output_format^")")
271
Log.system_or_fail command;
272
st#flash ~delay:8000 ((s_ "Network image correctly exported to the file ")^filename)
273
with _ -> on_error ()
276
let project_export = Created_entry_project_export.item
279
module Created_entry_project_quit = Menu_factory.Make_entry
282
let to_string = env_to_string
283
let text = (s_ "Quit")
288
if ((not st#active_project) || st#project_already_saved)
289
then (Some (mkenv [("answer","no")]))
290
else Talking.EDialog.ask_question ~help:None ~cancel:true
292
~question:(s_ "Do you want to save\nthe current project before quitting?")
296
(* At this point the user really wants to quit the application. *)
297
let save = (st#active_project) && ((r#get "answer") = "yes") in
298
(match st#is_there_something_on_or_sleeping (), save with
300
st#shutdown_everything ();
303
st#poweroff_everything ();
308
Log.printf "Killing the death monitor thread...\n";
309
Death_monitor.stop_polling_loop ();
310
st#network#destroy_process_before_quitting ();
315
let project_quit = Created_entry_project_quit.item
318
(* **************************************** *
320
* **************************************** *)
322
let options = add_menu (s_ "_Options")
324
module Created_entry_options_cwd = Menu_factory.Make_entry
327
let to_string = env_to_string
328
let text = (s_ "Change the temporary working directory")
329
let stock = `DIRECTORY
332
Talking.EDialog.ask_for_existing_writable_folder_pathname_supporting_sparse_files
333
~title:(s_ "Choose the temporary working directory")
334
~help:(Some Msg.help_repertoire_de_travail) ()
335
let reaction r = st#temporary_directory#set (r#get "foldername")
337
let options_cwd = Created_entry_options_cwd.item
339
let options_autogenerate_ip_addresses =
340
add_check_item (s_ "Auto-generation of IP address" )
341
~active:Global_options.autogenerate_ip_addresses_default
342
~callback:(fun active ->
343
Log.printf "You toggled the option (IP)\n";
344
Global_options.set_autogenerate_ip_addresses active)
347
let options_debug_mode =
348
add_check_item (s_ "Debug mode")
349
~active:(Global_options.Debug_level.are_we_debugging ())
350
~callback:(fun active ->
351
Log.printf "You toggled the option (debug)\n";
352
Global_options.Debug_level.set 1)
355
let options_keep_all_snapshots_when_saving =
356
add_check_item (s_ "Keep all snapshots when saving (not only the most recent ones)")
357
~active:(Global_options.Keep_all_snapshots_when_saving.extract ())
358
~callback:(fun active ->
359
Log.printf "You toggled the option (keep al snapshots)\n";
360
Global_options.Keep_all_snapshots_when_saving.set active)
363
(** Hidden to user in this version. *)
364
let workaround_wirefilter_problem =
365
add_check_item "Workaround wirefilter problem"
366
~active:Global_options.workaround_wirefilter_problem_default
367
~callback:(fun active ->
368
Log.printf "You toggled the option (wirefilter)\n"; flush_all ();
369
Global_options.set_workaround_wirefilter_problem active)
372
let () = workaround_wirefilter_problem#coerce#misc#hide ()
374
(* **************************************** *
376
* **************************************** *)
378
let help = add_menu (s_ "_Help")
380
let module D = Gui_dialog_A_PROPOS.Make (State) in
382
let dialog = D.dialog () in
383
let _ = dialog#closebutton_A_PROPOS#connect#clicked ~callback:(dialog#toplevel#destroy) in ()
384
in add_stock_item (s_ "Help") ~stock:`ABOUT ~callback ()
387
(* **************************************** *
389
* **************************************** *)
391
let () = List.iter (* when Active *)
392
(fun w -> st#sensitive_when_Active#insert w#coerce)
393
[project_save; project_save_as; project_copy_to; project_close; project_export]
395
let () = List.iter (* when NoActive *)
396
(fun w -> st#sensitive_when_NoActive#insert w#coerce)
added
removed
gui/gui_menubar_MARIONNET.ml
