1--
2--  Copyright (c) 2009-2012,
3--  Reto Buerki, Adrian-Ken Rueegsegger
4--
5--  This file is part of Alog.
6--
7--  Alog is free software; you can redistribute it and/or modify
8--  it under the terms of the GNU Lesser General Public License as published
9--  by the Free Software Foundation; either version 2.1 of the License, or
10--  (at your option) any later version.
11--
12--  Alog is distributed in the hope that it will be useful,
13--  but WITHOUT ANY WARRANTY; without even the implied warranty of
14--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15--  GNU Lesser General Public License for more details.
16--
17--  You should have received a copy of the GNU Lesser General Public License
18--  along with Alog; if not, write to the Free Software
19--  Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
20--  MA  02110-1301  USA
21--
22
23with Ada.Text_IO;
24with Ada.Exceptions;
25with Ada.Strings.Unbounded;
26
27with Alog.Logger;
28
29package body Alog.Tasked_Logger is
30
31   use Ada.Strings.Unbounded;
32
33   procedure F_Dummy (Facility_Handle : Facilities.Handle) is null;
34   --  This procedure is needed to initialize the 'Current_Facility_Proc'
35   --  handle of type Facility_Update_Handle since that type is defined as
36   --  'not null'.
37
38   procedure Default_Handler
39     (Except : Ada.Exceptions.Exception_Occurrence;
40      Caller : Ada.Task_Identification.Task_Id);
41   --  Tasked logger default exception handling callback. Prints the calling
42   --  task's ID and exception information to stderr.
43
44   -------------------------------------------------------------------------
45
46   procedure Default_Handler
47     (Except : Ada.Exceptions.Exception_Occurrence;
48      Caller : Ada.Task_Identification.Task_Id)
49   is
50      use Ada.Task_Identification;
51   begin
52      Ada.Text_IO.Put_Line
53        (File => Ada.Text_IO.Current_Error,
54         Item => "Logging exception while processing request for task with ID "
55         & Image (T => Caller));
56      Ada.Text_IO.Put_Line
57        (File => Ada.Text_IO.Current_Error,
58         Item => Ada.Exceptions.Exception_Information (Except));
59   end Default_Handler;
60
61   -------------------------------------------------------------------------
62
63   task body Instance is
64      use type Ada.Task_Identification.Task_Id;
65
66      Except_Handler : Exceptions.Exception_Handler := Default_Handler'Access;
67      --  Exception handler callback, initialized to default handler.
68
69      Logsink               : Alog.Logger.Instance (Init => Init);
70      Current_Source        : Unbounded_String;
71      Current_Level         : Log_Level;
72      Current_Message       : Unbounded_String;
73      Current_Caller        : Ada.Task_Identification.Task_Id;
74      Current_Facility_Name : Unbounded_String;
75      Current_Facility_Proc : Facility_Update_Handle := F_Dummy'Access;
76   begin
77
78      Main_Loop :
79      loop
80         begin
81            select
82
83               -------------------------------------------------------------
84
85               accept Attach_Facility (Facility : Facilities.Handle) do
86                  Logsink.Attach_Facility (Facility => Facility);
87               end Attach_Facility;
88            or
89
90               -------------------------------------------------------------
91
92               accept Attach_Default_Facility do
93                  Logsink.Attach_Default_Facility;
94               end Attach_Default_Facility;
95            or
96
97               -------------------------------------------------------------
98
99               accept Detach_Facility (Name : String) do
100                  Logsink.Detach_Facility (Name => Name);
101               end Detach_Facility;
102            or
103
104               -------------------------------------------------------------
105
106               accept Detach_Default_Facility do
107                  Logsink.Detach_Default_Facility;
108               end Detach_Default_Facility;
109            or
110
111               -------------------------------------------------------------
112
113               accept Facility_Count (Count : out Natural) do
114                  Count := Logsink.Facility_Count;
115               end Facility_Count;
116            or
117
118               -------------------------------------------------------------
119
120               accept Update
121                 (Name    : String;
122                  Process : Facility_Update_Handle)
123               do
124                  Current_Facility_Name := To_Unbounded_String (Name);
125                  Current_Facility_Proc := Process;
126                  Current_Caller        := Instance.Update'Caller;
127               end Update;
128
129               begin
130                  Logsink.Update (Name    => To_String (Current_Facility_Name),
131                                  Process => Current_Facility_Proc);
132
133               exception
134                  when E : others =>
135                     Except_Handler (Except => E,
136                                     Caller => Current_Caller);
137               end;
138            or
139
140               -------------------------------------------------------------
141
142               accept Iterate (Process : Facility_Update_Handle) do
143                  Current_Facility_Proc := Process;
144                  Current_Caller        := Instance.Iterate'Caller;
145               end Iterate;
146
147               begin
148                  Logsink.Iterate (Process => Current_Facility_Proc);
149
150               exception
151                  when E : others =>
152                     Except_Handler (Except => E,
153                                     Caller => Current_Caller);
154               end;
155            or
156
157               -------------------------------------------------------------
158
159               accept Attach_Transform (Transform : Transforms.Handle) do
160                  Logsink.Attach_Transform (Transform => Transform);
161               end Attach_Transform;
162            or
163
164               -------------------------------------------------------------
165
166               accept Detach_Transform (Name : String) do
167                  Logsink.Detach_Transform (Name => Name);
168               end Detach_Transform;
169
170            or
171               -------------------------------------------------------------
172
173               accept Transform_Count (Count : out Natural) do
174                  Count := Logsink.Transform_Count;
175               end Transform_Count;
176
177            or
178
179               -------------------------------------------------------------
180
181               accept Clear do
182                  Logsink.Clear;
183               end Clear;
184            or
185
186               -------------------------------------------------------------
187
188               accept Log_Message
189                 (Level  : Log_Level;
190                  Msg    : String;
191                  Source : String := "";
192                  Caller : Ada.Task_Identification.Task_Id :=
193                    Ada.Task_Identification.Null_Task_Id)
194               do
195                  Current_Source  := To_Unbounded_String (Source);
196                  Current_Level   := Level;
197                  Current_Message := To_Unbounded_String (Msg);
198
199                  --  Log_Message'Caller can not be used as default parameter
200                  --  so we need to check for 'Null_Task_Id' instead.
201
202                  if Caller = Ada.Task_Identification.Null_Task_Id then
203                     Current_Caller := Log_Message'Caller;
204                  else
205                     Current_Caller := Caller;
206                  end if;
207               end Log_Message;
208
209               begin
210                  Logsink.Log_Message
211                    (Source => To_String (Current_Source),
212                     Level  => Current_Level,
213                     Msg    => To_String (Current_Message));
214
215               exception
216                  when E : others =>
217                     Except_Handler (Except => E,
218                                     Caller => Current_Caller);
219               end;
220
221            or
222
223               -------------------------------------------------------------
224
225               accept Shutdown;
226               exit Main_Loop;
227
228            or
229
230               -----------------------------------------------------------
231
232               accept Set_Except_Handler
233                 (Proc : Exceptions.Exception_Handler)
234               do
235                  Except_Handler := Proc;
236               end Set_Except_Handler;
237
238            or
239               terminate;
240            end select;
241
242            --  Exceptions raised during a rendezvous are raised here and in
243            --  the calling task. Catch and ignore it so the tasked logger does
244            --  not get terminated after an exception.
245
246         exception
247            when others =>
248               null;
249         end;
250      end loop Main_Loop;
251
252   end Instance;
253
254end Alog.Tasked_Logger;
255