ada/xmlada
0
0
Fork 0
mirror of https://github.com/AdaCore/xmlada.git synced 2026-02-12 12:30:28 -08:00
Code Issues Packages Projects Releases Wiki Activity
Files
master
xmlada/tests/sax/debug_readers.adb
Emmanuel Briot 53dc51bf5c Update copyright notices 
Change-Id: Iae1283292b460ead48dedc565d6f24259e497e69
2017-01-03 10:02:38 +01:00

615 lines
18 KiB
Ada
Raw Permalink Blame History

------------------------------------------------------------------------------
-- XML/Ada - An XML suite for Ada95 --
-- --
-- Copyright (C) 2004-2017, AdaCore --
-- --
-- This library is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
-- Software Foundation; either version 3, or (at your option) any later --
-- version. This library is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
------------------------------------------------------------------------------
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Unchecked_Deallocation;
with Ada.Strings.Unbounded;
with Sax.Readers; use Sax.Readers;
with Sax.Exceptions; use Sax.Exceptions;
with Sax.Locators; use Sax.Locators;
with Sax.Attributes; use Sax.Attributes;
with Sax.Models; use Sax.Models;
with Unicode.CES; use Unicode.CES;
with Unicode; use Unicode;
with Sax.Encodings; use Sax.Encodings;
with Input_Sources.Strings; use Input_Sources.Strings;
package body Debug_Readers is
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(String, String_Access);
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(String_List, String_List_Access);
procedure Free (List : in out String_List_Access);
-- Free the array and all the stored strings
function Location
(Handler : Debug_Reader'Class; Skip : Natural := 0) return String;
-- Return the current location.
-- Skip indicates the number of frames to skip in the saved locations
-- stack
----------
-- Free --
----------
procedure Free (List : in out String_List_Access) is
begin
if List /= null then
for L in List'Range loop
Unchecked_Free (List (L));
end loop;
Unchecked_Free (List);
end if;
end Free;
--------------
-- Location --
--------------
function Location
(Handler : Debug_Reader'Class; Skip : Natural := 0) return String
is
use Ada.Strings.Unbounded;
Result : Unbounded_String;
begin
for C in Handler.Saved_Locs'First + Skip .. Handler.Saved_Locs'Last loop
Result := Result
& "[entity expansion at " & Handler.Saved_Locs (C).all;
end loop;
for C in Handler.Saved_Locs'First + Skip .. Handler.Saved_Locs'Last loop
Result := Result & ']';
end loop;
if Handler.Color then
return ASCII.ESC & "[33m"
& To_String (Handler.Locator) & To_String (Result)
& ASCII.ESC & "[39m";
else
return To_String (Handler.Locator) & To_String (Result);
end if;
end Location;
----------------
-- Set_Silent --
----------------
procedure Set_Silent
(Handler : in out Debug_Reader; Silent : Boolean) is
begin
Handler.Silent := Silent;
end Set_Silent;
---------------
-- Set_Color --
---------------
procedure Set_Color
(Handler : in out Debug_Reader; Color : Boolean) is
begin
Handler.Color := Color;
end Set_Color;
-------------
-- Warning --
-------------
procedure Warning
(Handler : in out Debug_Reader;
Except : Sax.Exceptions.Sax_Parse_Exception'Class)
is
pragma Warnings (Off, Handler);
begin
Put_Line ("Sax.Warning ("
& Get_Message (Except) & ", at "
& To_String (Get_Location (Except)) & ')');
end Warning;
-----------
-- Error --
-----------
procedure Error
(Handler : in out Debug_Reader;
Except : Sax.Exceptions.Sax_Parse_Exception'Class)
is
pragma Warnings (Off, Handler);
begin
Put_Line ("Sax.Error ("
& Get_Message (Except) & ", at "
& To_String (Get_Location (Except)) & ')');
end Error;
-----------------
-- Fatal_Error --
-----------------
procedure Fatal_Error
(Handler : in out Debug_Reader;
Except : Sax.Exceptions.Sax_Parse_Exception'Class) is
begin
Put_Line ("Sax.Fatal_Error (" & Get_Message (Except) & ") at "
& Location (Handler));
Free (Handler.Saved_Locs);
Handler.Saved_Locs := new String_List'(1 .. 0 => null);
Fatal_Error (Reader (Handler), Except);
end Fatal_Error;
--------------------------
-- Set_Document_Locator --
--------------------------
procedure Set_Document_Locator
(Handler : in out Debug_Reader;
Loc : in out Sax.Locators.Locator) is
begin
if not Handler.Silent then
Put_Line ("Sax.Set_Document_Locator ()");
end if;
Handler.Locator := Loc;
end Set_Document_Locator;
--------------------
-- Start_Document --
--------------------
procedure Start_Document (Handler : in out Debug_Reader) is
begin
Handler.Saved_Locs := new String_List'(1 .. 0 => null);
if not Handler.Silent then
Put_Line ("Sax.Start_Document () at " & Location (Handler));
end if;
end Start_Document;
------------------
-- End_Document --
------------------
procedure End_Document (Handler : in out Debug_Reader) is
begin
if not Handler.Silent then
Put_Line ("Sax.End_Document () at " & Location (Handler));
Free (Handler.Saved_Locs);
end if;
end End_Document;
--------------------------
-- Start_Prefix_Mapping --
--------------------------
procedure Start_Prefix_Mapping
(Handler : in out Debug_Reader;
Prefix : Unicode.CES.Byte_Sequence;
URI : Unicode.CES.Byte_Sequence)
is
pragma Unmodified (Handler);
begin
if not Handler.Silent then
Put_Line ("Sax.Start_Prefix_Mapping (" & Prefix & ", " & URI
& ") at " & Location (Handler));
end if;
end Start_Prefix_Mapping;
------------------------
-- End_Prefix_Mapping --
------------------------
procedure End_Prefix_Mapping
(Handler : in out Debug_Reader; Prefix : Unicode.CES.Byte_Sequence)
is
pragma Unmodified (Handler);
begin
if not Handler.Silent then
Put_Line ("Sax.End_Prefix_Mapping (" & Prefix & ") at "
& Location (Handler));
end if;
end End_Prefix_Mapping;
-------------------
-- Start_Element --
-------------------
procedure Start_Element
(Handler : in out Debug_Reader;
Namespace_URI : Unicode.CES.Byte_Sequence := "";
Local_Name : Unicode.CES.Byte_Sequence := "";
Qname : Unicode.CES.Byte_Sequence := "";
Atts : Sax.Attributes.Attributes'Class)
is
pragma Unmodified (Handler);
begin
if not Handler.Silent then
Put ("Sax.Start_Element ("
& Namespace_URI & ", " & Local_Name & ", " & Qname);
for J in 0 .. Get_Length (Atts) - 1 loop
Put (", " & Get_Qname (Atts, J) & "='"
& Get_Value (Atts, J) & ''');
end loop;
Put_Line (") at " & Location (Handler));
end if;
end Start_Element;
-----------------
-- End_Element --
-----------------
procedure End_Element
(Handler : in out Debug_Reader;
Namespace_URI : Unicode.CES.Byte_Sequence := "";
Local_Name : Unicode.CES.Byte_Sequence := "";
Qname : Unicode.CES.Byte_Sequence := "")
is
pragma Unmodified (Handler);
begin
if not Handler.Silent then
Put_Line ("Sax.End_Element (" & Namespace_URI & ", "
& Local_Name & ", " & Qname & ") at " & Location (Handler));
end if;
end End_Element;
----------------
-- Characters --
----------------
procedure Characters
(Handler : in out Debug_Reader; Ch : Unicode.CES.Byte_Sequence)
is
pragma Unmodified (Handler);
begin
if not Handler.Silent then
Put_Line ("Sax.Characters (" & Ch & ','
& Integer'Image (Ch'Length) & ") at " & Location (Handler));
end if;
end Characters;
--------------------------
-- Ignorable_Whitespace --
--------------------------
procedure Ignorable_Whitespace
(Handler : in out Debug_Reader; Ch : Unicode.CES.Byte_Sequence)
is
pragma Unmodified (Handler);
Index : Natural := Ch'First;
C : Unicode_Char;
begin
if not Handler.Silent then
Put ("Sax.Ignorable_Whitespace (");
while Index <= Ch'Last loop
Encoding.Read (Ch, Index, C);
Put (Unicode_Char'Image (C));
end loop;
Put_Line (','
& Integer'Image (Ch'Length) & ") at "
& Location (Handler));
end if;
end Ignorable_Whitespace;
----------------------------
-- Processing_Instruction --
----------------------------
procedure Processing_Instruction
(Handler : in out Debug_Reader;
Target : Unicode.CES.Byte_Sequence;
Data : Unicode.CES.Byte_Sequence)
is
pragma Unmodified (Handler);
begin
if not Handler.Silent then
Put_Line ("Sax.Processing instruction (" & Target & ", '" & Data
& "') at " & Location (Handler));
end if;
end Processing_Instruction;
--------------------
-- Skipped_Entity --
--------------------
procedure Skipped_Entity
(Handler : in out Debug_Reader; Name : Unicode.CES.Byte_Sequence)
is
pragma Unmodified (Handler);
begin
if not Handler.Silent then
Put_Line ("Sax.Skipped_Entity (" & Name & ") at "
& Location (Handler));
end if;
end Skipped_Entity;
-------------
-- Comment --
-------------
procedure Comment
(Handler : in out Debug_Reader; Ch : Unicode.CES.Byte_Sequence)
is
pragma Unmodified (Handler);
begin
if not Handler.Silent then
Put_Line ("Sax.Comment (" & Ch & ") at "
& Location (Handler));
end if;
end Comment;
-----------------
-- Start_Cdata --
-----------------
procedure Start_Cdata (Handler : in out Debug_Reader) is
pragma Unmodified (Handler);
begin
if not Handler.Silent then
Put_Line ("Sax.Start_Cdata () at " & Location (Handler));
end if;
end Start_Cdata;
---------------
-- End_Cdata --
---------------
procedure End_Cdata (Handler : in out Debug_Reader) is
pragma Unmodified (Handler);
begin
if not Handler.Silent then
Put_Line ("Sax.End_Cdata () at " & Location (Handler));
end if;
end End_Cdata;
------------------
-- Start_Entity --
------------------
procedure Start_Entity
(Handler : in out Debug_Reader; Name : Unicode.CES.Byte_Sequence)
is
Tmp : String_List_Access;
begin
if not Handler.Silent then
Put_Line ("Sax.Start_Entity (" & Name & ") at "
& Location (Handler));
Tmp := new String_List'
(new String'(To_String (Handler.Locator))
& Handler.Saved_Locs.all);
Unchecked_Free (Handler.Saved_Locs);
Handler.Saved_Locs := Tmp;
end if;
end Start_Entity;
----------------
-- End_Entity --
----------------
procedure End_Entity
(Handler : in out Debug_Reader; Name : Unicode.CES.Byte_Sequence)
is
Tmp : String_List_Access;
begin
if not Handler.Silent then
Tmp := new String_List (1 .. Handler.Saved_Locs'Length - 1);
Tmp.all := Handler.Saved_Locs
(Handler.Saved_Locs'First + 1 .. Handler.Saved_Locs'Last);
Unchecked_Free (Handler.Saved_Locs);
Handler.Saved_Locs := Tmp;
Put_Line ("Sax.End_Entity (" & Name & ") at " & Location (Handler));
end if;
end End_Entity;
---------------
-- Start_DTD --
---------------
procedure Start_DTD
(Handler : in out Debug_Reader;
Name : Unicode.CES.Byte_Sequence;
Public_Id : Unicode.CES.Byte_Sequence := "";
System_Id : Unicode.CES.Byte_Sequence := "")
is
pragma Unmodified (Handler);
begin
if not Handler.Silent then
Put_Line ("Sax.Start_DTD (" & Name
& ", " & Public_Id
& ", " & System_Id & ") at "
& Location (Handler));
end if;
end Start_DTD;
-------------
-- End_DTD --
-------------
procedure End_DTD (Handler : in out Debug_Reader) is
pragma Unmodified (Handler);
begin
if not Handler.Silent then
Put_Line ("Sax.End_DTD () at " & Location (Handler));
end if;
end End_DTD;
--------------------------
-- Internal_Entity_Decl --
--------------------------
procedure Internal_Entity_Decl
(Handler : in out Debug_Reader;
Name : Unicode.CES.Byte_Sequence;
Value : Unicode.CES.Byte_Sequence)
is
pragma Unmodified (Handler);
begin
if not Handler.Silent then
Put_Line ("Sax.Internal_Entity_Decl ("
& Name & ", " & Value
& ") at " & Location (Handler));
end if;
end Internal_Entity_Decl;
--------------------------
-- External_Entity_Decl --
--------------------------
procedure External_Entity_Decl
(Handler : in out Debug_Reader;
Name : Unicode.CES.Byte_Sequence;
Public_Id : Unicode.CES.Byte_Sequence;
System_Id : Unicode.CES.Byte_Sequence)
is
pragma Unmodified (Handler);
begin
if not Handler.Silent then
Put_Line ("Sax.External_Entity_Decl ("
& Name & ", " & Public_Id
& ", " & System_Id
& ") at " & Location (Handler));
end if;
end External_Entity_Decl;
--------------------------
-- Unparsed_Entity_Decl --
--------------------------
procedure Unparsed_Entity_Decl
(Handler : in out Debug_Reader;
Name : Unicode.CES.Byte_Sequence;
System_Id : Unicode.CES.Byte_Sequence;
Notation_Name : Unicode.CES.Byte_Sequence)
is
pragma Unmodified (Handler);
begin
if not Handler.Silent then
Put_Line ("Sax.Unparsed_Entity_Decl ("
& Name & ", " & System_Id
& ", " & Notation_Name
& ") at " & Location (Handler));
end if;
end Unparsed_Entity_Decl;
------------------
-- Element_Decl --
------------------
procedure Element_Decl
(Handler : in out Debug_Reader;
Name : Unicode.CES.Byte_Sequence;
Model : Content_Model)
is
pragma Unmodified (Handler);
begin
if not Handler.Silent then
Put_Line ("Sax.Element_Decl ("
& Name & ", " & To_String (Model)
& ") at " & Location (Handler));
end if;
end Element_Decl;
-------------------
-- Notation_Decl --
-------------------
procedure Notation_Decl
(Handler : in out Debug_Reader;
Name : Unicode.CES.Byte_Sequence;
Public_Id : Unicode.CES.Byte_Sequence;
System_Id : Unicode.CES.Byte_Sequence)
is
pragma Unmodified (Handler);
begin
if not Handler.Silent then
Put_Line ("Sax.Notation_Decl ("
& Name & ", " & Public_Id
& ", " & System_Id & ") at "
& Location (Handler));
end if;
end Notation_Decl;
--------------------
-- Attribute_Decl --
--------------------
procedure Attribute_Decl
(Handler : in out Debug_Reader;
Ename : Unicode.CES.Byte_Sequence;
Aname : Unicode.CES.Byte_Sequence;
Typ : Attribute_Type;
Content : Content_Model;
Value_Default : Sax.Attributes.Default_Declaration;
Value : Unicode.CES.Byte_Sequence)
is
pragma Unmodified (Handler);
begin
if not Handler.Silent then
if Content /= Unknown_Model then
Put_Line ("Sax.Attribute_Decl ("
& Ename & ", " & Aname
& ", " & Attribute_Type'Image (Typ) & ", "
& To_String (Content)
& ", " & Default_Declaration'Image (Value_Default)
& ", " & Value & ") at " & Location (Handler));
else
Put_Line ("Sax.Attribute_Decl ("
& Ename & ", " & Aname
& ", " & Attribute_Type'Image (Typ) & ", "
& Default_Declaration'Image (Value_Default)
& ", " & Value & ") at " & Location (Handler));
end if;
end if;
end Attribute_Decl;
--------------------
-- Resolve_Entity --
--------------------
function Resolve_Entity
(Handler : Debug_Reader;
Public_Id : Unicode.CES.Byte_Sequence;
System_Id : Unicode.CES.Byte_Sequence)
return Input_Sources.Input_Source_Access is
begin
if not Handler.Silent then
Put_Line ("Sax.Resolve_Entity ("
& Public_Id & ", " & System_Id
& ") at " & Location (Handler, Skip => 1));
end if;
if System_Id = "t3.xml" then
declare
S : constant String_Input_Access := new String_Input;
begin
Open (new Byte_Sequence'("Virtual_t3.xml_file"),
Sax.Encodings.Encoding, S.all);
return Input_Sources.Input_Source_Access (S);
end;
end if;
return null;
end Resolve_Entity;
end Debug_Readers;
Reference in New Issue View Git Blame Copy Permalink