~ubuntu-branches/ubuntu/wily/marionnet/wily

 

exception ForbiddenTransition;;

let raise_forbidden_transition msg =

 raise ForbiddenTransition

;;

 

          let message =

            Printf.sprintf "enqueue_task_with_progress_bar: %s %s failed (%s)"

              verb self#get_name (Printexc.to_string e) in

          Simple_dialogs.warning message message ();

          Log.printf "!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\n";

        end));

        | None ->

            assert false)

 

  method create =

    (* This is invisible for the user: don't set the next state *)

    Task_runner.the_task_runner#schedule ~name:("create "^self#get_name) (fun () -> self#create_right_now)

 

  method (*private*) destroy_my_simulated_device =

    (* This is invisible for the user: don't set the next state *)

    Task_runner.the_task_runner#schedule ~name:("destroy "^self#get_name)(fun () -> self#destroy_right_now)

 

    self#set_next_simulated_device_state (Some DeviceOff);

    self#enqueue_task_with_progress_bar (s_ "Stopping") (fun () -> if self#can_gracefully_shutdown then self#gracefully_shutdown_right_now)

 

  method poweroff =

    self#set_next_simulated_device_state (Some DeviceOff);

    self#enqueue_task_with_progress_bar (s_ "Shutting down") (fun () -> if self#can_poweroff then self#poweroff_right_now)

  method (*private*) create_right_now =

    Recursive_mutex.with_mutex mutex

      (fun () ->

          self#get_name

          (List.length (self#get_involved_cables));

 

              (* An endpoint for cables linked to self was just added; we need to start some cables. *)

              ignore (List.map

                        (fun cable ->

                           cable#increment_alive_endpoint_no)

                        (self#get_involved_cables)))

 

 

  (** The unit parameter is needed: see how it's used in simulated_network: *)

  method private destroy_because_of_unexpected_death () =

    Recursive_mutex.with_mutex mutex

      (fun () ->

        (try

          self#destroy_right_now

        with e -> begin

            (Printexc.to_string e);

        end;

          self#set_next_simulated_device_state None)); (* don't show next-state icons for this *)

  method (*private*) destroy_right_now =

    Recursive_mutex.with_mutex mutex

      (fun () ->

        match !automaton_state, !simulated_device with

        | (DeviceOn | DeviceSleeping), Some(d) ->

               "  (destroying the on/sleeping device %s. Powering it off first...)\n"

               self#get_name;

             self#poweroff_right_now; (* non-gracefully *)

             self#destroy_right_now

        | NoDevice, None ->

             "  (destroying the already 'no-device' device %s. Doing nothing...)\n"

             self#get_name;

            () (* Do nothing, but don't fail. *)

        | DeviceOff, Some(d) ->

            ((* An endpoint for cables linked to self was just added; we

                may need to start some cables. *)

               "  (destroying the off device %s: decrementing its cables rc...)\n"

               self#get_name;

             List.iter

               (fun cable ->

                 cable#decrement_alive_endpoint_no;

                 )

               self#get_involved_cables;

             d#destroy; (* This is the a method from some object in Simulation_level *)

             simulated_device := None;

             automaton_state := NoDevice;

             self#set_next_simulated_device_state None;

        | _ ->

            raise_forbidden_transition "destroy_right_now"

        );

 

 

  method (*private*) startup_right_now =

        (* Don't startup ``incorrect'' devices. This is currently limited to cables of the

           wrong crossoverness which the user has defined by mistake: *)

        if self#is_correct then begin

          match !automaton_state, !simulated_device with

          | NoDevice, None ->

              self#create_right_now;

              self#startup_right_now

              )

 

             (d#startup;  (* This is the a method from some object in Simulation_level *)

              automaton_state := DeviceOn;

              self#set_next_simulated_device_state None;

              )

 

          | DeviceOn,  _ ->

 

          | _ -> raise_forbidden_transition "startup_right_now"

        end else begin

        end)

 

  method (*private*) suspend_right_now =

    Recursive_mutex.with_mutex mutex

      (fun () ->

        match !automaton_state, !simulated_device with

          DeviceOn, Some(d) ->

           (d#suspend; (* This is the a method from some object in Simulation_level *)

  method (*private*) resume_right_now =

    Recursive_mutex.with_mutex mutex

      (fun () ->

        match !automaton_state, !simulated_device with

        | DeviceSleeping, Some(d) ->

           (d#resume; (* This is the a method from some object in Simulation_level *)

    Recursive_mutex.with_mutex mutex

      (fun () ->

        let current_state = self#automaton_state_as_string in

          self#get_name

          current_state);

        match !automaton_state, !simulated_device with

            self#gracefully_shutdown_right_now)

 

        | NoDevice,  _ | DeviceOff, _ ->

 

        | _ -> raise_forbidden_transition "gracefully_shutdown_right_now")

 

  method (*private*) poweroff_right_now =

    Recursive_mutex.with_mutex mutex

      (fun () ->

        match !automaton_state, !simulated_device with

        | DeviceOn, Some(d) ->

           (d#shutdown; (* non-gracefully *)

             self#poweroff_right_now)

 

        | NoDevice,  _ | DeviceOff, _ ->

 

        | _ -> raise_forbidden_transition "poweroff_right_now")

 

  (** The global network. It's a pain to have to access this via a global variable

      define in Marionnet *)

  val network = network

  method virtual can_suspend : bool

  method virtual can_resume  : bool

  method virtual suspend : unit

  method virtual resume  : unit

end;;

        self#get_name

   with

   | true ->

         self#defects_device_type

         self#get_name

   | false ->

         ()

 

  method private destroy_my_defects =

    network#defects#remove_subtree_by_name self#get_name;

 

  method private defects_update_port_no new_port_no =

               busy_ports_indexes)

 

  method destroy_my_ledgrid : unit =

    (network#ledgrid_manager:Ledgrid_manager.ledgrid_manager)#destroy_device_ledgrid

      ~id:(self#id)

      ()

    Obj.magic

      (Printf.ksprintf

        (fun x-> let msg = self#banner^x in

                 failwith msg))

 

  (** A machine has a Linux filesystem *)

   let icon = self#history_icon in

   let name = self#get_name in

   match ((network#history:Treeview_history.t)#number_of_states_with_name name) > 0 with

   | false ->

      network#history#add_device

          ~name

        "Name"

        self#get_name

   with

   | false ->

      begin

      network#ifconfig#add_device

      end

 

  method destroy_my_ifconfig =

    network#ifconfig#remove_subtree_by_name self#get_name;

 

  method destroy_my_history =

    network#history#remove_device_tree self#get_name;

 

  method update_virtual_machine_with ~name ~port_no kernel =

 method  set_dotoptions x = dotoptions <- Some x

 

 method components : (component list) =

     (cables#get :> component list) (* CABLES MUST BE AT THE FINAL POSITION for marshaling !!!! *)

 

   match kind with

   | None        -> self#components

 method disjoint_union_of_nodes_and_cables : ((component * [`Node | `Cable]) list) =

   let xs = List.map (fun x -> x,`Node ) (nodes#get  :> component list)  in

   let ys = List.map (fun x -> x,`Cable) (cables#get :> component list)  in

    the task runner method [wait_for_all_currently_scheduled_tasks]. *)

 method reset ?(scheduled=false) () =

  begin

   (List.iter

      (fun cable -> try cable#destroy with _ -> ())

      cables#get);

   Log.printf "\tWait for all devices to terminate...\n";

   (** Make sure that all devices have actually been terminated before going

       on: we don't want them to lose filesystem access: *)

  end

 

 method destroy_process_before_quitting () =

  | false ->

      let ((nodename, attrs), _) = f in

        let name  = List.assoc "name" attrs in

        (* Forward-compatibility *)

 

 method names = (List.map (fun x->x#get_name) self#components)

 method get_component_by_name ?kind n =

   let components = self#components_of_kind ?kind () in

   try List.find (fun x->x#get_name=n) components with _ -> failwith ("get_component_by_name "^n)

 method involved_node_and_port_index_list =

   List.flatten (List.map (fun c->c#involved_node_and_port_index_list) cables#get)

 

 method get_node_names  =

   List.map (fun x->x#get_name) (nodes#get)

 

 method get_component_names_that_can_suspend_or_resume () : (string * [`Node|`Cable] * bool) list =

  ListExtra.filter_map

       let can_suspend = x#can_suspend in

       let can_resume  = lazy x#can_resume in

         else None)

    self#disjoint_union_of_nodes_and_cables

 

 (** List of direct cable names in the network *)

 method get_direct_cable_names  =

        (String.concat " , "

        (List.map (fun d->d#get_name^" ("^(d#string_of_devkind)^")") nodes#get))

        with _ -> ""

  (* show links *)

   let msg=try

        (String.concat "\n" (List.map (fun c->(c#show "\r\t\t  ")) cables#get))

        with _ -> ""

 

 

 (** {b Consider cable as Edge.edges} *)