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