1------------------------------------------------------------------------------
2--                                                                          --
3--                            Matreshka Project                             --
4--                                                                          --
5--                               XML Processor                              --
6--                                                                          --
7--                             Examples Component                           --
8--                                                                          --
9------------------------------------------------------------------------------
10--                                                                          --
11-- Copyright © 2010-2012, Vadim Godunko <vgodunko@gmail.com>                --
12-- All rights reserved.                                                     --
13--                                                                          --
14-- Redistribution and use in source and binary forms, with or without       --
15-- modification, are permitted provided that the following conditions       --
16-- are met:                                                                 --
17--                                                                          --
18--  * Redistributions of source code must retain the above copyright        --
19--    notice, this list of conditions and the following disclaimer.         --
20--                                                                          --
21--  * Redistributions in binary form must reproduce the above copyright     --
22--    notice, this list of conditions and the following disclaimer in the   --
23--    documentation and/or other materials provided with the distribution.  --
24--                                                                          --
25--  * Neither the name of the Vadim Godunko, IE nor the names of its        --
26--    contributors may be used to endorse or promote products derived from  --
27--    this software without specific prior written permission.              --
28--                                                                          --
29-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS      --
30-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT        --
31-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR    --
32-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT     --
33-- HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,   --
34-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED --
35-- TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR   --
36-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF   --
37-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING     --
38-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS       --
39-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.             --
40--                                                                          --
41------------------------------------------------------------------------------
42--  $Revision: 3459 $ $Date: 2012-11-21 11:08:42 +0400 (Wed, 21 Nov 2012) $
43------------------------------------------------------------------------------
44with League.IRIs;
45with Put_Line;
46with XML.SAX.Input_Sources.Streams.Files;
47
48package body Events_Printers is
49
50   use type League.Strings.Universal_String;
51
52   function Image (Item : XML.SAX.Locators.SAX_Locator)
53     return League.Strings.Universal_String;
54
55   ----------------
56   -- Characters --
57   ----------------
58
59   overriding procedure Characters
60    (Self    : in out Events_Printer;
61     Text    : League.Strings.Universal_String;
62     Success : in out Boolean) is
63   begin
64      Put_Line
65       (">>> (Characters) " & Image (Self.Locator) & ": '" & Text & "'");
66   end Characters;
67
68   -------------
69   -- Comment --
70   -------------
71
72   overriding procedure Comment
73    (Self    : in out Events_Printer;
74     Text    : League.Strings.Universal_String;
75     Success : in out Boolean) is
76   begin
77      Put_Line (">>> (Comment) " & Image (Self.Locator) & ": '" & Text & "'");
78   end Comment;
79
80   -----------------
81   -- End_Element --
82   -----------------
83
84   overriding procedure End_Element
85    (Self           : in out Events_Printer;
86     Namespace_URI  : League.Strings.Universal_String;
87     Local_Name     : League.Strings.Universal_String;
88     Qualified_Name : League.Strings.Universal_String;
89     Success        : in out Boolean) is
90   begin
91      Put_Line
92       (">>> (End_Element) "
93          & Image (Self.Locator)
94          & ": '"
95          & Namespace_URI
96          & "' '"
97          & Local_Name
98          & "' '"
99          & Qualified_Name
100          & "'");
101   end End_Element;
102
103   ------------------------
104   -- End_Prefix_Mapping --
105   ------------------------
106
107   overriding procedure End_Prefix_Mapping
108    (Self    : in out Events_Printer;
109     Prefix  : League.Strings.Universal_String;
110     Success : in out Boolean) is
111   begin
112      Put_Line
113       (">>> (End_Prefix_Mapping) "
114          & Image (Self.Locator)
115          & ": '"
116          & Prefix
117          & "'");
118   end End_Prefix_Mapping;
119
120   -----------
121   -- Error --
122   -----------
123
124   overriding procedure Error
125    (Self       : in out Events_Printer;
126     Occurrence : XML.SAX.Parse_Exceptions.SAX_Parse_Exception;
127     Success    : in out Boolean) is
128   begin
129      Put_Line
130       (">>> (Error) "
131          & Image (Self.Locator)
132          & ": '"
133          & Occurrence.Message
134          & "'");
135   end Error;
136
137   ------------------
138   -- Error_String --
139   ------------------
140
141   overriding function Error_String
142    (Self : Events_Printer)
143       return League.Strings.Universal_String is
144   begin
145      return X : League.Strings.Universal_String;
146   end Error_String;
147
148   ---------------------------------
149   -- External_Entity_Declaration --
150   ---------------------------------
151
152   overriding procedure External_Entity_Declaration
153    (Self      : in out Events_Printer;
154     Name      : League.Strings.Universal_String;
155     Public_Id : League.Strings.Universal_String;
156     System_Id : League.Strings.Universal_String;
157     Success   : in out Boolean) is
158   begin
159      Put_Line
160       (">>> (External_Entity_Declaration) "
161          & Image (Self.Locator)
162          & ": '"
163          & Name & "' => '" & Public_Id & "' '" & System_Id & "'");
164   end External_Entity_Declaration;
165
166   -----------------
167   -- Fatal_Error --
168   -----------------
169
170   overriding procedure Fatal_Error
171    (Self       : in out Events_Printer;
172     Occurrence : XML.SAX.Parse_Exceptions.SAX_Parse_Exception) is
173   begin
174      Put_Line
175       (">>> (Fatal_Error) "
176          & Image (Self.Locator)
177          & ": '"
178          & Occurrence.Message
179          & "'");
180   end Fatal_Error;
181
182   --------------------------
183   -- Ignorable_Whitespace --
184   --------------------------
185
186   overriding procedure Ignorable_Whitespace
187    (Self    : in out Events_Printer;
188     Text    : League.Strings.Universal_String;
189     Success : in out Boolean) is
190   begin
191      Put_Line
192       (">>> (Ignorable_Whitespace) "
193          & Image (Self.Locator)
194          & ": '"
195          & Text
196          & "'");
197   end Ignorable_Whitespace;
198
199   -----------
200   -- Image --
201   -----------
202
203   function Image (Item : XML.SAX.Locators.SAX_Locator)
204     return League.Strings.Universal_String
205   is
206      L : constant Wide_Wide_String := Natural'Wide_Wide_Image (Item.Line);
207      C : constant Wide_Wide_String := Natural'Wide_Wide_Image (Item.Column);
208
209   begin
210      return
211        League.Strings.To_Universal_String
212         (L (L'First + 1 .. L'Last)
213            & ':'
214            & C (C'First + 1 .. C'Last));
215   end Image;
216
217   ---------------------------------
218   -- Internal_Entity_Declaration --
219   ---------------------------------
220
221   overriding procedure Internal_Entity_Declaration
222    (Self    : in out Events_Printer;
223     Name    : League.Strings.Universal_String;
224     Value   : League.Strings.Universal_String;
225     Success : in out Boolean) is
226   begin
227      Put_Line
228       (">>> (Internal_Entity_Declaration) "
229          & Image (Self.Locator)
230          & ": '"
231          & Name
232          & "' => '"
233          & Value
234          & "'");
235   end Internal_Entity_Declaration;
236
237   ----------------------------
238   -- Processing_Instruction --
239   ----------------------------
240
241   overriding procedure Processing_Instruction
242    (Self    : in out Events_Printer;
243     Target  : League.Strings.Universal_String;
244     Data    : League.Strings.Universal_String;
245     Success : in out Boolean) is
246   begin
247      Put_Line
248       (">>> (Processing_Instruction) "
249          & Image (Self.Locator)
250          & ": '"
251          & Target
252          & "' '"
253          & Data
254          & "'");
255   end Processing_Instruction;
256
257   --------------------
258   -- Resolve_Entity --
259   --------------------
260
261   overriding procedure Resolve_Entity
262    (Self      : in out Events_Printer;
263     Name      : League.Strings.Universal_String;
264     Public_Id : League.Strings.Universal_String;
265     Base_URI  : League.Strings.Universal_String;
266     System_Id : League.Strings.Universal_String;
267     Source    : out XML.SAX.Input_Sources.SAX_Input_Source_Access;
268     Success   : in out Boolean)
269   is
270      use XML.SAX.Input_Sources.Streams.Files;
271
272   begin
273      Source := new File_Input_Source;
274      File_Input_Source'Class (Source.all).Open_By_URI
275       (League.IRIs.From_Universal_String (Base_URI).Resolve
276         (League.IRIs.From_Universal_String (System_Id)).To_Universal_String);
277   end Resolve_Entity;
278
279   --------------------------
280   -- Set_Document_Locator --
281   --------------------------
282
283   overriding procedure Set_Document_Locator
284    (Self    : in out Events_Printer;
285     Locator : XML.SAX.Locators.SAX_Locator) is
286   begin
287      Self.Locator := Locator;
288   end Set_Document_Locator;
289
290   -------------------
291   -- Start_Element --
292   -------------------
293
294   overriding procedure Start_Element
295    (Self           : in out Events_Printer;
296     Namespace_URI  : League.Strings.Universal_String;
297     Local_Name     : League.Strings.Universal_String;
298     Qualified_Name : League.Strings.Universal_String;
299     Attributes     : XML.SAX.Attributes.SAX_Attributes;
300     Success        : in out Boolean) is
301   begin
302      Put_Line
303       (">>> (Start_Element) "
304          & Image (Self.Locator)
305          & ": '"
306          & Namespace_URI
307          & "' '"
308          & Local_Name
309          & "' '"
310          & Qualified_Name
311          & "'");
312
313      for J in 1 .. Attributes.Length loop
314         Put_Line
315          ("                    '" & Attributes.Namespace_URI (J)
316             & "' '" & Attributes.Local_Name (J)
317             & "' '" & Attributes.Qualified_Name (J)
318             & "' '" & Attributes.Value (J) & "'");
319      end loop;
320   end Start_Element;
321
322   --------------------------
323   -- Start_Prefix_Mapping --
324   --------------------------
325
326   overriding procedure Start_Prefix_Mapping
327    (Self          : in out Events_Printer;
328     Prefix        : League.Strings.Universal_String;
329     Namespace_URI : League.Strings.Universal_String;
330     Success       : in out Boolean) is
331   begin
332      Put_Line
333       (">>> (Start_Prefix_Mapping) "
334          & Image (Self.Locator)
335          & ": '"
336          & Prefix
337          & "' => '"
338          & Namespace_URI
339          & "'");
340   end Start_Prefix_Mapping;
341
342   ---------------------------------
343   -- Unparsed_Entity_Declaration --
344   ---------------------------------
345
346   overriding procedure Unparsed_Entity_Declaration
347    (Self          : in out Events_Printer;
348     Name          : League.Strings.Universal_String;
349     Public_Id     : League.Strings.Universal_String;
350     System_Id     : League.Strings.Universal_String;
351     Notation_Name : League.Strings.Universal_String;
352     Success       : in out Boolean) is
353   begin
354      Put_Line
355       (">>> (Unparsed_Entity_Declaration) "
356          & Image (Self.Locator)
357          & ": '"
358          & Name
359          & "' => '"
360          & Public_Id
361          & "' '"
362          & System_Id
363          & "' '"
364          & Notation_Name
365          & "'");
366   end Unparsed_Entity_Declaration;
367
368   -------------
369   -- Warning --
370   -------------
371
372   overriding procedure Warning
373    (Self       : in out Events_Printer;
374     Occurrence : XML.SAX.Parse_Exceptions.SAX_Parse_Exception;
375     Success    : in out Boolean) is
376   begin
377      Put_Line
378       (">>> (Warning) "
379          & Image (Self.Locator)
380          & ": '"
381          & Occurrence.Message
382          & "'");
383   end Warning;
384
385end Events_Printers;
386