1
(* This file is part of Marionnet, a virtual network laboratory
2
Copyright (C) 2010 Jean-Vincent Loddo
3
Copyright (C) 2010 Université Paris 13
5
This program is free software: you can redistribute it and/or modify
6
it under the terms of the GNU General Public License as published by
7
the Free Software Foundation, either version 2 of the License, or
8
(at your option) any later version.
10
This program is distributed in the hope that it will be useful,
11
but WITHOUT ANY WARRANTY; without even the implied warranty of
12
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13
GNU General Public License for more details.
15
You should have received a copy of the GNU General Public License
16
along with this program. If not, see <http://www.gnu.org/licenses/>. *)
19
(** "Hub" component implementation. *)
26
(* Hub related constants: *)
27
(* TODO: make it configurable! *)
29
let port_no_default = 4
34
(* The type of data exchanged with the dialog: *)
43
let to_string t = "<obj>" (* TODO? *)
46
module Make_menus (Params : sig
47
val st : State.globalState
48
val packing : [ `toolbar of GButton.toolbar | `menu_parent of Menu_factory.menu_parent ]
53
module Toolbar_entry = struct
54
let imagefile = "ico.hub.palette.png"
55
let tooltip = (s_ "Hub")
56
let packing = Params.packing
62
let key = Some GdkKeysyms._H
64
let ok_callback t = Gui_bricks.Ok_callback.check_name t.name t.old_name st#network#name_exists t
67
let name = st#network#suggestedName "H" in
68
Dialog_add_or_update.make ~title:(s_ "Add hub") ~name ~ok_callback ()
70
let reaction { name = name; label = label; port_no = port_no } =
71
let action () = ignore (new User_level_hub.hub ~network:st#network ~name ~label ~port_no ()) in
72
st#network_change action ();
76
module Properties = struct
78
let dynlist () = st#network#get_nodes_that_can_startup ~devkind:`Hub ()
81
let d = (st#network#get_node_by_name name) in
82
let title = (s_ "Modify hub")^" "^name in
83
let label = d#get_label in
84
let port_no = d#get_port_no in
85
let port_no_min = st#network#port_no_lower_of (d :> User_level.node) in
86
Dialog_add_or_update.make ~title ~name ~label ~port_no ~port_no_min ~ok_callback:Add.ok_callback ()
88
let reaction { name = name; label = label; port_no = port_no; old_name = old_name; } =
89
let d = (st#network#get_node_by_name old_name) in
90
let h = ((Obj.magic d):> User_level_hub.hub) in
91
let action () = h#update_with ~name ~label ~port_no in
92
st#network_change action ();
96
module Remove = struct
97
type t = string (* just the name *)
98
let to_string = (Printf.sprintf "name = %s\n")
100
let dynlist = Properties.dynlist
103
Gui_bricks.Dialog.yes_or_cancel_question
105
~markup:(Printf.sprintf (f_ "Are you sure that you want to remove %s\nand all the cables connected to this %s?") name (s_ "hub"))
110
let d = (st#network#get_node_by_name name) in
111
let h = ((Obj.magic d):> User_level_hub.hub) in
112
let action () = h#destroy in
113
st#network_change action ();
117
module Startup = struct
118
type t = string (* just the name *)
119
let to_string = (Printf.sprintf "name = %s\n")
120
let dynlist = Properties.dynlist
121
let dialog = Menu_factory.no_dialog_but_simply_return_name
122
let reaction name = (st#network#get_node_by_name name)#startup
127
type t = string (* just the name *)
128
let to_string = (Printf.sprintf "name = %s\n")
129
let dynlist () = st#network#get_nodes_that_can_gracefully_shutdown ~devkind:`Hub ()
130
let dialog = Menu_factory.no_dialog_but_simply_return_name
131
let reaction name = (st#network#get_node_by_name name)#gracefully_shutdown
135
module Suspend = struct
136
type t = string (* just the name *)
137
let to_string = (Printf.sprintf "name = %s\n")
138
let dynlist () = st#network#get_nodes_that_can_suspend ~devkind:`Hub ()
139
let dialog = Menu_factory.no_dialog_but_simply_return_name
140
let reaction name = (st#network#get_node_by_name name)#suspend
144
module Resume = struct
145
type t = string (* just the name *)
146
let to_string = (Printf.sprintf "name = %s\n")
147
let dynlist () = st#network#get_nodes_that_can_resume ~devkind:`Hub ()
148
let dialog = Menu_factory.no_dialog_but_simply_return_name
149
let reaction name = (st#network#get_node_by_name name)#resume
153
module Create_entries =
154
Gui_toolbar_COMPONENTS_layouts.Layout_for_network_node (Params) (Toolbar_entry) (Add) (Properties) (Remove) (Startup) (Stop) (Suspend) (Resume)
156
(* Subscribe this kind of component to the network club: *)
157
st#network#subscribe_a_try_to_add_procedure Eval_forest_child.try_to_add_hub;
165
module Dialog_add_or_update = struct
167
(* This function may be useful for testing the widget creation without
168
recompiling the whole project. *)
173
?(port_no=Const.port_no_default)
174
?(port_no_min=Const.port_no_min)
175
?(port_no_max=Const.port_no_max)
176
?(help_callback=help_callback) (* defined backward with "WHERE" *)
177
?(ok_callback=(fun data -> Some data))
178
?(dialog_image_file=Initialization.Path.images^"ico.hub.dialog.png")
180
let old_name = name in
181
let (w,_,name,label) =
182
Gui_bricks.Dialog_add_or_update.make_window_image_name_and_label
184
~image_file:dialog_image_file
185
~image_tooltip:(s_ "Hub")
187
~name_tooltip:(s_ "Hub name. This name must be unique in the virtual network. Suggested: H1, H2, ... ")
192
let vbox = GPack.vbox ~homogeneous:false ~border_width:20 ~spacing:10 ~packing:w#vbox#add () in
194
Gui_bricks.make_form_with_labels
196
[(s_ "Ports number")]
200
~packing:(form#add_with_tooltip (s_ "Hub ports number"))
201
~lower:port_no_min ~upper:port_no_max ~step_incr:2
207
let get_widget_data () :'result =
208
let name = name#text in
209
let label = label#text in
210
let port_no = int_of_float port_no#value in
213
Data.port_no = port_no;
214
Data.old_name = old_name;
217
(* The result of make is the result of the dialog loop (of type 'result option): *)
218
Gui_bricks.Dialog_run.ok_or_cancel w ~ok_callback ~help_callback ~get_widget_data ()
225
let title = (s_ "ADD OR MODIFY A HUB") in
227
In this dialog window you can define the name of an Ethernet HUB \
228
and set parameters for it:\n\
229
- Label: a string appearing near the hub icon in the network graph; it may \
230
allow, for example, to know at a glance the Ethernet network realized by the device; \
231
this field is exclusively for graphic purposes, is not taken in consideration \
232
for the configuration.\n\
233
- Nb of Ports: the number of ports of the hub (default 4); this number must \
234
not be increased without a reason, because the number of processes needed for the \
235
device emulation is proportional to his ports number.")
236
in Simple_dialogs.help title msg
244
module Eval_forest_child = struct
246
let try_to_add_hub (network:User_level.network) ((root,childs):Xforest.tree) =
250
let name = List.assoc "name" attrs in
251
let port_no = int_of_string (List.assoc "port_no" attrs) in
252
Log.printf "Importing hub \"%s\" with %d ports...\n" name port_no;
253
let x = new User_level_hub.hub ~network ~name ~port_no () in
254
x#from_tree ("hub", attrs) childs;
255
Log.printf "Hub \"%s\" successfully imported.\n" name;
258
(* backward compatibility *)
259
| ("device", attrs) ->
260
let name = List.assoc "name" attrs in
261
let port_no = try int_of_string (List.assoc "eth" attrs) with _ -> Const.port_no_default in
262
let kind = List.assoc "kind" attrs in
265
Log.printf "Importing hub \"%s\" with %d ports...\n" name port_no;
266
let x = new User_level_hub.hub ~network ~name ~port_no () in
267
x#from_tree ("hub", attrs) childs; (* Just for the label... *)
268
Log.printf "This is an old project: we set the user port offset to 1...\n";
269
network#defects#change_port_user_offset ~device_name:name ~user_port_offset:1;
270
Log.printf "Hub \"%s\" successfully imported.\n" name;
278
end (* module Eval_forest_child *)
286
module User_level_hub = struct
295
object (self) inherit OoExtra.destroy_methods ()
298
User_level.node_with_ledgrid_and_defects
300
~name ?label ~devkind:`Hub
302
~port_no_min:Const.port_no_min
303
~port_no_max:Const.port_no_max
304
~user_port_offset:1 (* in order to have a perfect mapping with VDE *)
307
as self_as_node_with_ledgrid_and_defects
308
method ledgrid_label = "Hub"
309
method defects_device_type = "hub"
310
method polarity = User_level.MDI_X
311
method string_of_devkind = "hub"
313
method dotImg iconsize =
314
let imgDir = Initialization.Path.images in
315
(imgDir^"ico.hub."^(self#string_of_simulated_device_state)^"."^iconsize^".png")
317
(** Create the simulated device *)
318
method private make_simulated_device =
319
let hublet_no = self#get_port_no in
320
let unexpected_death_callback = self#destroy_because_of_unexpected_death in
321
((new Simulation_level_hub.hub
324
~unexpected_death_callback
325
()) :> User_level.node Simulation_level.device)
328
Forest.tree_of_leaf ("hub", [
329
("name" , self#get_name );
330
("label" , self#get_label);
331
("port_no" , (string_of_int self#get_port_no)) ;
334
method eval_forest_attribute = function
335
| ("name" , x ) -> self#set_name x
336
| ("label" , x ) -> self#set_label x
337
| ("port_no" , x ) -> self#set_port_no (int_of_string x)
338
| _ -> () (* Forward-comp. *)
342
end (* module User_level_hub *)
348
module Simulation_level_hub = struct
350
(** A hub: just a [hub_or_switch] with [hub = true] *)
351
class ['parent] hub =
354
?(last_user_visible_port_index:int option)
355
~unexpected_death_callback
358
inherit ['parent] Simulation_level.hub_or_switch
361
?last_user_visible_port_index
363
~unexpected_death_callback
366
method device_type = "hub"
369
end (* module Simulation_level_hub *)
371
(** Just for testing: *)
372
let test = Dialog_add_or_update.make
added
removed
hub.ml
