1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114 | with
lace.Event,
lace.Subject,
lace.Observer;
private
with
ada.Containers.Vectors,
ada.Containers.indefinite_hashed_Maps;
generic
type T is abstract tagged limited private;
package lace.make_Subject
--
-- Makes a user class T into an event Subject.
--
is
pragma remote_Types;
type Item is abstract limited new T
and Subject.item with private;
type View is access all Item'Class;
procedure destroy (Self : in out Item);
-------------
-- Attributes
--
overriding
function Observers (Self : in Item; of_Kind : in Event.Kind) return Subject.Observer_views;
overriding
function observer_Count (Self : in Item) return Natural;
-------------
-- Operations
--
overriding
procedure register (Self : access Item; the_Observer : in Observer.view;
of_Kind : in Event.Kind);
overriding
procedure deregister (Self : in out Item; the_Observer : in Observer.view;
of_Kind : in Event.Kind);
overriding
procedure emit (Self : access Item; the_Event : in Event.item'Class := Event.null_Event);
overriding
function emit (Self : access Item; the_Event : in Event.item'Class := Event.null_Event)
return subject.Observer_views;
private
-------------------------
-- Event observer vectors
--
use type Observer.view;
package event_Observer_Vectors is new ada.Containers.Vectors (Positive, Observer.view);
subtype event_Observer_Vector is event_Observer_Vectors.Vector;
type event_Observer_Vector_view is access all event_Observer_Vector;
-------------------------------------
-- Event kind Maps of event observers
--
use type Event.Kind;
package event_kind_Maps_of_event_observers is new ada.Containers.indefinite_hashed_Maps (Event.Kind,
event_Observer_Vector_view,
Event.Hash,
"=");
subtype event_kind_Map_of_event_observers is event_kind_Maps_of_event_observers.Map;
-----------------
-- Safe observers
--
protected
type safe_Observers
is
procedure destruct;
procedure add (the_Observer : in Observer.view;
of_Kind : in Event.Kind);
procedure rid (the_Observer : in Observer.view;
of_Kind : in Event.Kind);
function fetch_Observers (of_Kind : in Event.Kind) return Subject.Observer_views;
function observer_Count return Natural;
private
the_Observers : event_kind_Map_of_event_observers;
end safe_Observers;
---------------
-- Subject Item
--
type Item is abstract limited new T
and Subject.item
with
record
safe_Observers : make_Subject.safe_Observers;
end record;
end lace.make_Subject;
|