1-- This file is covered by the Internet Software Consortium (ISC) License 2-- Reference: ../../License.txt 3 4package body AdaBase.Logger.Facility is 5 6 7 ------------------ 8 -- error_mode -- 9 ------------------ 10 function error_mode (facility : LogFacility) return Error_Modes 11 is 12 begin 13 return facility.prop_error_mode; 14 end error_mode; 15 16 17 ---------------------- 18 -- set_error_mode -- 19 ---------------------- 20 procedure set_error_mode (facility : out LogFacility; mode : Error_Modes) 21 is 22 begin 23 facility.prop_error_mode := mode; 24 end set_error_mode; 25 26 27 -------------------- 28 -- set_log_file -- 29 -------------------- 30 procedure set_log_file (facility : LogFacility; filename : String) is 31 begin 32 facility.listener_file.all.set_filepath (filename); 33 end set_log_file; 34 35 36 --------------------- 37 -- standard_logger -- 38 --------------------- 39 procedure standard_logger (facility : out LogFacility; 40 logger : TLogger; 41 action : TAction) 42 is 43 use type ALF.File_Logger_access; 44 use type ALS.Screen_Logger_access; 45 begin 46 case logger is 47 when screen => 48 case action is 49 when detach => 50 if facility.listener_screen = null then 51 raise ALREADY_DETACHED; 52 else 53 facility.listener_screen := null; 54 end if; 55 when attach => 56 if facility.listener_screen = null then 57 facility.listener_screen := logger_screen'Access; 58 else 59 raise ALREADY_ATTACHED; 60 end if; 61 end case; 62 when file => 63 case action is 64 when detach => 65 if facility.listener_file = null then 66 raise ALREADY_DETACHED; 67 else 68 facility.listener_file := null; 69 end if; 70 when attach => 71 if facility.listener_file = null then 72 facility.listener_file := logger_file'Access; 73 else 74 raise ALREADY_ATTACHED; 75 end if; 76 end case; 77 end case; 78 end standard_logger; 79 80 81 ---------------------------- 82 -- detach_custom_logger -- 83 ---------------------------- 84 procedure detach_custom_logger (facility : out LogFacility) 85 is 86 use type AL.BaseClass_Logger_access; 87 begin 88 if facility.listener_custom = null then 89 raise ALREADY_DETACHED; 90 else 91 facility.listener_custom := null; 92 end if; 93 end detach_custom_logger; 94 95 96 ---------------------------- 97 -- attach_custom_logger -- 98 ---------------------------- 99 procedure attach_custom_logger (facility : out LogFacility; 100 logger_access : AL.BaseClass_Logger_access) 101 is 102 use type AL.BaseClass_Logger_access; 103 begin 104 if facility.listener_custom = null then 105 facility.listener_custom := logger_access; 106 else 107 raise ALREADY_ATTACHED; 108 end if; 109 end attach_custom_logger; 110 111 112 ------------------- 113 -- log_nominal -- 114 ------------------- 115 procedure log_nominal (facility : LogFacility; 116 driver : Driver_Type; 117 category : Log_Category; 118 message : CT.Text) 119 is 120 use type AL.Screen.Screen_Logger_access; 121 use type AL.File.File_Logger_access; 122 use type AL.BaseClass_Logger_access; 123 begin 124 125 if facility.listener_screen /= null then 126 facility.listener_screen.all.set_information 127 (driver => driver, 128 category => category, 129 message => message); 130 facility.listener_screen.all.reaction; 131 end if; 132 133 if facility.listener_file /= null then 134 facility.listener_file.all.set_information 135 (driver => driver, 136 category => category, 137 message => message); 138 facility.listener_file.all.reaction; 139 end if; 140 141 if facility.listener_custom /= null then 142 facility.listener_custom.all.set_information 143 (driver => driver, 144 category => category, 145 message => message); 146 facility.listener_custom.all.reaction; 147 end if; 148 149 end log_nominal; 150 151 152 ------------------- 153 -- log_problem -- 154 ------------------- 155 procedure log_problem 156 (facility : LogFacility; 157 driver : Driver_Type; 158 category : Log_Category; 159 message : CT.Text; 160 error_msg : CT.Text := CT.blank; 161 error_code : Driver_Codes := 0; 162 sqlstate : SQL_State := stateless; 163 break : Boolean := False) 164 is 165 use type Error_Modes; 166 use type AL.Screen.Screen_Logger_access; 167 use type AL.File.File_Logger_access; 168 use type AL.BaseClass_Logger_access; 169 QND : constant String := CT.USS (message); 170 begin 171 if not break and then facility.prop_error_mode = silent 172 then 173 return; 174 end if; 175 176 if facility.listener_screen /= null then 177 facility.listener_screen.all.set_information 178 (driver => driver, 179 category => category, 180 message => message, 181 error_msg => error_msg, 182 error_code => error_code, 183 sqlstate => sqlstate); 184 facility.listener_screen.all.reaction; 185 end if; 186 187 if facility.listener_file /= null then 188 facility.listener_file.all.set_information 189 (driver => driver, 190 category => category, 191 message => message, 192 error_msg => error_msg, 193 error_code => error_code, 194 sqlstate => sqlstate); 195 facility.listener_file.all.reaction; 196 end if; 197 198 if facility.listener_custom /= null then 199 facility.listener_custom.all.set_information 200 (driver => driver, 201 category => category, 202 message => message, 203 error_msg => error_msg, 204 error_code => error_code, 205 sqlstate => sqlstate); 206 facility.listener_custom.all.reaction; 207 end if; 208 209 if break or else facility.prop_error_mode = raise_exception 210 then 211 raise ERRMODE_EXCEPTION with QND; 212 end if; 213 214 end log_problem; 215 216 217end AdaBase.Logger.Facility; 218