1. with Ada.Strings.Hash_Case_Insensitive; 
  2. with Events.Listeners;                  use Events.Listeners; 
  3. with Processes;                         use Processes; 
  4.  
  5. private with Ada.Containers.Doubly_Linked_Lists; 
  6. private with Ada.Containers.Indefinite_Hashed_Maps; 
  7. private with Mutable_Lists; 
  8.  
  9. package Events.Corrals is 
  10.  
  11.     -- An event Corral is an object for Event_Listener objects to register with, 
  12.     -- to receive events. A Corral in turn registers with the global event 
  13.     -- manager to receive the events for which it has registered listeners. All 
  14.     -- listeners attached to a Corral are serviced by the same event dispatching 
  15.     -- thread. Corrals are necessary to allow events to be dispatched from the 
  16.     -- global event manager thread and processed in different Process_Manager 
  17.     -- processes simultaneously. Each Process_Manager (which is backed by a 
  18.     -- single thread), must have its own event Corral. Note that a Corral 
  19.     -- implements the Process interface. It is meant to be attached to a 
  20.     -- Process_Manager and executed incrementally with other Process objects. 
  21.     type Corral is new Limited_Object and Process with private; 
  22.     type A_Corral is access all Corral'Class; 
  23.  
  24.     -- Creates a new corral to receive events from the global event manager. 
  25.     function Create_Corral( name : String ) return A_Corral; 
  26.     pragma Precondition( name'Length > 0 ); 
  27.     pragma Postcondition( Create_Corral'Result /= null ); 
  28.  
  29.     -- Registers an object as a listener for a specific type of event. Listeners 
  30.     -- will receive all events sent to this corral unless the event has been 
  31.     -- consumed by an earlier registered handler that wants to prevent an event 
  32.     -- from propagating. Event listeners are notified in the order in which they 
  33.     -- register with the corral. 
  34.     procedure Add_Listener( this     : not null access Corral'Class; 
  35.                             listener : not null A_Event_Listener; 
  36.                             evtName  : String ); 
  37.     pragma Precondition( evtName'Length > 0 ); 
  38.  
  39.     -- Returns the name of the corral. 
  40.     function Get_Name( this : not null access Corral'Class ) return String; 
  41.     pragma Postcondition( Get_Name'Result'Length > 0 ); 
  42.  
  43.     -- Queue an event to be dispatched to all the registered listener objects. 
  44.     -- The event will be consumed. 
  45.     procedure Queue_Event( this : not null access Corral'Class; 
  46.                            evt  : in out A_Event ); 
  47.     pragma Precondition( evt /= null ); 
  48.     pragma Postcondition( evt = null ); 
  49.  
  50.     -- Unregisters an object as a listener for a specific type of event. If the 
  51.     -- listener was not previously registered, this has no effect. 
  52.     procedure Remove_Listener( this     : not null access Corral'Class; 
  53.                                listener : not null A_Event_Listener; 
  54.                                evtName  : String ); 
  55.     pragma Precondition( evtName'Length > 0 ); 
  56.  
  57.     -- Dispatches an event immediately and sychronously, separate from the 
  58.     -- queue. The Event_Listener that handles the event may choose to return a 
  59.     -- response to the caller via 'response'. The event 'evt' will be consumed. 
  60.     procedure Trigger_Event( this     : not null access Corral'Class; 
  61.                              evt      : in out A_Event; 
  62.                              response : out Response_Type ); 
  63.     pragma Precondition( evt /= null ); 
  64.     pragma Postcondition( evt = null ); 
  65.  
  66.     -- Deletes the Corral. 
  67.     procedure Delete( this : in out A_Corral ); 
  68.     pragma Postcondition( this = null ); 
  69.  
  70. private 
  71.  
  72.     -- A broker acts as a queueable go-between object that brokers the exchange 
  73.     -- between a calling thread and an event dispatching thread. The calling 
  74.     -- thread puts an event into the broker, inserts it into the corral's event 
  75.     -- thread, and waits for the corral's dispatching thread to get around to 
  76.     -- dispatching the event and returning a response via the broker. 
  77.     protected type Broker_Type is 
  78.  
  79.         -- Set's the broker's event, consuming it. If an event has already been 
  80.         -- set, the first event will be preserved and the second event, 'evt' in 
  81.         -- this case, will be ignored and deleted. 
  82.         procedure Put_Event( evt : in out A_Event ); 
  83.         pragma Postcondition( evt = null ); 
  84.  
  85.         -- Retrieves the broker's event. This can only be called once because 
  86.         -- the internal pointer is cleared when the event is returned. The 
  87.         -- returned event, 'evt', belongs to the caller. 
  88.         procedure Take_Event( evt : in out A_Event ); 
  89.         pragma Precondition( evt = null ); 
  90.  
  91.         -- Sets the response to be returned by Get_Response and allows any 
  92.         -- callers waiting on Get_Response to proceed. 
  93.         procedure Set_Response( response : Response_Type ); 
  94.  
  95.         -- Returns the Event_Listeners's response. This will block until 
  96.         -- Set_Response has been called. 
  97.         entry Get_Response( response : out Response_Type ); 
  98.  
  99.     private 
  100.         my_event    : A_Event := null; 
  101.         my_response : Response_Type := No_Response; 
  102.         initialized : Boolean := False; 
  103.         complete    : Boolean := False; 
  104.     end Broker_Type; 
  105.     type A_Broker is access all Broker_Type; 
  106.  
  107.     -- Creates a Broker object for 'evt', consuming it. 
  108.     procedure Create_Broker( evt : in out A_Event; broker : out A_Broker ); 
  109.     pragma Precondition( evt /= null ); 
  110.     pragma Postcondition( evt = null ); 
  111.     pragma Postcondition( broker /= null ); 
  112.  
  113.     -- Deletes the Broker object. 
  114.     procedure Delete( broker : in out A_Broker ); 
  115.     pragma Postcondition( broker = null ); 
  116.  
  117.     ---------------------------------------------------------------------------- 
  118.  
  119.     package Broker_Lists is new Ada.Containers.Doubly_Linked_Lists( A_Broker, "=" ); 
  120.     use Broker_Lists; 
  121.  
  122.     package Event_Lists is new Ada.Containers.Doubly_Linked_Lists( A_Event, "=" ); 
  123.     use Event_Lists; 
  124.  
  125.     -- An Event_Queue is a protected FIFO queue of Events. Events can jump to 
  126.     -- the front of the line for synchronous dispatching by being encapsulated 
  127.     -- in a broker object. 
  128.     protected type Event_Queue is 
  129.  
  130.         -- Adds a brokered event to the queue. Brokered events take precedence 
  131.         -- over any other asynchronous events in the queue. 
  132.         procedure Add( broker : A_Broker ); 
  133.  
  134.         -- Adds an event to the end of the queue for asynchronous dispatching. 
  135.         procedure Add( evt : in out A_Event ); 
  136.         pragma Precondition( evt /= null ); 
  137.         pragma Postcondition( evt = null ); 
  138.  
  139.         -- Marks an event frame. All events that were queued prior to this 
  140.         -- marker will be dispatched before the Corral Process returns execution 
  141.         -- to its Process_Manager. Any events added after this point will be 
  142.         -- dispatched in the next Process tick. 
  143.         procedure Mark_Frame; 
  144.  
  145.         -- Removes the first brokered event to be synchronously dispatched. If 
  146.         -- no brokered events are waiting then null will be returned. 
  147.         procedure Remove( broker : out A_Broker ); 
  148.  
  149.         -- Removes the next event on the queue. If the frame marker is reached 
  150.         -- or the queue is begin shutdown, then null will be returned. 
  151.         procedure Remove( evt : out A_Event ); 
  152.  
  153.         -- Shuts down the event queue, deleting all pending events and 
  154.         -- preventing any further from being queued. 
  155.         procedure Shutdown; 
  156.  
  157.     private 
  158.         queue     : Event_Lists.List; 
  159.         brokers   : Broker_Lists.List; 
  160.         remaining : Integer := 0;       -- queued events remaining in the frame 
  161.         stopped   : Boolean := False; 
  162.     end Event_Queue; 
  163.  
  164.     ---------------------------------------------------------------------------- 
  165.  
  166.     package Listener_Lists is new Mutable_Lists( A_Event_Listener, "=" ); 
  167.     use Listener_Lists; 
  168.  
  169.     -- A Listener_List is a list of Event_Listeners which are all registered 
  170.     -- with a Corral for the same Event. 
  171.     type Listener_List is tagged 
  172.         record 
  173.             corral    : A_Corral := null; 
  174.             name      : Unbounded_String; 
  175.             listeners : access Listener_Lists.List := new Listener_Lists.List; 
  176.         end record; 
  177.     type A_Listener_List is access all Listener_List'Class; 
  178.  
  179.     -- Adds the listener to the list and registers the list's corral with 
  180.     -- the event manager if the list was empty. 
  181.     procedure Add( this     : not null access Listener_List'Class; 
  182.                    listener : not null A_Event_Listener ); 
  183.  
  184.     -- Synchronously notifies each listener in the list until the event is 
  185.     -- consumed. The response is returned from the last event listener to 
  186.     -- be notified, or contains error information if an exception was 
  187.     -- raised by the last listener to be notified. 
  188.     procedure Call( this     : not null access Listener_List'Class; 
  189.                     evt      : in out A_Event; 
  190.                     response : out Response_Type ); 
  191.  
  192.     -- Clears the listener list and unregisters the list's corral with the 
  193.     -- event manager. 
  194.     procedure Clear( this : not null access Listener_List'Class ); 
  195.  
  196.     -- Call this with the listener list's owning corral and the event name that 
  197.     -- the list is associated with at time of object creation. 
  198.     procedure Construct( this    : access Listener_List; 
  199.                          owner   : not null A_Corral; 
  200.                          evtName : String ); 
  201.  
  202.     -- Removes the listener from the list and unregisters the list's corral 
  203.     -- with the event manager if the list is now empty. 
  204.     procedure Remove( this     : not null access Listener_List'Class; 
  205.                       listener : not null A_Event_Listener ); 
  206.  
  207.     ---------------------------------------------------------------------------- 
  208.  
  209.     package Type_Map is new 
  210.         Ada.Containers.Indefinite_Hashed_Maps( String, 
  211.                                                A_Listener_List, 
  212.                                                Ada.Strings.Hash_Case_Insensitive, 
  213.                                                "=", "=" ); 
  214.     use Type_Map; 
  215.  
  216.     -- A Listener_Registry is a protected object that manages a map of event 
  217.     -- names to their corresponding registered Event_Listener lists. 
  218.     protected type Listener_Registry is 
  219.  
  220.         -- Clears all event listener lists in the registry. 
  221.         procedure Clear; 
  222.  
  223.         -- Returns a reference to the list of event listeners for the given 
  224.         -- event name. If no listeners have been registered for the name yet, an 
  225.         -- empty list is returned. The reference to the listener list that is 
  226.         -- returned is owned by the listener registry. Do not delete it. 
  227.         procedure Get_List( evtName : String; list : out A_Listener_List ); 
  228.  
  229.         -- Call this with the listener registry's owning corral at time of 
  230.         -- object creation to initialize/construct the Listener_Registry. 
  231.         procedure Init( owner : not null A_Corral ); 
  232.  
  233.     private 
  234.         corral   : A_Corral := null; 
  235.         registry : Type_Map.Map; 
  236.     end Listener_Registry; 
  237.  
  238.     ---------------------------------------------------------------------------- 
  239.  
  240.     type Corral is new Limited_Object and Process with 
  241.         record 
  242.             name      : Unbounded_String; 
  243.             listeners : access Listener_Registry := null; 
  244.             queue     : access Event_Queue := null; 
  245.         end record; 
  246.  
  247.     procedure Construct( this : access Corral; name : String ); 
  248.  
  249.     procedure Delete( this : in out Corral ); 
  250.  
  251.     -- Returns the name of the Process. 
  252.     function Get_Process_Name( this : access Corral ) return String; 
  253.  
  254.     -- Dispatches one frame of events from the event queue. 
  255.     procedure Tick( this : access Corral; time : Tick_Time ); 
  256.  
  257.     -- Returns a string representation of the Corral. 
  258.     function To_String( this : access Corral ) return String; 
  259.  
  260. end Events.Corrals;