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