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
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136 | with
lace.Event.Logger.text,
ada.unchecked_Deallocation,
system.RPC;
package body lace.Event.utility
is
--------------
-- Event Kinds
--
function to_Kind (From : in ada.Tags.Tag) return lace.Event.Kind
is
begin
return event.Kind (ada.Tags.external_Tag (From));
end to_Kind;
function Name_of (Kind : in Event.Kind) return String
is
begin
return String (Kind);
end Name_of;
---------
-- Events
--
function Kind_of (the_Event : in Event.item'Class) return Event.Kind
is
begin
return to_Kind (the_Event'Tag);
end Kind_of;
function Name_of (the_Event : in Event.item'Class) return String
is
begin
return Name_of (Kind_of (the_Event));
end Name_of;
--------------
-- Connections
--
procedure connect (the_Observer : in Observer.view;
to_Subject : in Subject .view;
with_Response : in Response.view;
to_Event_Kind : in Event.Kind)
is
begin
the_Observer.add (with_Response,
to_Event_Kind,
to_Subject.Name);
to_Subject.register (the_Observer,
to_Event_Kind);
end connect;
procedure disconnect (the_Observer : in Observer.view;
from_Subject : in Subject .view;
for_Response : in Response.view;
to_Event_Kind : in Event.Kind;
Subject_Name : in String)
is
begin
begin
the_Observer.rid (for_Response,
to_Event_Kind,
Subject_Name);
exception
when storage_Error =>
null; -- The observer is dead.
end;
begin
from_Subject.deregister (the_Observer,
to_Event_Kind);
exception
when system.RPC.communication_Error
| storage_Error =>
null; -- The subject is dead.
end;
end disconnect;
----------
-- Logging
--
the_Logger : Event.Logger.text.view;
procedure use_text_Logger (log_Filename : in String)
is
begin
the_Logger := new Event.Logger.text.item' (Event.Logger.text.to_Logger (log_Filename));
lace.Subject .Logger_is (the_Logger.all'Access);
lace.Observer.Logger_is (the_Logger.all'Access);
end use_text_Logger;
function Logger return lace.event.Logger.view
is
begin
return the_Logger.all'Access;
end Logger;
--------------
-- Termination
--
procedure close
is
use type Event.Logger.text.view;
begin
if the_Logger /= null
then
declare
procedure deallocate is new ada.unchecked_Deallocation (Event.Logger.text.item'Class,
Event.Logger.text.view);
begin
the_Logger.destruct;
deallocate (the_Logger);
end;
end if;
end close;
end lace.Event.utility;
|