------------------------------------------------------------------------------
-- XML/Ada - An XML suite for Ada95 --
-- --
-- Copyright (C) 2001-2020, 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 --
-- . --
-- --
------------------------------------------------------------------------------
pragma Ada_05;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with Input_Sources.File; use Input_Sources.File;
with Input_Sources.Strings; use Input_Sources.Strings;
with Input_Sources; use Input_Sources;
with Interfaces; use Interfaces;
with Sax.Attributes; use Sax.Attributes;
with Sax.Encodings; use Sax.Encodings;
with Sax.Exceptions; use Sax.Exceptions;
with Sax.Locators; use Sax.Locators;
with Sax.Models; use Sax.Models;
with Sax.Symbols; use Sax.Symbols;
with Unchecked_Deallocation;
with Unicode.CES; use Unicode.CES;
with Unicode.CES.Basic_8bit; use Unicode.CES.Basic_8bit;
with Unicode.Names.Basic_Latin; use Unicode.Names.Basic_Latin;
with Unicode; use Unicode;
package body Sax.Readers is
use Entity_Table, Attributes_Table, Notations_Table;
use Symbol_Table_Pointers;
Debug_Lexical : constant Boolean := False;
Debug_Input : constant Boolean := False;
Debug_Internal : constant Boolean := False;
-- Set to True if you want to debug this package
Initial_Buffer_Length : constant := 10000;
-- Initial length of the internal buffer that stores CDATA, tag names,...
--------------------
-- Error messages --
--------------------
-- The comment indicates the section of the XML or Namespaces specification
-- relevant for that error
Error_Attlist_DefaultDecl : constant String :=
"Invalid default declaration for the attribute"; -- 3.3.2
Error_Attlist_Invalid_Enum : constant String :=
"Invalid character ',' in ATTLIST enumeration"; -- 3.3.1
Error_Attlist_Type : constant String :=
"Invalid type for attribute"; -- WF
Error_Attribute_External_Entity : constant String :=
"Attribute values cannot reference external entities";
Error_Attribute_Is_Name : constant String :=
"Attribute must contain Names: "; -- NS 6 and 3.3.1
Error_Attribute_Is_Ncname : constant String :=
"Attribute must contain Names with no colon: "; -- NS 6 and 3.3.1
Error_Attribute_Is_Nmtoken : constant String :=
"Attribute must contain Nmtokens: "; -- 2.3 and 3.3.1
Error_Attribute_Less_Than : constant String :=
"'<' not authorized in attribute values"; -- 2.3
Error_Attribute_Less_Than_Suggests : constant String := -- 2.3
"'<' not authorized in attribute values. Possible end of value at ";
Error_Attribute_Ref_Unparsed_Entity : constant String :=
"Attribute must reference an existing unparsed entity: ";
Error_Cdata_End : constant String :=
"CDATA sections must end with ']]>'"; -- 2.7
Error_Cdata_Unterminated : constant String :=
"CDATA must be followed immediately by '['";
Error_Charref_Toplevel : constant String :=
"Character references cannot appear at top-level"; -- 2.1
Error_Charref_Invalid_Char : constant String :=
"Invalid character in character reference: "; -- 4.1
Error_Comment_End : constant String :=
"Comments must end with '-->'"; -- 2.5
Error_Comment_Unterminated : constant String :=
"Unterminated comment in stream"; -- WF
Error_Comment_Dash_Dash : constant String :=
"'--' cannot appear in comments"; -- 2.5
Error_Conditional_Location : constant String := -- 3.4
"INCLUDE and IGNORE sections only allowed in the external DTD subset";
Error_Conditional_Syntax : constant String :=
"Conditional sections need '[' after INCLUDE or IGNORE"; -- 3.4
Error_Content_Model_Closing_Paren : constant String :=
"Closing parenthesis must be followed by '*' in mixed content"; -- 3.2.2
Error_Content_Model_Empty_List : constant String :=
"Invalid content model: list of choices cannot be empty";
Error_Content_Model_Expect_Operator : constant String :=
"Expecting operator in content model";
Error_Content_Model_Invalid : constant String :=
"Invalid content model";
Error_Content_Model_Invalid_Multiplier : constant String :=
"Invalid location for '+', '?' or '*' operators"; -- 3.2.1
Error_Content_Model_Invalid_Name : constant String :=
"Invalid name in content model: ";
Error_Content_Model_Invalid_Seq : constant String :=
"Missing content particle in sequence"; -- 3.2.1
Error_Content_Model_Invalid_Start : constant String :=
"Invalid content model, cannot start with #";
Error_Content_Model_Mixing : constant String :=
"Cannot mix ',' and '|' in content model";
Error_Content_Model_Nested_Groups : constant String :=
"Nested groups and occurrence operators not allowed in mixed content";
-- 3.3.2
Error_Content_Model_Pcdata : constant String :=
"#PCDATA can only be used with '|' connectors"; -- 3.2.2
Error_Content_Model_Pcdata_First : constant String :=
"#PCDATA must be first in list"; -- 3.2.2
Error_Content_Model_Pcdata_Occurrence : constant String :=
"Occurrence on #PCDATA must be '*'"; -- 3.2.2
Error_Entity_Definition : constant String :=
"Invalid definition for ENTITY";
Error_Entity_Definition_Unterminated : constant String :=
"Expecting end of ENTITY definition";
Error_Entity_Name : constant String := "Invalid entity name"; -- 4.1
Error_Entity_Not_Standalone : constant String :=
"Entity declared in external subset, but document is standalone"; -- 4.1
Error_Entity_Self_Ref : constant String :=
"Entity cannot reference itself"; -- 4.1
Error_Entity_Toplevel : constant String :=
"Entity references cannot appear at top-level"; -- 2.1
Error_Entity_Undefined : constant String := "Undefined entity"; -- 4.1
Error_Entityref_Unterminated : constant String :=
"Entity references must end with ';'." & ASCII.LF
& "Did you want to use &?"; -- 4.1
Error_Entity_Nested : constant String :=
"Replacement text for entities must be properly nested"; -- 3.2.1
Error_Entity_Self_Contained : constant String :=
"Entity values must be self-contained"; -- 4.5 or 4.3.2
Error_Expecting_Space : constant String :=
"Expecting a space"; -- WF or 3.3
Error_External_Entity_Not_Found : constant String :=
"External entity not found: ";
Error_Invalid_Char : constant String :=
"Invalid character code:"; -- 2.2 or 4.1
Error_Invalid_Declaration : constant String := "Invalid declaration";
Error_Invalid_Encoding : constant String := "Invalid character encoding";
Error_Invalid_Content_Model : constant String := "Invalid content model";
Error_Invalid_Language : constant String :=
"Invalid language specification"; -- 2.12
Error_Invalid_Name : constant String :=
"Invalid name: "; -- 3.1
Error_Invalid_Notation_Decl : constant String :=
"Invalid notation declaration"; -- WF
Error_Invalid_Space : constant String :=
"Value of xml:space must be (default|preserve)"; -- 2.10
Error_Is_Name : constant String := "Expecting a Name"; -- 3.3.1
Error_Is_Ncname : constant String :=
"Expecting a Name with no colon"; -- NS 6 and 3.3.1
Error_Missing_Operand : constant String :=
"Missing operand before this operator";
Error_Mixed_Contents : constant String :=
"Mixed contents cannot be used in a list or a sequence"; -- 3.2.1
Error_Ndata_ParamEntity : constant String := -- 4.2
"NDATA annotation not allowed for parameter entities";
Error_Ndata_Space : constant String := -- 4.2.2
"Expecting space before NDATA declaration";
Error_Ndata_String : constant String :=
"Expecting string after NDATA";
Error_ParamEntity_In_Attribute : constant String :=
"Parameter entities cannot occur in attribute values";
-- WF PE in internal subset
Error_Notation_Undeclared : constant String :=
"Notation must be declared: "; -- VC 4.2.2 or 3.3.1
Error_Prefix_Not_Declared : constant String :=
"Prefix must be declared before its use: "; -- WF
Error_Public_String : constant String :=
"Expecting a string after PUBLIC";
Error_Public_Sysid : constant String :=
"Expecting SystemID after PUBLIC";
Error_Public_Sysid_Space : constant String :=
"Require whitespace between public and system IDs"; -- 4.2.2
Error_Public_Invalid : constant String :=
"Invalid PubID character: ";
Error_System_String : constant String :=
"Expecting a string after SYSTEM";
Error_System_URI : constant String := -- 4.2.2
"SYSTEM identifiers may not contain URI fragments starting with #";
Error_Unknown_Declaration : constant String :=
"Unknown declaration in DTD"; -- WF
Error_Unexpected_Chars1 : constant String :=
"Invalid characters '' in the DTD"; -- 2.8
Error_Unexpected_Chars3 : constant String :=
"Text may not contain the litteral ']]>'"; -- 2.4
Error_Unterminated_String : constant String :=
"Unterminated string"; -- 2.3
Error_Unterminated_String_Suggests : constant String :=
"Unterminated string, possible end at "; -- 2.3
------------
-- Tokens --
------------
type Token_Type is
(Double_String_Delimiter, -- "
Single_String_Delimiter, -- '
Comment, -- (Data is the comment)
Start_Of_Tag, -- <
Start_Of_End_Tag, --
End_Of_Start_Tag, -- />
Start_Of_PI, --
End_Of_PI, -- ?>
End_Of_Tag, -- >
Equal, -- = (in tags)
Colon, -- : (in tags)
Open_Paren, -- ( (while parsing content model in ATTLIST)
Internal_DTD_Start, -- [ (while in DTD)
Internal_DTD_End, -- ] (while in DTD)
Include, --
Space, -- Any number of spaces (Data is the spaces)
Text, -- any text (Data is the identifier)
Name, -- same as text, but contains only valid
-- name characters
Char_Ref, -- A character reference. Data is the character
Cdata_Section, -- "Def",
Ignore_Special => False,
Detect_End_Of_PI => False,
Greater_Special => False,
Less_Special => False,
Expand_Param_Entities => False,
Expand_Entities => True,
Report_Character_Ref => False,
Expand_Character_Ref => True,
In_DTD => False,
Recognize_External => False,
Handle_Strings => False,
In_Tag => False,
Report_Parenthesis => False,
In_Attlist => False);
Attr_Value_State : constant Parser_State :=
(Name => "Att",
Ignore_Special => True,
Detect_End_Of_PI => False,
Greater_Special => False,
Less_Special => True,
Expand_Param_Entities => False,
Expand_Entities => True,
Report_Character_Ref => True,
Expand_Character_Ref => False,
In_DTD => False,
Recognize_External => False,
Handle_Strings => True,
In_Tag => False,
Report_Parenthesis => False,
In_Attlist => False);
Non_Interpreted_String_State : constant Parser_State :=
(Name => "Str",
Ignore_Special => True,
Detect_End_Of_PI => False,
Greater_Special => False,
Less_Special => False,
Expand_Param_Entities => False,
Expand_Entities => False,
Report_Character_Ref => False,
Expand_Character_Ref => False,
In_DTD => False,
Recognize_External => False,
Handle_Strings => True,
In_Tag => False,
Report_Parenthesis => False,
In_Attlist => False);
DTD_State : constant Parser_State :=
(Name => "DTD",
Ignore_Special => False,
Detect_End_Of_PI => False,
Greater_Special => True,
Less_Special => False,
Expand_Param_Entities => True,
Expand_Entities => True,
Report_Character_Ref => False,
Expand_Character_Ref => True,
In_DTD => True,
Recognize_External => True,
Handle_Strings => True,
In_Tag => False,
Report_Parenthesis => False,
In_Attlist => False);
PI_State : constant Parser_State :=
(Name => "PI ",
Ignore_Special => True,
Detect_End_Of_PI => True,
Greater_Special => False,
Less_Special => False,
Expand_Param_Entities => False,
Expand_Entities => False,
Report_Character_Ref => False,
Expand_Character_Ref => False,
In_DTD => False,
Recognize_External => False,
Handle_Strings => True,
In_Tag => False,
Report_Parenthesis => False,
In_Attlist => False);
Entity_Def_State : constant Parser_State :=
(Name => "Ent",
Ignore_Special => False,
Detect_End_Of_PI => False,
Greater_Special => True,
Less_Special => False,
Expand_Param_Entities => False,
Expand_Entities => False,
Report_Character_Ref => False,
Expand_Character_Ref => True,
In_DTD => True,
Recognize_External => True,
Handle_Strings => True,
In_Tag => False,
Report_Parenthesis => False,
In_Attlist => False);
Element_Def_State : constant Parser_State :=
(Name => "Ele",
Ignore_Special => False,
Detect_End_Of_PI => False,
Greater_Special => True,
Less_Special => False,
Expand_Param_Entities => True,
Expand_Entities => False,
Report_Character_Ref => False,
Expand_Character_Ref => True,
In_DTD => True,
Recognize_External => True,
Handle_Strings => True,
In_Tag => True,
Report_Parenthesis => True,
In_Attlist => False);
Attribute_Def_State : constant Parser_State :=
(Name => "AtD",
Ignore_Special => False,
Detect_End_Of_PI => False,
Greater_Special => True,
Less_Special => False,
Expand_Param_Entities => True,
Expand_Entities => False,
Report_Character_Ref => False,
Expand_Character_Ref => True,
In_DTD => True,
Recognize_External => False,
Handle_Strings => True,
In_Tag => True,
Report_Parenthesis => True,
In_Attlist => True);
Attribute_Def_Name_State : constant Parser_State :=
(Name => "ADN",
Ignore_Special => False,
Detect_End_Of_PI => False,
Greater_Special => True,
Less_Special => False,
Expand_Param_Entities => True,
Expand_Entities => False,
Report_Character_Ref => False,
Expand_Character_Ref => True,
In_DTD => True,
Recognize_External => False,
Handle_Strings => True,
In_Tag => True,
Report_Parenthesis => True,
In_Attlist => False);
Entity_Str_Def_State : constant Parser_State :=
(Name => "EtS",
Ignore_Special => True,
Detect_End_Of_PI => False,
Greater_Special => False,
Less_Special => False,
Expand_Param_Entities => True,
Expand_Entities => False,
Report_Character_Ref => False,
Expand_Character_Ref => True,
In_DTD => True,
Recognize_External => False,
Handle_Strings => True,
In_Tag => False,
Report_Parenthesis => False,
In_Attlist => False);
Attlist_Str_Def_State : constant Parser_State :=
(Name => "AtS",
Ignore_Special => True,
Detect_End_Of_PI => False,
Greater_Special => False,
Less_Special => False,
Expand_Param_Entities => False,
Expand_Entities => True,
Report_Character_Ref => False,
Expand_Character_Ref => True,
In_DTD => True,
Recognize_External => False,
Handle_Strings => True,
In_Tag => False,
Report_Parenthesis => False,
In_Attlist => False);
Tag_State : constant Parser_State :=
(Name => "Tag",
Ignore_Special => False,
Greater_Special => True,
Less_Special => False,
Detect_End_Of_PI => False,
Expand_Param_Entities => False,
Expand_Entities => False,
Report_Character_Ref => False,
Expand_Character_Ref => True,
In_DTD => False,
Recognize_External => False,
Handle_Strings => True,
In_Tag => True,
Report_Parenthesis => False,
In_Attlist => False);
--------------------------
-- Internal subprograms --
--------------------------
procedure Unchecked_Free is new Unchecked_Deallocation
(Input_Source'Class, Input_Source_Access);
procedure Unchecked_Free is new Unchecked_Deallocation
(Hook_Data'Class, Hook_Data_Access);
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(Sax_Attribute_Array, Sax_Attribute_Array_Access);
function Debug_Encode (C : Unicode_Char) return Byte_Sequence;
-- Return an encoded string matching C (matching Sax.Encodins.Encoding)
procedure Test_Valid_Char
(Parser : in out Sax_Reader'Class; C : Unicode_Char; Loc : Token);
-- Raise an error if C is not valid in XML. The error is reported at
-- location Loc.
function Is_Pubid_Char (C : Unicode_Char) return Boolean;
-- Return True if C is a valid character for a Public ID (2.3 specs)
procedure Test_Valid_Lang
(Parser : in out Sax_Reader'Class; Lang : Byte_Sequence);
-- Return True if Lang matches the rules for languages
procedure Test_Valid_Space
(Parser : in out Sax_Reader'Class; Space : Byte_Sequence);
-- Return True if Space matches the rules for the xml:space attribute
procedure Next_Char
(Input : in out Input_Source'Class;
Parser : in out Sax_Reader'Class);
-- Return the next character, and increments the locators.
-- If there are no more characters in the input streams, Parser is setup
-- so that End_Of_Stream (Parser) returns True.
procedure Lookup_Char
(Input : in out Input_Source'Class;
Parser : in out Sax_Reader'Class;
Char : out Unicode_Char);
-- Lookup one character, but put it back in the input so that the next call
-- to Next_Char will return it again. This does not change
-- Parser.Last_Read.
function End_Of_Stream (Parser : Sax_Reader'Class) return Boolean;
pragma Inline (End_Of_Stream);
-- Return True if there are no more characters in the parser.
-- Note that this indicates that no more character remains to be read, and
-- is different from checking Eof on the current input (since for instance
-- a new input is open for an entity).
function Create_Attribute_List
(Attrs : Sax_Attribute_List) return Sax.Attributes.Attributes;
-- Create the list of attributes from Parser.Attributes.
-- This function has the side effect of resetting
-- Parser.Attributes_Count to 0, and freeing memory as appropriate
procedure Put_In_Buffer
(Parser : in out Sax_Reader'Class; Char : Unicode_Char);
pragma Inline (Put_In_Buffer);
procedure Put_In_Buffer
(Parser : in out Sax_Reader'Class; Str : Byte_Sequence);
pragma Inline (Put_In_Buffer);
-- Put the last character read in the internal buffer
procedure Next_Token
(Input : in out Input_Sources.Input_Source'Class;
Parser : in out Sax_Reader'Class;
Id : out Token;
Coalesce_Space : Boolean := False);
-- Return the next identifier in the input stream.
-- Locator is modified accordingly (line and column).
-- If Coalesce_Space is True, then all the Name or Text tokens preceded or
-- followed by Space tokens are grouped together and returned as a single
-- Text token.
-- Id.Typ is set to End_Of_Input if there are no more token to be read.
procedure Next_Token_Skip_Spaces
(Input : in out Input_Sources.Input_Source'Class;
Parser : in out Sax_Reader'Class;
Id : out Token;
Must_Have : Boolean := False);
-- Same as Next_Token, except it skips spaces. If Must_Have is True,
-- then the first token read must be a space, or an error is raised
-- Id.Typ is set to End_Of_Input if there are no more token to be read.
procedure Next_NS_Token_Skip_Spaces
(Input : in out Input_Sources.Input_Source'Class;
Parser : in out Sax_Reader'Class;
NS_Id : out Token;
Name_Id : out Token);
-- Skip spaces, if any, then read a "ns:name" or "name" token.
function Find_Symbol (Parser : Sax_Reader'Class; T : Token) return Symbol;
function Find_Symbol
(Parser : Sax_Reader'Class; First, Last : Token) return Symbol;
-- Return the value of the symbol
procedure Reset_Buffer
(Parser : in out Sax_Reader'Class; Id : Token := Null_Token);
-- Clears the internal buffer in Parser.
-- If Id is not Null_Token, then only the characters starting from
-- Id.First are removed
procedure Set_State
(Parser : in out Sax_Reader'Class; State : Parser_State);
-- Set the current state for the parser
function Get_State (Parser : Sax_Reader'Class) return Parser_State;
-- Return the current state.
procedure Close_Namespaces
(Parser : in out Sax_Reader'Class; List : XML_NS);
-- Close all namespaces in the list, and report appropriate SAX events
procedure Check_Valid_Name_Or_NCname
(Parser : in out Sax_Reader'Class;
Name : Token);
-- Check that Name is a valid Name (if namespaces are not supported) or
-- a NCname if namespaces are supported.
procedure Check_Attribute_Value
(Parser : in out Sax_Reader'Class;
Local_Name : Symbol;
Typ : Attribute_Type;
Value : Symbol;
Error_Loc : Token);
-- Check Validity Constraints for a single attribute. Only call this
-- subprogram for a validating parser
procedure Syntactic_Parse
(Parser : in out Sax_Reader'Class;
Input : in out Input_Sources.Input_Source'Class);
-- Internal syntactical parser.
procedure Find_NS
(Parser : in out Sax_Reader'Class;
Prefix : Token;
NS : out XML_NS;
Include_Default_NS : Boolean := True);
-- Internal version of Find_NS
function Qname_From_Name
(Parser : Sax_Reader'Class; Prefix, Local_Name : Token)
return Byte_Sequence;
function Qname_From_Name (Prefix, Local_Name : Symbol) return Byte_Sequence;
-- Create the qualified name from the namespace URI and the local name.
procedure Add_Namespace
(Parser : in out Sax_Reader'Class;
Node : Element_Access;
Prefix : Symbol;
URI : Symbol;
Report_Event : Boolean := True);
-- Same as above, with strings
procedure Add_Namespace_No_Event
(Parser : in out Sax_Reader'Class;
Prefix, URI : Symbol);
-- Create a new default namespace in the parser
procedure Free (Parser : in out Sax_Reader'Class);
-- Free the memory allocated for the parser, including the namespaces,
-- entities,...
procedure Free (Elem : in out Element_Access);
-- Free the memory of Elem (and its contents). Note that this doesn't free
-- the parent of Elem).
-- On Exit, Elem is set to its parent.
procedure Parse_Element_Model
(Input : in out Input_Sources.Input_Source'Class;
Parser : in out Sax_Reader'Class;
Result : out Element_Model_Ptr;
Attlist : Boolean := False;
Open_Was_Read : Boolean);
-- Parse the following characters in the stream so as to create an
-- element or attribute contents model, ie the tree matching an
-- expression like "(foo|bar)+".
-- Nmtokens should be true if the names in the model should follow the
-- Nmtoken rule in XML specifications rather than the Name rule.
-- If Open_Was_Read, then the opening parenthesis is considered to have
-- been read already and is automatically inserted into the stack.
-- Attlist should be set to true if this is the model in
procedure Fatal_Error
(Parser : in out Sax_Reader'Class;
Msg : String;
Loc : Sax.Locators.Location := No_Location);
procedure Fatal_Error
(Parser : in out Sax_Reader'Class;
Msg : String;
Loc : Token);
-- Raises a fatal error.
-- The error is reported at location Id (or the current parser location
-- if Id is Null_Token).
-- The user application should not return from this call. Thus, a
-- Program_Error is raised if it does return.
procedure Error
(Parser : in out Sax_Reader'Class;
Msg : String;
Loc : Sax.Locators.Location);
procedure Error
(Parser : in out Sax_Reader'Class;
Msg : String;
Id : Token);
-- Same as Fatal_Error, but reports an error instead
procedure Warning
(Parser : in out Sax_Reader'Class;
Msg : String;
Loc : Sax.Locators.Location);
procedure Warning
(Parser : in out Sax_Reader'Class;
Msg : String;
Id : Token := Null_Token);
-- Same as Fatal_Error, but reports a warning instead
function Location
(Parser : Sax_Reader'Class;
Loc : Sax.Locators.Location) return Byte_Sequence;
-- Return the location of the start of Id as a string.
function Resolve_URI
(Parser : Sax_Reader'Class;
System_Id : Symbol;
URI : Symbol) return Symbol;
-- Return a fully resolved URI, based on the system identifier set for
-- Machine, and URI.
-- [System_Id] should be the result of [System_Id (Parser)] at the time the
-- URI was found.
function System_Id (Parser : Sax_Reader'Class) return Symbol;
function Public_Id (Parser : Sax_Reader'Class) return Symbol;
pragma Inline (System_Id, Public_Id);
-- Return the current system id that we are parsing
procedure Close_Inputs
(Parser : in out Sax_Reader'Class;
Inputs : in out Entity_Input_Source_Access);
-- Close the inputs that have been completely read. This should be
-- called every time one starts an entity, so that calls to
-- Start_Entity/End_Entity are properly nested, and error messages
-- point to the right entity.
procedure Debug_Print (Parser : Sax_Reader'Class; Id : Token);
-- Print the contents of Id
-----------------
-- Find_Symbol --
-----------------
function Find_Symbol
(Parser : Sax_Reader'Class; Str : Byte_Sequence) return Symbol is
begin
return Find (Get (Parser.Symbols), Str);
end Find_Symbol;
-----------------
-- Find_Symbol --
-----------------
function Find_Symbol (Parser : Sax_Reader'Class; T : Token) return Symbol is
begin
return Find (Get (Parser.Symbols), Parser.Buffer (T.First .. T.Last));
end Find_Symbol;
-----------------
-- Find_Symbol --
-----------------
function Find_Symbol
(Parser : Sax_Reader'Class; First, Last : Token) return Symbol is
begin
return Find (Get (Parser.Symbols),
Parser.Buffer (First.First .. Last.Last));
end Find_Symbol;
-------------------
-- End_Of_Stream --
-------------------
function End_Of_Stream (Parser : Sax_Reader'Class) return Boolean is
begin
return not Parser.Last_Read_Is_Valid
and Parser.Last_Read = 16#FFFF#;
end End_Of_Stream;
------------------
-- Debug_Encode --
------------------
function Debug_Encode (C : Unicode_Char) return Byte_Sequence is
Buffer : Byte_Sequence (1 .. 20);
Index : Natural := Buffer'First - 1;
begin
Encoding.Encode (C, Buffer, Index);
return Buffer (Buffer'First .. Index);
end Debug_Encode;
---------------
-- System_Id --
---------------
function System_Id (Parser : Sax_Reader'Class) return Symbol is
begin
if Parser.Inputs = null then
return Parser.System_Id;
else
return Parser.Inputs.System_Id;
end if;
end System_Id;
---------------
-- Public_Id --
---------------
function Public_Id (Parser : Sax_Reader'Class) return Symbol is
begin
if Parser.Inputs = null then
return Parser.Public_Id;
else
return Parser.Inputs.Public_Id;
end if;
end Public_Id;
----------
-- Free --
----------
procedure Free (Elem : in out Element_Access) is
procedure Free_Element is new Unchecked_Deallocation
(Element, Element_Access);
Tmp : constant Element_Access := Elem.Parent;
begin
Free (Elem.Namespaces);
Free_Element (Elem);
Elem := Tmp;
end Free;
---------------------------
-- Create_Attribute_List --
---------------------------
function Create_Attribute_List
(Attrs : Sax_Attribute_List) return Sax.Attributes.Attributes
is
function Get_Or_Null (S : Symbol) return String;
function Get_Or_Null (S : Symbol) return String is
begin
if S = No_Symbol then
return "";
else
return Get (S).all;
end if;
end Get_Or_Null;
Attributes : Sax.Attributes.Attributes;
begin
for J in 1 .. Attrs.Count loop
Add_Attribute
(Attr => Attributes,
URI => Get_Or_Null (Attrs.List (J).URI),
Local_Name => Get (Attrs.List (J).Local_Name).all,
Qname =>
Qname_From_Name
(Prefix => Attrs.List (J).Prefix,
Local_Name => Attrs.List (J).Local_Name),
Att_Type => Attrs.List (J).Att_Type,
Content => Unknown_Model, -- not needed anyway
Value => Get (Attrs.List (J).Value).all,
Default_Decl => Attrs.List (J).Default_Decl);
end loop;
return Attributes;
exception
when others =>
Clear (Attributes);
raise;
end Create_Attribute_List;
-----------------
-- Resolve_URI --
-----------------
function Resolve_URI
(Parser : Sax_Reader'Class;
System_Id : Symbol;
URI : Symbol) return Symbol
is
C : Unicode_Char;
URI_Str : constant Cst_Byte_Sequence_Access := Get (URI);
URI_Index : Positive := URI_Str'First;
begin
pragma Assert (URI /= No_Symbol);
if URI = Empty_String then
return System_Id;
end if;
-- ??? Only resolve paths for now
Encoding.Read (URI_Str.all, URI_Index, C);
if C = Solidus then
return URI;
else
declare
System_Str : constant Cst_Byte_Sequence_Access := Get (System_Id);
Index : Natural := System_Str'First;
Basename_Start : Natural := System_Str'First;
begin
while Index <= System_Str'Last loop
Encoding.Read (System_Str.all, Index, C);
if C = Solidus or else C = Reverse_Solidus then
Basename_Start := Index;
end if;
end loop;
return Find_Symbol
(Parser,
System_Str (System_Str'First .. Basename_Start - 1)
& URI_Str.all);
end;
end if;
end Resolve_URI;
--------------
-- Location --
--------------
function Location (Parser : Sax_Reader'Class; Loc : Sax.Locators.Location)
return Byte_Sequence
is
Line : constant Byte_Sequence := Natural'Image (Loc.Line);
Col : constant Byte_Sequence := Natural'Image (Loc.Column);
begin
if Parser.Close_Inputs = null then
if Use_Basename_In_Error_Messages (Parser) then
return Base_Name (Get (Get_Public_Id (Parser.Locator)).all) & ':'
& Line (Line'First + 1 .. Line'Last)
& ':' & Col (Col'First + 1 .. Col'Last);
else
return Get (Get_Public_Id (Parser.Locator)).all & ':'
& Line (Line'First + 1 .. Line'Last)
& ':' & Col (Col'First + 1 .. Col'Last);
end if;
else
if Use_Basename_In_Error_Messages (Parser) then
return Base_Name (Get_Public_Id (Parser.Close_Inputs.Input.all))
& ':' & Line (Line'First + 1 .. Line'Last)
& ':' & Col (Col'First + 1 .. Col'Last);
else
return Get_Public_Id (Parser.Close_Inputs.Input.all) & ':'
& Line (Line'First + 1 .. Line'Last)
& ':' & Col (Col'First + 1 .. Col'Last);
end if;
end if;
end Location;
-----------------
-- Fatal_Error --
-----------------
procedure Fatal_Error
(Parser : in out Sax_Reader'Class;
Msg : String;
Loc : Sax.Locators.Location := No_Location)
is
Id2 : Sax.Locators.Location := Loc;
begin
if Id2 = No_Location then
Id2 := Parser.Current_Location;
end if;
Parser.Buffer_Length := 0;
-- So that when calling Close_Inputs, we do generate an End_Entity
Parser.State.Ignore_Special := True;
begin
-- Must be called before End_Document, as per the SAX standard
Fatal_Error
(Parser, Create (Location (Parser, Id2) & ": " & Msg, Id2));
End_Document (Parser);
exception
when E : others =>
begin
End_Document (Parser);
exception
when others => null;
end;
-- Priority is given to the Fatal_Error, whatever
-- End_Document raises
Reraise_Occurrence (E);
end;
raise Program_Error;
end Fatal_Error;
-----------------
-- Fatal_Error --
-----------------
procedure Fatal_Error
(Parser : in out Sax_Reader'Class;
Msg : String;
Loc : Token) is
begin
Fatal_Error (Parser, Msg, Loc.Location);
end Fatal_Error;
-----------
-- Error --
-----------
procedure Error
(Parser : in out Sax_Reader'Class;
Msg : String;
Loc : Sax.Locators.Location)
is
Id2 : Sax.Locators.Location := Loc;
begin
if Id2 = No_Location then
Id2 := Parser.Current_Location;
end if;
Error (Parser, Create (Location (Parser, Id2) & ": " & Msg, Id2));
end Error;
procedure Error
(Parser : in out Sax_Reader'Class;
Msg : String;
Id : Token) is
begin
Error (Parser, Msg, Id.Location);
end Error;
-----------
-- Error --
-----------
procedure Error (Parser : in out Sax_Reader'Class; Msg : String) is
begin
Error (Parser, Msg, No_Location);
end Error;
-------------
-- Warning --
-------------
procedure Warning
(Parser : in out Sax_Reader'Class;
Msg : String;
Loc : Sax.Locators.Location)
is
Id2 : Sax.Locators.Location := Loc;
begin
if Id2 = No_Location then
Id2 := Parser.Current_Location;
end if;
Warning (Parser, Create (Location (Parser, Id2) & ": " & Msg, Id2));
end Warning;
procedure Warning
(Parser : in out Sax_Reader'Class;
Msg : String;
Id : Token := Null_Token)
is
Id2 : Sax.Locators.Location := Id.Location;
begin
if Id2 = No_Location then
Id2 := Parser.Current_Location;
end if;
Warning (Parser, Create (Location (Parser, Id2) & ": " & Msg, Id2));
end Warning;
-----------------
-- Lookup_Char --
-----------------
procedure Lookup_Char
(Input : in out Input_Source'Class;
Parser : in out Sax_Reader'Class;
Char : out Unicode_Char)
is
begin
if Parser.Inputs /= null then
if Eof (Parser.Inputs.Input.all) then
if Debug_Input then
Put_Line ("++Input Lookup_Char: ");
end if;
Char := Unicode_Char'Last;
else
Input_Sources.Next_Char (Parser.Inputs.Input.all, Char);
end if;
else
if Eof (Input) then
if Debug_Input then
Put_Line ("++Input Lookup_Char 2: ");
end if;
Char := Unicode_Char'Last;
else
Input_Sources.Next_Char (Input, Char);
end if;
end if;
if Debug_Input then
Put_Line ("++Input Lookup_Char: " & Unicode_Char'Image (Char));
end if;
Parser.Lookup_Char := Char;
end Lookup_Char;
---------------
-- Next_Char --
---------------
procedure Next_Char
(Input : in out Input_Source'Class;
Parser : in out Sax_Reader'Class)
is
procedure Internal (Stream : in out Input_Source'Class);
pragma Inline (Internal);
--------------
-- Internal --
--------------
procedure Internal (Stream : in out Input_Source'Class) is
C : Unicode_Char;
begin
if Parser.Lookup_Char /= Unicode_Char'Last then
C := Parser.Lookup_Char;
Parser.Lookup_Char := Unicode_Char'Last;
else
Next_Char (Stream, C);
end if;
-- XML specs say that #xD#xA must be converted to one single #xA.
-- A single #xD must be converted to one single #xA
if C = Carriage_Return then
Parser.Previous_Char_Was_CR := True;
-- When expanding an internal entity, do not normalize the
-- character (which has already been normalized when creating the
-- entity, and therefore comes from a
character ref
if Parser.Inputs = null
or else Parser.Inputs.External
then
Parser.Last_Read := Line_Feed;
else
Parser.Last_Read := Carriage_Return;
end if;
elsif C = Line_Feed and then Parser.Previous_Char_Was_CR then
Parser.Previous_Char_Was_CR := False;
-- When expanding an internal entity, do not strip the CRLF
-- sequences: since they have already been stripped when the
-- entity was created, the sequences that remain were created
-- through character references
and should therefore
-- be kept as is.
if Parser.Inputs = null
or else Parser.Inputs.External
then
Next_Char (Stream, Parser);
end if;
else
Parser.Last_Read := C;
if Parser.Feature_Test_Valid_Chars then
Test_Valid_Char (Parser, Parser.Last_Read, Null_Token);
end if;
end if;
end Internal;
Input_A : Entity_Input_Source_Access;
begin
-- First thing is to take into account location changes due to the
-- previous character.
if Parser.Last_Read_Is_Valid then
if Parser.Last_Read = Line_Feed
and then not Parser.Previous_Char_Was_CR
then
Set_Column_Number (Parser.Locator, 0);
Increase_Line_Number (Parser.Locator);
end if;
elsif Parser.Inputs /= null then
Set_Location (Parser.Locator, Parser.Inputs.Save_Loc);
if Parser.Inputs.External then
Parser.In_External_Entity := False;
-- ??? Should test whether we are still in an external entity.
-- However, this is only used for the PI, and at this
-- point we have already read and discarded it, so it doesn't
-- really matter.
end if;
-- Insert the closed input at the end of the Close_Input list, so
-- that the next call to Next_Token properly closes the entity.
-- This can not be done here, otherwise End_Entity is called too
-- early, and the error messages do not point to the right entity.
if Parser.Close_Inputs = null then
Parser.Close_Inputs := Parser.Inputs;
else
Input_A := Parser.Close_Inputs;
while Input_A.Next /= null loop
Input_A := Input_A.Next;
end loop;
Input_A.Next := Parser.Inputs;
end if;
Input_A := Parser.Inputs;
Parser.Inputs := Parser.Inputs.Next;
Input_A.Next := null;
end if;
-- Read the text of the entity if there is any
if Parser.Inputs /= null then
if Parser.Inputs.Input = null
or else Eof (Parser.Inputs.Input.all)
then
if Debug_Input then
Put_Line ("++Input END OF INPUT");
end if;
Parser.Last_Read := Unicode_Char'Val (16#00#);
Parser.Last_Read_Is_Valid := False;
return;
end if;
Parser.Last_Read_Is_Valid := True;
Increase_Column_Number (Parser.Locator);
Internal (Parser.Inputs.Input.all);
-- Else read from the initial input stream
elsif Eof (Input) then
if Debug_Input then
Put_Line
("++Input " & To_String (Parser.Locator) & " END_OF_INPUT");
end if;
Parser.Last_Read := 16#FFFF#;
Parser.Last_Read_Is_Valid := False;
else
Parser.Last_Read_Is_Valid := True;
Increase_Column_Number (Parser.Locator);
Internal (Input);
end if;
if Debug_Input and then Parser.Last_Read_Is_Valid then
Put ("++Input " & To_String (Parser.Locator)
& "(" & Unicode_Char'Image (Parser.Last_Read) & ")= ");
if Parser.Last_Read /= Line_Feed then
Put_Line (Debug_Encode (Parser.Last_Read));
else
Put_Line ("Line_Feed");
end if;
end if;
exception
when Unicode.CES.Invalid_Encoding =>
Fatal_Error (Parser, Error_Invalid_Encoding);
end Next_Char;
-------------------
-- Put_In_Buffer --
-------------------
procedure Put_In_Buffer
(Parser : in out Sax_Reader'Class; Char : Unicode_Char)
is
W : constant Natural := Encoding.Width (Char);
Tmp : Byte_Sequence_Access;
begin
-- Loop until we have enough memory to store the string
while Parser.Buffer_Length + W > Parser.Buffer'Last loop
Tmp := Parser.Buffer;
Parser.Buffer := new Byte_Sequence
(1 .. Tmp'Length * 2);
Parser.Buffer (1 .. Tmp'Length) := Tmp.all;
Free (Tmp);
end loop;
Encoding.Encode (Char, Parser.Buffer.all, Parser.Buffer_Length);
end Put_In_Buffer;
-------------------
-- Put_In_Buffer --
-------------------
procedure Put_In_Buffer
(Parser : in out Sax_Reader'Class; Str : Byte_Sequence)
is
Tmp : Byte_Sequence_Access;
begin
-- Loop until we have enough memory to store the string
while Parser.Buffer_Length + Str'Length > Parser.Buffer'Last loop
Tmp := Parser.Buffer;
Parser.Buffer := new Byte_Sequence (1 .. Tmp'Length * 2);
Parser.Buffer (1 .. Tmp'Length) := Tmp.all;
Free (Tmp);
end loop;
Parser.Buffer
(Parser.Buffer_Length + 1 .. Parser.Buffer_Length + Str'Length) := Str;
Parser.Buffer_Length := Parser.Buffer_Length + Str'Length;
end Put_In_Buffer;
---------------------
-- Test_Valid_Lang --
---------------------
procedure Test_Valid_Lang
(Parser : in out Sax_Reader'Class; Lang : Byte_Sequence) is
begin
-- XML Errata 41: An empty xml:lang attribute is valid
if Lang /= "" and then not Is_Valid_Language_Name (Lang) then
Error (Parser, Error_Invalid_Language);
end if;
end Test_Valid_Lang;
----------------------
-- Test_Valid_Space --
----------------------
procedure Test_Valid_Space
(Parser : in out Sax_Reader'Class; Space : Byte_Sequence) is
begin
if Space /= Default_Sequence
and then Space /= Preserve_Sequence
then
Error (Parser, Error_Invalid_Space);
end if;
end Test_Valid_Space;
-------------------
-- Is_Pubid_Char --
-------------------
function Is_Pubid_Char (C : Unicode_Char) return Boolean is
begin
return C = Unicode.Names.Basic_Latin.Space
or else C = Line_Feed
or else C in Latin_Small_Letter_A .. Latin_Small_Letter_Z
or else C in Latin_Capital_Letter_A .. Latin_Capital_Letter_Z
or else C in Digit_Zero .. Digit_Nine
or else C = Hyphen_Minus
or else C = Apostrophe
or else C = Left_Parenthesis
or else C = Right_Parenthesis
or else C = Plus_Sign
or else C = Comma
or else C = Full_Stop
or else C = Solidus
or else C = Unicode.Names.Basic_Latin.Colon
or else C = Equals_Sign
or else C = Question_Mark
or else C = Semicolon
or else C = Exclamation_Mark
or else C = Asterisk
or else C = Number_Sign
or else C = Commercial_At
or else C = Dollar_Sign
or else C = Low_Line
or else C = Percent_Sign;
end Is_Pubid_Char;
---------------------
-- Test_Valid_Char --
---------------------
procedure Test_Valid_Char
(Parser : in out Sax_Reader'Class; C : Unicode_Char; Loc : Token)
is
Id : Sax.Locators.Location;
begin
if not (C = 16#9#
or else C = 16#A#
or else C = 16#D#
or else C in Unicode.Names.Basic_Latin.Space .. 16#D7FF#
or else C in 16#E000# .. 16#FFFD#
or else C in 16#10000# .. 16#10FFFF#)
then
if Loc /= Null_Token then
Id := Loc.Location;
else
Id := No_Location;
Id.Line := Get_Line_Number (Parser.Locator);
Id.Column := Get_Column_Number (Parser.Locator);
end if;
Fatal_Error (Parser, Error_Invalid_Char & Unicode_Char'Image (C), Id);
end if;
end Test_Valid_Char;
-------------
-- Find_NS --
-------------
procedure Find_NS
(Parser : in out Sax_Reader'Class;
Prefix : Token;
NS : out XML_NS;
Include_Default_NS : Boolean := True) is
begin
Find_NS
(Parser,
Find_Symbol (Parser, Parser.Buffer (Prefix.First .. Prefix.Last)),
NS, Include_Default_NS);
if NS = No_XML_NS then
Fatal_Error
(Parser, Error_Prefix_Not_Declared &
Parser.Buffer (Prefix.First .. Prefix.Last));
end if;
end Find_NS;
-------------
-- Find_NS --
-------------
procedure Find_NS
(Parser : Sax_Reader'Class;
Prefix : Sax.Symbols.Symbol;
NS : out XML_NS;
Include_Default_NS : Boolean := True)
is
E : Element_Access := Parser.Current_Node;
begin
loop
if E = null then
NS := Find_NS_In_List
(Parser.Default_Namespaces, Prefix, Include_Default_NS, False);
else
NS := Find_NS_In_List
(E.Namespaces, Prefix, Include_Default_NS, True);
end if;
exit when NS /= No_XML_NS or else E = null;
E := E.Parent;
end loop;
end Find_NS;
----------------------
-- Find_NS_From_URI --
----------------------
procedure Find_NS_From_URI
(Parser : in out Sax_Reader'Class;
URI : Symbol;
NS : out XML_NS)
is
E : Element_Access := Parser.Current_Node;
begin
loop
-- Search in the default namespaces
if E = null then
NS := Find_NS_From_URI_In_List (Parser.Default_Namespaces, URI);
else
NS := Find_NS_From_URI_In_List (E.Namespaces, URI);
end if;
exit when NS /= No_XML_NS or else E = null;
E := E.Parent;
end loop;
end Find_NS_From_URI;
---------------------
-- Qname_From_Name --
---------------------
function Qname_From_Name
(Parser : Sax_Reader'Class; Prefix, Local_Name : Token)
return Byte_Sequence is
begin
if Prefix = Null_Token then
return Parser.Buffer (Local_Name.First .. Local_Name.Last);
else
return Parser.Buffer (Prefix.First .. Prefix.Last)
& Colon_Sequence
& Parser.Buffer (Local_Name.First .. Local_Name.Last);
end if;
end Qname_From_Name;
---------------------
-- Qname_From_Name --
---------------------
function Qname_From_Name
(Prefix, Local_Name : Symbol) return Byte_Sequence is
begin
if Prefix = No_Symbol or else Prefix = Empty_String then
return Get (Local_Name).all;
else
return Get (Prefix).all & Colon_Sequence & Get (Local_Name).all;
end if;
end Qname_From_Name;
-----------------------
-- Prefix_From_Qname --
-----------------------
function Prefix_From_Qname (Qname : Byte_Sequence) return Byte_Sequence is
Index : Natural := Qname'First;
C : Unicode_Char;
Previous : Natural;
begin
while Index <= Qname'Last loop
Previous := Index;
Encoding.Read (Qname, Index, C);
if C = Unicode.Names.Basic_Latin.Colon then
return Qname (Qname'First .. Previous - 1);
end if;
end loop;
return "";
end Prefix_From_Qname;
----------------------------
-- Add_Namespace_No_Event --
----------------------------
procedure Add_Namespace_No_Event
(Parser : in out Sax_Reader'Class;
Prefix, URI : Symbol) is
begin
Add_Namespace (Parser, null, Prefix, URI, Report_Event => False);
end Add_Namespace_No_Event;
-------------------
-- Add_Namespace --
-------------------
procedure Add_Namespace
(Parser : in out Sax_Reader'Class;
Node : Element_Access;
Prefix : Symbol;
URI : Symbol;
Report_Event : Boolean := True)
is
Same_As : XML_NS := No_XML_NS;
begin
-- Was there a previous definition of this namespace ?
Find_NS_From_URI (Parser, URI, Same_As);
if Node = null then
Add_NS_To_List (Parser.Default_Namespaces, Same_As, Prefix, URI);
else
Add_NS_To_List (Node.Namespaces, Same_As, Prefix, URI);
end if;
if Report_Event then
Start_Prefix_Mapping (Parser, Prefix => Prefix, URI => URI);
end if;
end Add_Namespace;
------------------
-- Close_Inputs --
------------------
procedure Close_Inputs
(Parser : in out Sax_Reader'Class;
Inputs : in out Entity_Input_Source_Access)
is
procedure Free is new Unchecked_Deallocation
(Entity_Input_Source, Entity_Input_Source_Access);
Input_A : Entity_Input_Source_Access;
begin
while Inputs /= null loop
-- ??? Could use Input_Sources.Locator.Free
if Inputs.Input /= null then
Close (Inputs.Input.all);
Unchecked_Free (Inputs.Input);
end if;
-- not in string context
if not Parser.State.Ignore_Special then
End_Entity (Parser, Inputs.Name);
end if;
Input_A := Inputs;
Inputs := Inputs.Next;
Free (Input_A);
end loop;
end Close_Inputs;
-----------------
-- Debug_Print --
-----------------
procedure Debug_Print (Parser : Sax_Reader'Class; Id : Token) is
begin
Put ("++Lex (" & Parser.State.Name & ") at "
& To_String (Parser.Locator)
& " (" & Token_Type'Image (Id.Typ) & ") at "
& To_String (Id.Location));
if Parser.State.Ignore_Special then
Put (" (in string)");
end if;
if Id.Typ = Space then
declare
J : Natural := Id.First;
C : Unicode_Char;
begin
Put (" --");
while J <= Id.Last loop
Encoding.Read (Parser.Buffer.all, J, C);
Put (Unicode_Char'Image (C));
end loop;
Put ("--");
end;
elsif Id.Last >= Id.First then
Put (" --" & Parser.Buffer (Id.First .. Id.Last) & "--");
end if;
Put_Line
(" buffer="
& Parser.Buffer (Parser.Buffer'First .. Parser.Buffer_Length)
& "--");
end Debug_Print;
----------------
-- Next_Token --
----------------
procedure Next_Token
(Input : in out Input_Source'Class;
Parser : in out Sax_Reader'Class;
Id : out Token;
Coalesce_Space : Boolean := False)
is
function Looking_At (Str : Byte_Sequence) return Boolean;
-- True if the next characters read (including the current one) in the
-- stream match Str. Characters read are stored in the buffer
procedure Handle_Comments;
--
Id.Typ := Start_Of_End_Tag;
Next_Char (Input, Parser);
when Exclamation_Mark =>
Next_Char (Input, Parser);
if Parser.Last_Read = Hyphen_Minus then
Handle_Comments;
elsif Looking_At (Doctype_Sequence) then
Reset_Buffer (Parser, Id);
Id.Typ := Doctype_Start;
elsif Parser.Last_Read = Left_Square_Bracket then
Next_Char (Input, Parser);
if Parser.Last_Read = Latin_Capital_Letter_C then
if not Looking_At (Cdata_Sequence) then
Fatal_Error (Parser, Error_Invalid_Declaration, Id);
end if;
if Parser.Last_Read /= Left_Square_Bracket then
Fatal_Error (Parser, Error_Cdata_Unterminated, Id);
end if;
Reset_Buffer (Parser, Id);
Id.Typ := Cdata_Section;
Num_Closing_Bracket := 1;
loop
Next_Char (Input, Parser);
if End_Of_Stream (Parser) then
Id.Typ := End_Of_Input;
Fatal_Error (Parser, Error_Cdata_End, Id);
return;
elsif Parser.Last_Read_Is_Valid then
Put_In_Buffer (Parser, Parser.Last_Read);
if Parser.Last_Read = Right_Square_Bracket then
Num_Closing_Bracket := Num_Closing_Bracket + 1;
elsif Parser.Last_Read = Greater_Than_Sign
and then Num_Closing_Bracket >= 2
then
Parser.Buffer_Length := Parser.Buffer_Length
- 2 * Encoding.Width (Right_Square_Bracket)
- Encoding.Width (Greater_Than_Sign);
exit;
else
Num_Closing_Bracket := 0;
end if;
end if;
end loop;
if Id.Location.System_Id /= System_Id (Parser) then
Fatal_Error (Parser, Error_Entity_Self_Contained, Id);
end if;
if not Eof (Input) then
Next_Char (Input, Parser);
else
Parser.Last_Read := 16#FFFF#;
end if;
else
while Is_White_Space (Parser.Last_Read) loop
Next_Char (Input, Parser);
end loop;
if Parser.Last_Read = Latin_Capital_Letter_I
or else Parser.Last_Read = Percent_Sign
then
-- Skip spaces: if we are expending a parameter
-- entity, it must start with spaces (4.4.8)
Next_Token_Skip_Spaces (Input, Parser, Id2);
if Parser.Buffer (Id2.First .. Id2.Last) =
Include_Sequence
then
Reset_Buffer (Parser, Id2);
Id.Typ := Include;
elsif Parser.Buffer (Id2.First .. Id2.Last) =
Ignore_Sequence
then
Reset_Buffer (Parser, Id2);
Id.Typ := Ignore;
else
Fatal_Error (Parser, Error_Invalid_Declaration, Id);
end if;
if not Parser.State.In_DTD
or else not Parser.In_External_Entity
then
Fatal_Error
(Parser, Error_Conditional_Location, Id);
end if;
Next_Token_Skip_Spaces (Input, Parser, Id2);
if Id2.Typ /= Internal_DTD_Start then
Fatal_Error (Parser, Error_Conditional_Syntax, Id2);
end if;
elsif Parser.State.In_DTD then
Id.Typ := Start_Conditional;
else
Fatal_Error (Parser, Error_Unexpected_Chars1, Id);
end if;
end if;
elsif not Parser.State.In_DTD then
Fatal_Error (Parser, Error_Unexpected_Chars1, Id);
elsif Looking_At (Attlist_Sequence)
-- Since parameter entities are expanded with spaces, we can
-- have one following ATTLIST immediately
and then (Is_White_Space (Parser.Last_Read)
or else Parser.Last_Read = Percent_Sign)
then
Reset_Buffer (Parser, Id);
Id.Typ := Attlist_Def;
elsif Parser.Last_Read = Latin_Capital_Letter_E then
Next_Char (Input, Parser);
if Looking_At (Ntity_Sequence) then
Reset_Buffer (Parser, Id);
Id.Typ := Entity_Def;
elsif Looking_At (Element_Sequence) then
Reset_Buffer (Parser, Id);
Id.Typ := Element_Def;
else
Fatal_Error (Parser, Error_Unknown_Declaration);
end if;
elsif Looking_At (Notation_Sequence)
-- Since parameter entities are expanded with spaces, we can
-- have one following NOTATION immediately
and then (Is_White_Space (Parser.Last_Read)
or else Parser.Last_Read = Percent_Sign)
then
Reset_Buffer (Parser, Id);
Id.Typ := Notation;
else
Put_In_Buffer (Parser, Less_Than_Sign);
Put_In_Buffer (Parser, Exclamation_Mark);
Id.Typ := Text;
end if;
when Question_Mark =>
Id.Typ := Start_Of_PI;
Next_Char (Input, Parser);
when others => null;
end case;
end Handle_Less_Than_Sign;
-----------------------
-- Handle_Entity_Ref --
-----------------------
procedure Handle_Entity_Ref is
begin
if not Parser.Last_Read_Is_Valid
or else Is_Valid_Name_Startchar
(Parser.Last_Read, Parser.XML_Version)
then
while Parser.Last_Read_Is_Valid
and then Parser.Last_Read /= Semicolon
and then Is_Valid_Name_Char
(Parser.Last_Read, Parser.XML_Version)
loop
Put_In_Buffer (Parser, Parser.Last_Read);
Next_Char (Input, Parser);
end loop;
if not Parser.Last_Read_Is_Valid
or else System_Id (Parser) /= Id.Location.System_Id
then
Fatal_Error (Parser, Error_Entity_Self_Contained, Id);
end if;
if Parser.Last_Read /= Semicolon then
Fatal_Error (Parser, Error_Entityref_Unterminated, Id);
end if;
Id.From_Entity := True;
else
Fatal_Error (Parser, Error_Entity_Name, Id);
end if;
end Handle_Entity_Ref;
type Entity_Ref is (None, Entity, Param_Entity);
Is_Entity_Ref : Entity_Ref := None;
Old_System_Id : Symbol;
begin
if not Parser.Last_Read_Is_Valid then
Next_Char (Input, Parser);
end if;
Id.First := Parser.Buffer_Length + 1;
Id.Last := Parser.Buffer_Length;
Id.Typ := End_Of_Input;
Id.Location.System_Id := System_Id (Parser);
Id.Location.Public_Id := Public_Id (Parser);
Id.Location.Line := Get_Line_Number (Parser.Locator);
Id.Location.Column := Get_Column_Number (Parser.Locator);
Id.From_Entity := False;
Close_Inputs (Parser, Parser.Close_Inputs);
if Eof (Input) and then Parser.Last_Read = 16#FFFF# then
Id.Location.Column := Id.Location.Column + 1;
return;
end if;
if Is_White_Space (Parser.Last_Read) then
Id.Typ := Space;
loop
Put_In_Buffer (Parser, Parser.Last_Read);
Next_Char (Input, Parser);
exit when not Is_White_Space (Parser.Last_Read);
end loop;
-- If we are ignoring special characters
elsif Id.Typ = End_Of_Input
and then (Parser.Ignore_State_Special
or else Parser.State.Ignore_Special)
and then not Parser.State.Detect_End_Of_PI
then
Id.Typ := Text;
Parser.Ignore_State_Special := True;
while Parser.Last_Read_Is_Valid loop
exit when Parser.Last_Read = Ampersand
and then (Parser.State.Expand_Entities
or else Parser.State.Expand_Character_Ref);
exit when Parser.Last_Read = Percent_Sign
and then Parser.State.Expand_Param_Entities;
exit when (Parser.Last_Read = Apostrophe
or else Parser.Last_Read = Quotation_Mark)
and then Parser.State.Handle_Strings
and then (Parser.Inputs = null
or else Parser.Inputs.Handle_Strings);
exit when Parser.Last_Read = Less_Than_Sign
and then Parser.State.Less_Special;
Put_In_Buffer (Parser, Parser.Last_Read);
Next_Char (Input, Parser);
end loop;
end if;
-- If we haven't found a non-empty token yet
if Id.Typ = End_Of_Input
or else Id.First > Parser.Buffer_Length
then
case Parser.Last_Read is
when Less_Than_Sign =>
if Parser.State.Less_Special then
Id.Typ := Start_Of_Tag;
Next_Char (Input, Parser);
elsif Parser.State.Detect_End_Of_PI then
Put_In_Buffer (Parser, Parser.Last_Read);
Id.Typ := Text;
Next_Char (Input, Parser);
else
Handle_Less_Than_Sign;
end if;
when Question_Mark =>
if Eof (Input) then
Put_In_Buffer (Parser, Parser.Last_Read);
Id.Typ := Text;
else
Next_Char (Input, Parser);
if Parser.Last_Read = Greater_Than_Sign then
Id.Typ := End_Of_PI;
Next_Char (Input, Parser);
elsif Parser.Last_Read = Question_Mark then
Put_In_Buffer (Parser, Question_Mark);
Id.Typ := Text;
else
Put_In_Buffer (Parser, Question_Mark);
Id.Typ := Text;
end if;
end if;
when Greater_Than_Sign =>
if Parser.State.Greater_Special then
Id.Typ := End_Of_Tag;
else
Put_In_Buffer (Parser, Parser.Last_Read);
Id.Typ := Text;
end if;
Next_Char (Input, Parser);
when Equals_Sign =>
if Parser.State.In_Tag then
Id.Typ := Equal;
else
Put_In_Buffer (Parser, Parser.Last_Read);
Id.Typ := Text;
end if;
Next_Char (Input, Parser);
when Unicode.Names.Basic_Latin.Colon =>
if Parser.State.In_Tag then
if Parser.Feature_Namespace then
Id.Typ := Colon;
else
Put_In_Buffer (Parser, Parser.Last_Read);
Id.Typ := Name;
end if;
else
Put_In_Buffer (Parser, Parser.Last_Read);
Id.Typ := Text;
end if;
Next_Char (Input, Parser);
when Ampersand =>
Id.Typ := Text; -- So that eof would at least report an error
if Eof (Input)
and then Parser.State.Expand_Entities
then
Fatal_Error (Parser, Error_Entityref_Unterminated, Id);
end if;
Next_Char (Input, Parser);
if Parser.Last_Read = Number_Sign
and then (Parser.State.Expand_Character_Ref
or Parser.State.Report_Character_Ref)
then
Handle_Character_Ref;
if System_Id (Parser) /= Id.Location.System_Id then
Fatal_Error (Parser, Error_Entity_Self_Contained, Id);
end if;
elsif Parser.Last_Read /= Number_Sign
and then Parser.State.Expand_Entities
then
Handle_Entity_Ref;
Is_Entity_Ref := Entity;
elsif Parser.Last_Read /= Number_Sign
and then Parser.State.Ignore_Special -- string context
and then not Parser.State.Detect_End_Of_PI -- not in PI
then
-- Inside a string (entity value), we still need to check
-- that the '&' marks the beginning of an entity reference.
Put_In_Buffer (Parser, Ampersand);
Handle_Entity_Ref;
Put_In_Buffer (Parser, Parser.Last_Read);
Next_Char (Input, Parser);
else
Put_In_Buffer (Parser, Ampersand);
end if;
when Percent_Sign =>
Put_In_Buffer (Parser, Parser.Last_Read);
Id.Typ := Text;
Next_Char (Input, Parser);
if Parser.State.Expand_Param_Entities then
while Parser.Last_Read /= Semicolon
and then Is_Valid_Name_Char
(Parser.Last_Read, Parser.XML_Version)
loop
Put_In_Buffer (Parser, Parser.Last_Read);
Next_Char (Input, Parser);
end loop;
if Parser.Last_Read /= Semicolon then
Fatal_Error (Parser, Error_Entityref_Unterminated);
end if;
Is_Entity_Ref := Param_Entity;
end if;
when Quotation_Mark =>
if Parser.State.Handle_Strings then
Id.Typ := Double_String_Delimiter;
Next_Char (Input, Parser);
else
Id.Typ := Text;
Put_In_Buffer (Parser, Parser.Last_Read);
Next_Char (Input, Parser);
end if;
when Apostrophe =>
if Parser.State.Handle_Strings then
Id.Typ := Single_String_Delimiter;
Next_Char (Input, Parser);
else
Id.Typ := Text;
Put_In_Buffer (Parser, Parser.Last_Read);
Next_Char (Input, Parser);
end if;
when Left_Square_Bracket =>
if Parser.State.In_DTD then
Id.Typ := Internal_DTD_Start;
else
Put_In_Buffer (Parser, Parser.Last_Read);
Id.Typ := Text;
end if;
Next_Char (Input, Parser);
when Right_Square_Bracket =>
if Parser.State.In_DTD
and then not Parser.In_External_Entity
then
Id.Typ := Internal_DTD_End;
loop
Next_Char (Input, Parser);
exit when Parser.Last_Read = Greater_Than_Sign;
if Parser.Last_Read_Is_Valid
and then not Is_White_Space (Parser.Last_Read)
then
Fatal_Error (Parser, Error_Unexpected_Chars2, Id);
end if;
end loop;
Next_Char (Input, Parser);
-- In string context ?
elsif Parser.State.Ignore_Special then
Id.Typ := Text;
Put_In_Buffer (Parser, Parser.Last_Read);
Next_Char (Input, Parser);
else
declare
Num_Bracket : Natural := 1;
begin
Id.Typ := Text;
loop
Put_In_Buffer (Parser, Parser.Last_Read);
Next_Char (Input, Parser);
if Parser.Last_Read = Right_Square_Bracket then
Num_Bracket := Num_Bracket + 1;
elsif Num_Bracket >= 2
and Parser.Last_Read = Greater_Than_Sign
then
if Parser.State.In_DTD
and then Parser.In_External_Entity
then
Id.Typ := End_Conditional;
Reset_Buffer (Parser, Id);
Next_Char (Input, Parser);
exit;
else
Id.Location.Column :=
Id.Location.Column + Num_Bracket - 2;
Fatal_Error
(Parser, Error_Unexpected_Chars3, Id);
end if;
else
exit;
end if;
end loop;
end;
end if;
when Solidus =>
Id.Typ := Text;
Next_Char (Input, Parser);
if Parser.State.Greater_Special
and then Parser.Last_Read = Greater_Than_Sign
then
Id.Typ := End_Of_Start_Tag;
Next_Char (Input, Parser);
else
Put_In_Buffer (Parser, Solidus);
end if;
when others =>
if Parser.State.Recognize_External then
if Parser.Last_Read = Latin_Capital_Letter_A then
if Looking_At (Any_Sequence) then
Reset_Buffer (Parser, Id);
Id.Typ := Any;
else
Id.Typ := Name;
end if;
elsif Parser.Last_Read = Latin_Capital_Letter_E then
if Looking_At (Empty_Sequence) then
Reset_Buffer (Parser, Id);
Id.Typ := Empty;
else
Id.Typ := Name;
end if;
elsif Parser.Last_Read = Latin_Capital_Letter_N then
if Looking_At (Ndata_Sequence) then
Reset_Buffer (Parser, Id);
Id.Typ := Ndata;
else
Id.Typ := Name;
end if;
elsif Parser.Last_Read = Latin_Capital_Letter_P then
if Looking_At (Public_Sequence) then
Reset_Buffer (Parser, Id);
Id.Typ := Public;
else
Id.Typ := Name;
end if;
elsif Parser.Last_Read = Latin_Capital_Letter_S then
if Looking_At (System_Sequence) then
Reset_Buffer (Parser, Id);
Id.Typ := System;
else
Id.Typ := Name;
end if;
end if;
end if;
if Parser.State.Report_Parenthesis
and then Parser.Last_Read = Left_Parenthesis
then
Reset_Buffer (Parser, Id);
Id.Typ := Open_Paren;
Next_Char (Input, Parser);
return;
end if;
if Parser.State.In_Attlist then
if Parser.Last_Read = Latin_Capital_Letter_C then
if Looking_At (Cdata_Sequence) then
Id.Typ := Cdata;
else
Id.Typ := Name;
end if;
elsif Parser.Last_Read = Latin_Capital_Letter_E
and then Looking_At (Entit_Sequence)
then
if Looking_At (Ies_Sequence) then
Id.Typ := Entities;
elsif Parser.Last_Read = Latin_Capital_Letter_Y then
Id.Typ := Entity;
Put_In_Buffer (Parser, Parser.Last_Read);
Next_Char (Input, Parser);
else
Fatal_Error (Parser, Error_Attlist_Type);
end if;
elsif Parser.Last_Read = Latin_Capital_Letter_I
and then Looking_At (Id_Sequence)
then
if Looking_At (Ref_Sequence) then
if Parser.Last_Read = Latin_Capital_Letter_S then
Id.Typ := Idrefs;
Put_In_Buffer (Parser, Parser.Last_Read);
Next_Char (Input, Parser);
else
Id.Typ := Idref;
end if;
else
Id.Typ := Id_Type;
end if;
elsif Parser.Last_Read = Latin_Capital_Letter_N then
Next_Char (Input, Parser);
if Looking_At (Mtoken_Sequence) then
if Parser.Last_Read = Latin_Capital_Letter_S then
Id.Typ := Nmtokens;
Next_Char (Input, Parser);
else
Id.Typ := Nmtoken;
end if;
elsif Looking_At (Otation_Sequence) then
Id.Typ := Notation;
else
Fatal_Error (Parser, Error_Attlist_Type);
end if;
elsif Parser.Last_Read = Number_Sign then
Put_In_Buffer (Parser, Parser.Last_Read);
Next_Char (Input, Parser);
if Looking_At (Implied_Sequence) then
Id.Typ := Implied;
elsif Looking_At (Required_Sequence) then
Id.Typ := Required;
elsif Looking_At (Fixed_Sequence) then
Id.Typ := Fixed;
else
Fatal_Error (Parser, Error_Attlist_DefaultDecl);
end if;
end if;
end if;
end case;
-- try to coalesce as many things as possible into a single
-- text event
if Id.Typ = End_Of_Input then
if Is_Valid_Name_Startchar (Parser.Last_Read, Parser.XML_Version)
or else Parser.Last_Read = Low_Line
then
Id.Typ := Name;
Put_In_Buffer (Parser, Parser.Last_Read);
Next_Char (Input, Parser);
else
Id.Typ := Text;
end if;
end if;
if Id.Typ = Name and then not Coalesce_Space then
while
(Parser.Last_Read /= Unicode.Names.Basic_Latin.Colon
or else not Parser.Feature_Namespace)
and then
Is_Valid_NCname_Char (Parser.Last_Read, Parser.XML_Version)
loop
Put_In_Buffer (Parser, Parser.Last_Read);
Next_Char (Input, Parser);
end loop;
elsif Is_Entity_Ref = None
and then (Id.Typ = Text
or else (Coalesce_Space and then Id.Typ = Name))
then
if not Parser.Last_Read_Is_Valid then
Next_Char (Input, Parser);
else
loop
if Is_White_Space (Parser.Last_Read) then
exit when not Coalesce_Space;
else
case Parser.Last_Read is
when Greater_Than_Sign =>
exit when Parser.State.Greater_Special;
when Less_Than_Sign -- Start of new tag
| Ampersand -- for Entities
| Right_Square_Bracket -- for CData ]]>
| Quotation_Mark -- for attributes a="..."
| Apostrophe -- for attributes a='...'
| Equals_Sign => -- for attributes
exit;
when Solidus => -- For
declare
C : Unicode_Char;
begin
Lookup_Char (Input, Parser, C);
exit when C = Greater_Than_Sign
or else Id.Typ = Name;
end;
when Percent_Sign =>
exit when Parser.State.Expand_Param_Entities;
when Question_Mark =>
exit when Parser.State.Detect_End_Of_PI;
when others =>
null;
end case;
end if;
Put_In_Buffer (Parser, Parser.Last_Read);
Next_Char (Input, Parser);
exit when not Parser.Last_Read_Is_Valid;
end loop;
end if;
end if;
Parser.Ignore_State_Special := False;
end if;
if Coalesce_Space and then Id.Typ = Space then
-- First character is necessarily not a space, so we'll change the
-- type of the token to text
declare
Save_Length : constant Natural := Parser.Buffer_Length;
begin
while Parser.Last_Read_Is_Valid
and then (not Parser.State.Greater_Special
or else Parser.Last_Read /= Greater_Than_Sign)
and then Parser.Last_Read /= Less_Than_Sign
and then Parser.Last_Read /= Ampersand
and then (not Parser.State.Expand_Param_Entities
or else Parser.Last_Read /= Percent_Sign)
and then Parser.Last_Read /= Equals_Sign
and then Parser.Last_Read /= Quotation_Mark
and then Parser.Last_Read /= Right_Square_Bracket
and then Parser.Last_Read /= Apostrophe
and then Parser.Last_Read /= Solidus
and then (Parser.Last_Read /= Question_Mark
or else not Parser.State.Detect_End_Of_PI)
loop
Put_In_Buffer (Parser, Parser.Last_Read);
Next_Char (Input, Parser);
end loop;
-- Special case for ']': since the parser needs to detect whether
-- this is the beginning of ']]>', this will be done in the next
-- call to Next_Token. However, we shouldn't report the spaces as
-- Ignorable_Whitespace in this case.
if Parser.Last_Read = Right_Square_Bracket
or else Parser.Buffer_Length /= Save_Length
then
Id.Typ := Text;
end if;
end;
end if;
Id.Last := Parser.Buffer_Length;
if Debug_Lexical then
Debug_Print (Parser, Id);
end if;
-- Internal entities should be processes inline
if Is_Entity_Ref /= None then
declare
N : constant Symbol := Find_Symbol (Parser, Id);
V : constant Entity_Entry_Access := Get (Parser.Entities, N);
begin
Reset_Buffer (Parser, Id);
if N = Parser.Lt_Sequence then
Put_In_Buffer (Parser, Less_Than_Sign);
Id.Typ := Text;
Id.Last := Parser.Buffer_Length;
Next_Char (Input, Parser);
elsif N = Parser.Gt_Sequence then
Put_In_Buffer (Parser, Greater_Than_Sign);
Id.Typ := Text;
Id.Last := Parser.Buffer_Length;
Next_Char (Input, Parser);
elsif N = Parser.Amp_Sequence then
Put_In_Buffer (Parser, Ampersand);
Id.Typ := Text;
Id.Last := Parser.Buffer_Length;
Next_Char (Input, Parser);
elsif N = Parser.Apos_Sequence then
Put_In_Buffer (Parser, Apostrophe);
Id.Typ := Text;
Id.Last := Parser.Buffer_Length;
Next_Char (Input, Parser);
elsif N = Parser.Quot_Sequence then
Put_In_Buffer (Parser, Quotation_Mark);
Id.Typ := Text;
Id.Last := Parser.Buffer_Length;
Next_Char (Input, Parser);
elsif V = null then
declare
Sym : constant Cst_Byte_Sequence_Access := Get (N);
begin
Skipped_Entity (Parser, N);
if N = Parser.Symbol_Ampersand
or else N = Parser.Symbol_Percent
then
Fatal_Error (Parser, Error_Entity_Name & " '"
& Sym.all & "'", Id);
elsif Sym (Sym'First) = '%' then
Error (Parser, Error_Entity_Undefined & " '"
& Sym.all & "'", Id);
elsif not Parser.In_External_Entity then
-- WF Entity Declared
Fatal_Error
(Parser, Error_Entity_Undefined & " '"
& Sym.all & ''', Id);
else
-- if Parser.Feature_Validation then
-- VC Entity Declared
Error
(Parser, Error_Entity_Undefined & " '"
& Sym.all & ''', Id);
end if;
end;
Id.Typ := Text;
Id.Last := Id.First - 1;
Next_Char (Input, Parser);
else
if Parser.Standalone_Document
and then V.External_Declaration
then
-- 4.1 WF Entity Declared
Fatal_Error
(Parser, Error_Entity_Not_Standalone, Id);
end if;
if Is_Entity_Ref = Entity
and then Parser.Current_Node = null
and then not Parser.State.In_DTD
then
Fatal_Error (Parser, Error_Entity_Toplevel, Id);
-- Else if we are in the internal subset of the DTD, and in
-- a context other than a declaration
elsif Is_Entity_Ref = Param_Entity
and then not Parser.In_External_Entity
and then Parser.State.Name /= DTD_State.Name
then
Fatal_Error (Parser, Error_ParamEntity_In_Attribute, Id);
end if;
Close_Inputs (Parser, Parser.Close_Inputs);
-- not in string context
if not Parser.State.Ignore_Special then
Start_Entity (Parser, N);
end if;
if V.Already_Read then
Fatal_Error (Parser, Error_Entity_Self_Ref, Id);
end if;
V.Already_Read := True;
Parser.Element_Id := Parser.Element_Id + 1;
if Debug_Internal then
Put_Line ("Expanding entity " & Get (N).all & " External="
& V.External'Img
& " Value=" & Get (V.Value).all);
end if;
Old_System_Id := Get_System_Id (Parser.Locator);
Parser.Inputs := new Entity_Input_Source'
(External => V.External,
Name => N,
Input => null,
Save_Loc => Get_Location (Parser.Locator),
System_Id => Find_Symbol
(Parser, Get (System_Id (Parser)).all & '#' & Get (N).all),
Public_Id => Find_Symbol
(Parser, Get (Public_Id (Parser)).all & '#' & Get (N).all),
Handle_Strings => not Parser.State.Ignore_Special,
Next => Parser.Inputs);
if V.External then
if Parser.State.Name = Attlist_Str_Def_State.Name
or else Parser.State.Name = Attr_Value_State.Name
then
Fatal_Error (Parser, Error_Attribute_External_Entity, Id);
end if;
declare
URI : constant Symbol :=
Resolve_URI (Parser, Old_System_Id, V.Value);
begin
Parser.Inputs.Input := Resolve_Entity
(Parser,
Public_Id => Get (V.Public).all,
System_Id => Get (URI).all);
-- If either there is no entity resolver or if the
-- standard algorithm should be used
if Parser.Inputs.Input = null then
Parser.Inputs.Input := new File_Input;
Open (Get (URI).all,
File_Input (Parser.Inputs.Input.all));
Set_Public_Id
(Parser.Inputs.Input.all, Get (V.Value).all);
Set_System_Id (Parser.Inputs.Input.all, Get (URI).all);
end if;
Parser.Inputs.Name := Find_Symbol
(Parser, Get_System_Id (Parser.Inputs.Input.all));
Set_System_Id (Parser.Locator, URI);
Set_Public_Id (Parser.Locator, V.Value);
exception
when Name_Error =>
Error
(Parser, Error_External_Entity_Not_Found
& Get (URI).all, Id);
Unchecked_Free (Parser.Inputs.Input);
when E : Mismatching_BOM =>
Error (Parser, Exception_Message (E));
Unchecked_Free (Parser.Inputs.Input);
end;
Parser.In_External_Entity := True;
else
Parser.Inputs.Input := new String_Input;
-- 4.4.8: Expansion of parameter entities must include
-- a leading and trailing space, unless we are within an
-- entity value.
if Is_Entity_Ref = Param_Entity
and then not Parser.State.Ignore_Special
then
Open (' ' & Get (V.Value).all & ' ',
Encoding,
String_Input (Parser.Inputs.Input.all));
else
Open (Get (V.Value).all, Encoding,
String_Input (Parser.Inputs.Input.all));
end if;
Set_Public_Id
(Parser.Locator,
Find_Symbol (Parser, "entity " & Get (N).all));
Set_Public_Id
(Parser.Inputs.Input.all,
Get (Get_Public_Id (Parser.Locator)).all);
end if;
if Parser.Inputs.Input = null then
Skipped_Entity (Parser, V.Name);
Next_Char (Input, Parser);
Next_Token (Input, Parser, Id);
else
Set_Line_Number (Parser.Locator, 1);
Set_Column_Number
(Parser.Locator,
Prolog_Size (Parser.Inputs.Input.all));
Next_Char (Input, Parser);
Next_Token (Input, Parser, Id);
V.Already_Read := False;
end if;
end if;
end;
end if;
end Next_Token;
----------------------------
-- Next_Token_Skip_Spaces --
----------------------------
procedure Next_Token_Skip_Spaces
(Input : in out Input_Sources.Input_Source'Class;
Parser : in out Sax_Reader'Class;
Id : out Token;
Must_Have : Boolean := False) is
begin
Next_Token (Input, Parser, Id);
if Must_Have and then Id.Typ /= Space then
Fatal_Error (Parser, Error_Expecting_Space, Id);
end if;
while Id.Typ = Space loop
Reset_Buffer (Parser, Id);
Next_Token (Input, Parser, Id);
end loop;
end Next_Token_Skip_Spaces;
-------------------------------
-- Next_NS_Token_Skip_Spaces --
-------------------------------
procedure Next_NS_Token_Skip_Spaces
(Input : in out Input_Sources.Input_Source'Class;
Parser : in out Sax_Reader'Class;
NS_Id : out Token;
Name_Id : out Token)
is
Id : Token;
Saved_In_Tag : constant Boolean := Parser.State.In_Tag;
begin
NS_Id := Null_Token;
Next_Token (Input, Parser, Id);
while Id.Typ = Space loop
Reset_Buffer (Parser, Id);
Next_Token (Input, Parser, Id);
end loop;
Name_Id := Id;
if Name_Id.Typ = Colon then
-- An empty namespace, used in the XML testsuite ?
NS_Id := Null_Token;
Reset_Buffer (Parser, Id);
Next_Token (Input, Parser, Name_Id);
elsif Name_Id.Typ = Name then
if Parser.Last_Read_Is_Valid
and then Parser.Last_Read = Unicode.Names.Basic_Latin.Colon
and then Parser.Feature_Namespace
then
Parser.State.In_Tag := True; -- Get COLON on its own
Next_Token (Input, Parser, Id);
Parser.State.In_Tag := Saved_In_Tag;
NS_Id := Name_Id;
Reset_Buffer (Parser, Id);
Next_Token (Input, Parser, Name_Id);
end if;
end if;
end Next_NS_Token_Skip_Spaces;
------------------
-- Reset_Buffer --
------------------
procedure Reset_Buffer
(Parser : in out Sax_Reader'Class; Id : Token := Null_Token) is
begin
Parser.Buffer_Length := Id.First - 1;
end Reset_Buffer;
---------------
-- Set_State --
---------------
procedure Set_State
(Parser : in out Sax_Reader'Class; State : Parser_State) is
begin
Parser.State := State;
end Set_State;
---------------
-- Get_State --
---------------
function Get_State (Parser : Sax_Reader'Class) return Parser_State is
begin
return Parser.State;
end Get_State;
-------------------------
-- Parse_Element_Model --
-------------------------
procedure Parse_Element_Model
(Input : in out Input_Source'Class;
Parser : in out Sax_Reader'Class;
Result : out Element_Model_Ptr;
Attlist : Boolean := False;
Open_Was_Read : Boolean)
is
-- ??? Would be nice to get rid of this hard-coded limitation in stacks
Stack_Size : constant Natural := 1024;
Operand_Stack : Element_Model_Array (1 .. Stack_Size);
Operand_Index : Natural := Operand_Stack'First;
Operator_Stack : array (1 .. Stack_Size) of Unicode_Char;
Operator_Index : Natural := Operator_Stack'First;
Expect_Operator : Boolean := not Open_Was_Read;
procedure Parse_Element_Model_From_Entity (Name : Symbol);
-- Parse the element model defined in the entity Name, and leave the
-- contents on the stacks.
procedure Parse
(Input : in out Input_Source'Class;
Result : out Element_Model_Ptr;
Open_Was_Read : Boolean;
Is_Recursive_Call : Boolean);
-- Parse the content model read in Input
-- Is_Recursive_Call should be true when called from itself or from
-- Parse_Element_Model_From_Entity.
-------------------------------------
-- Parse_Element_Model_From_Entity --
-------------------------------------
procedure Parse_Element_Model_From_Entity (Name : Symbol) is
Loc : Sax.Locators.Location;
Last : constant Unicode_Char := Parser.Last_Read;
Input_S : String_Input;
Val : constant Entity_Entry_Access := Get (Parser.Entities, Name);
M : Element_Model_Ptr;
begin
if Val = null then
Fatal_Error
(Parser,
Error_Entity_Undefined & ' ' & Get (Name).all);
elsif Val.Value = Empty_String then
return;
else
Loc := Get_Location (Parser.Locator);
Set_Line_Number (Parser.Locator, 1);
Set_Column_Number (Parser.Locator, 1);
Set_Public_Id
(Parser.Locator,
Find_Symbol (Parser, "entity " & Get (Name).all));
Open (Get (Val.Value).all, Encoding, Input_S);
Next_Char (Input_S, Parser);
Parse (Input_S, M, False, True);
-- Parse_Element_Model (Input_S, Parser, M, Attlist, False);
Close (Input_S);
Set_Location (Parser.Locator, Loc);
Parser.Last_Read := Last;
end if;
end Parse_Element_Model_From_Entity;
-----------
-- Parse --
-----------
procedure Parse
(Input : in out Input_Source'Class;
Result : out Element_Model_Ptr;
Open_Was_Read : Boolean;
Is_Recursive_Call : Boolean)
is
Num_Items : Positive;
Current_Item, Current_Operand : Natural;
Start_Sub : Natural := Parser.Buffer_Length + 1;
M : Element_Model_Ptr;
Found : Boolean;
Start_Id : constant Symbol := System_Id (Parser);
Start_Token : Token;
Test_Multiplier : Boolean;
Can_Be_Mixed : Boolean;
Num_Parenthesis : Integer := 0;
Already_Displayed_Self_Contained_Error : Boolean := False;
begin
Start_Token := Null_Token;
Start_Token.Location.Line := Get_Line_Number (Parser.Locator);
Start_Token.Location.Column := Get_Column_Number (Parser.Locator);
if Open_Was_Read then
Start_Token.Location.Column := Start_Token.Location.Column - 1;
end if;
while Is_White_Space (Parser.Last_Read) loop
Next_Char (Input, Parser);
end loop;
loop
if End_Of_Stream (Parser) then
if not Is_Recursive_Call then
for J in Operand_Stack'First .. Operand_Index - 1 loop
Free (Operand_Stack (J));
end loop;
elsif Num_Parenthesis /= 0 then
Fatal_Error (Parser, Error_Entity_Nested, Start_Token);
elsif Parser.Buffer_Length >= Start_Sub then
Operand_Stack (Operand_Index) :=
new Element_Model (Element_Ref);
Operand_Stack (Operand_Index).Name := Find_Symbol
(Parser,
Parser.Buffer (Start_Sub .. Parser.Buffer_Length));
Operand_Index := Operand_Index + 1;
Parser.Buffer_Length := Start_Sub - 1;
end if;
exit;
end if;
if Parser.Feature_Validation
and then (not Parser.Last_Read_Is_Valid
or else System_Id (Parser) /= Start_Id)
and then not Already_Displayed_Self_Contained_Error
then
Already_Displayed_Self_Contained_Error := True;
Error (Parser, Error_Entity_Self_Contained, Start_Token);
end if;
Test_Multiplier := False;
-- Process the operator
case Parser.Last_Read is
when Left_Parenthesis =>
Operator_Stack (Operator_Index) := Parser.Last_Read;
Operator_Index := Operator_Index + 1;
Expect_Operator := False;
Next_Char (Input, Parser);
Num_Parenthesis := Num_Parenthesis + 1;
when Right_Parenthesis =>
Num_Parenthesis := Num_Parenthesis - 1;
Num_Items := 1;
Current_Item := Operator_Index - 1;
Current_Operand := Operand_Index - 1;
Can_Be_Mixed := Current_Operand >= Operand_Stack'First
and then
(Operand_Stack (Current_Operand).Content = Character_Data
or else Operand_Stack (Current_Operand).Content
= Element_Ref);
if Current_Operand >= Operand_Stack'First
and then Is_Mixed (Operand_Stack (Current_Operand))
then
Fatal_Error (Parser, Error_Mixed_Contents);
end if;
while Current_Item >= Operator_Stack'First
and then
Operator_Stack (Current_Item) /= Left_Parenthesis
loop
if Operator_Stack (Current_Item) /= Comma
and then Operator_Stack (Current_Item) /= Vertical_Line
then
Fatal_Error
(Parser, Error_Invalid_Content_Model, Start_Token);
end if;
if Current_Operand = 0 then
Fatal_Error
(Parser, Error_Missing_Operand, Start_Token);
end if;
Current_Operand := Current_Operand - 1;
if Current_Operand < Operand_Stack'First then
Fatal_Error
(Parser, Error_Invalid_Content_Model, Start_Token);
end if;
if Operand_Stack (Current_Operand).Content
/= Character_Data and then
Operand_Stack (Current_Operand).Content /= Element_Ref
then
Can_Be_Mixed := False;
end if;
if Is_Mixed (Operand_Stack (Current_Operand)) then
Fatal_Error (Parser, Error_Mixed_Contents);
end if;
Num_Items := Num_Items + 1;
Current_Item := Current_Item - 1;
end loop;
if Current_Item < Operator_Stack'First then
Fatal_Error
(Parser, Error_Invalid_Content_Model, Start_Token);
end if;
if Current_Operand < Operand_Stack'First then
Fatal_Error
(Parser, Error_Content_Model_Empty_List, Start_Token);
end if;
if Operator_Stack (Operator_Index - 1) = Comma then
M := new Element_Model (Sequence);
else
if not Can_Be_Mixed
and then Operand_Stack (Current_Operand).Content
= Character_Data
then
Fatal_Error
(Parser, Error_Content_Model_Nested_Groups);
end if;
M := new Element_Model (Any_Of);
end if;
M.List := new Element_Model_Array (1 .. Num_Items);
for J in Current_Operand .. Operand_Index - 1 loop
M.List (J - Current_Operand + 1) := Operand_Stack (J);
end loop;
Operand_Index := Current_Operand + 1;
Operand_Stack (Current_Operand) := M;
Operator_Index := Current_Item;
Expect_Operator := False;
Test_Multiplier := True;
Next_Char (Input, Parser);
if not End_Of_Stream (Parser)
and then Current_Operand >= Operand_Stack'First
and then Is_Mixed (Operand_Stack (Current_Operand))
and then Operand_Stack (Current_Operand).List'Length >= 2
and then Parser.Last_Read /= Asterisk
then
Fatal_Error
(Parser, Error_Content_Model_Closing_Paren);
end if;
when Comma | Vertical_Line =>
if Attlist and then Parser.Last_Read = Comma then
Fatal_Error (Parser, Error_Attlist_Invalid_Enum);
end if;
if Parser.Last_Read = Comma
and then Operand_Index - 1 < Operand_Stack'First
then
Fatal_Error (Parser, Error_Content_Model_Invalid_Seq);
end if;
if Parser.Last_Read = Comma
and then Operator_Stack (Operator_Index - 1)
= Left_Parenthesis
and then Operand_Stack (Operand_Index - 1).Content
= Character_Data
then
Fatal_Error (Parser, Error_Content_Model_Pcdata);
end if;
if Operator_Index = Operator_Stack'First
or else
(Operator_Stack (Operator_Index - 1) /= Parser.Last_Read
and then
Operator_Stack (Operator_Index - 1) /=
Left_Parenthesis)
then
Fatal_Error (Parser, Error_Content_Model_Mixing);
end if;
Operator_Stack (Operator_Index) := Parser.Last_Read;
Operator_Index := Operator_Index + 1;
Expect_Operator := False;
Next_Char (Input, Parser);
when Asterisk | Question_Mark | Plus_Sign =>
Fatal_Error
(Parser, Error_Content_Model_Invalid_Multiplier,
Start_Token);
when Number_Sign =>
if Expect_Operator then
Fatal_Error
(Parser, Error_Content_Model_Invalid_Start,
Start_Token);
end if;
Expect_Operator := True;
-- #PCDATA can only be the first element of a choice list
-- ??? Note that in that case the Choice model can only be a
-- list of names, not a parenthesis expression.
Start_Sub := Parser.Buffer_Length + 1;
Next_Char (Input, Parser);
Found := (Parser.Last_Read = Latin_Capital_Letter_P);
if Found then
Next_Char (Input, Parser);
Found := (Parser.Last_Read = Latin_Capital_Letter_C);
if Found then
Next_Char (Input, Parser);
Found := (Parser.Last_Read = Latin_Capital_Letter_D);
if Found then
Next_Char (Input, Parser);
Found := Parser.Last_Read = Latin_Capital_Letter_A;
if Found then
Next_Char (Input, Parser);
Found :=
(Parser.Last_Read = Latin_Capital_Letter_T);
if Found then
Next_Char (Input, Parser);
Found :=
(Parser.Last_Read = Latin_Capital_Letter_A);
end if;
end if;
end if;
end if;
end if;
if not Found then
Fatal_Error
(Parser, Error_Content_Model_Invalid_Seq, Start_Token);
end if;
if Operator_Stack (Operator_Index - 1)
/= Left_Parenthesis
then
Fatal_Error (Parser, Error_Content_Model_Pcdata_First);
end if;
Operand_Stack (Operand_Index) :=
new Element_Model (Character_Data);
Operand_Index := Operand_Index + 1;
Parser.Buffer_Length := Start_Sub - 1;
Next_Char (Input, Parser);
when Percent_Sign =>
if not Parser.In_External_Entity
and then Parser.State.Name /= DTD_State.Name
then
Fatal_Error (Parser, Error_ParamEntity_In_Attribute);
end if;
Start_Sub := Parser.Buffer_Length + 1;
while Parser.Last_Read_Is_Valid
and then Parser.Last_Read /= Semicolon
loop
Put_In_Buffer (Parser, Parser.Last_Read);
Next_Char (Input, Parser);
end loop;
Parse_Element_Model_From_Entity
(Find_Symbol
(Parser,
Parser.Buffer (Start_Sub .. Parser.Buffer_Length)));
Parser.Buffer_Length := Start_Sub - 1;
Next_Char (Input, Parser);
when others =>
if Parser.Last_Read_Is_Valid then
if Expect_Operator then
Fatal_Error
(Parser, Error_Content_Model_Expect_Operator);
end if;
Expect_Operator := True;
-- ??? Should test Is_Nmtoken
Start_Sub := Parser.Buffer_Length + 1;
while Parser.Last_Read = Unicode.Names.Basic_Latin.Colon
or else Is_Valid_Name_Char
(Parser.Last_Read, Parser.XML_Version)
loop
Put_In_Buffer (Parser, Parser.Last_Read);
Next_Char (Input, Parser);
end loop;
if Start_Sub > Parser.Buffer_Length then
Error (Parser, Error_Content_Model_Invalid_Name
& Debug_Encode (Parser.Last_Read),
Start_Token);
end if;
Operand_Stack (Operand_Index) :=
new Element_Model (Element_Ref);
Operand_Stack (Operand_Index).Name := Find_Symbol
(Parser,
Parser.Buffer (Start_Sub .. Parser.Buffer_Length));
Operand_Index := Operand_Index + 1;
Parser.Buffer_Length := Start_Sub - 1;
Test_Multiplier := True;
else
-- Could happen with improper entity nesting
Next_Char (Input, Parser);
end if;
end case;
if Test_Multiplier then
case Parser.Last_Read is
when Asterisk =>
if Operand_Index = Operand_Stack'First then
Fatal_Error
(Parser, Error_Content_Model_Invalid_Multiplier);
end if;
Operand_Stack (Operand_Index - 1) := new Element_Model'
(Repeat, 0, Positive'Last,
Operand_Stack (Operand_Index - 1));
Expect_Operator := True;
Next_Char (Input, Parser);
when Plus_Sign =>
if Operand_Index = Operand_Stack'First then
Fatal_Error
(Parser, Error_Content_Model_Invalid_Multiplier);
end if;
if Is_Mixed (Operand_Stack (Operand_Index - 1)) then
Fatal_Error
(Parser, Error_Content_Model_Pcdata_Occurrence);
end if;
Operand_Stack (Operand_Index - 1) := new Element_Model'
(Repeat, 1,
Positive'Last, Operand_Stack (Operand_Index - 1));
Expect_Operator := True;
Next_Char (Input, Parser);
when Question_Mark =>
if Operand_Index = Operand_Stack'First then
Fatal_Error
(Parser, Error_Content_Model_Invalid_Multiplier);
end if;
if Is_Mixed (Operand_Stack (Operand_Index - 1)) then
Fatal_Error
(Parser, Error_Content_Model_Pcdata_Occurrence);
end if;
Operand_Stack (Operand_Index - 1) := new Element_Model'
(Repeat, 0, 1, Operand_Stack (Operand_Index - 1));
Expect_Operator := True;
Next_Char (Input, Parser);
when others => null;
end case;
end if;
exit when Operator_Index = Operator_Stack'First
and then Operand_Index = Operand_Stack'First + 1;
while Is_White_Space (Parser.Last_Read) loop
Next_Char (Input, Parser);
end loop;
end loop;
if not Is_Recursive_Call then
if Operator_Index /= Operator_Stack'First
or else Operand_Index /= Operand_Stack'First + 1
then
Error
(Parser, Error_Content_Model_Invalid, Start_Token);
end if;
Result := Operand_Stack (Operand_Stack'First);
elsif Num_Parenthesis /= 0 then
Error (Parser, Error_Entity_Nested, Start_Token);
end if;
exception
when others =>
if not Is_Recursive_Call then
for J in Operand_Stack'First .. Operand_Index - 1 loop
Free (Operand_Stack (J));
end loop;
end if;
raise;
end Parse;
begin
if Open_Was_Read then
-- Insert the opening parenthesis into the operators stack
Operator_Stack (Operator_Stack'First) := Left_Parenthesis;
Operator_Index := Operator_Index + 1;
end if;
Parse (Input, Result, Open_Was_Read, False);
end Parse_Element_Model;
--------------------------------
-- Check_Valid_Name_Or_NCname --
--------------------------------
procedure Check_Valid_Name_Or_NCname
(Parser : in out Sax_Reader'Class;
Name : Token)
is
begin
if Parser.Feature_Namespace then
if not Is_Valid_NCname
(Parser.Buffer (Name.First .. Name.Last), Parser.XML_Version)
then
Fatal_Error (Parser, Error_Is_Ncname, Name);
end if;
else
if not Is_Valid_Name
(Parser.Buffer (Name.First .. Name.Last), Parser.XML_Version)
then
Fatal_Error (Parser, Error_Is_Name, Name);
end if;
end if;
end Check_Valid_Name_Or_NCname;
---------------------------
-- Check_Attribute_Value --
---------------------------
procedure Check_Attribute_Value
(Parser : in out Sax_Reader'Class;
Local_Name : Symbol;
Typ : Attribute_Type;
Value : Symbol;
Error_Loc : Token)
is
Ent : Entity_Entry_Access;
Val : constant Cst_Byte_Sequence_Access := Get (Value);
begin
case Typ is
when Id | Idref =>
if Parser.Feature_Namespace then
if not Is_Valid_NCname (Val.all, Parser.XML_Version) then
-- Always a non-fatal error, since we are dealing with
-- namespaces
Error (Parser, Error_Attribute_Is_Ncname
& Get (Local_Name).all, Error_Loc);
end if;
else
if not Is_Valid_Name (Val.all, Parser.XML_Version) then
Error (Parser, Error_Attribute_Is_Name
& Get (Local_Name).all, Error_Loc);
end if;
end if;
when Idrefs =>
if Parser.Feature_Namespace then
if not Is_Valid_NCnames (Val.all, Parser.XML_Version) then
Error (Parser, Error_Attribute_Is_Ncname
& Get (Local_Name).all, Error_Loc);
end if;
else
if not Is_Valid_Names (Val.all, Parser.XML_Version) then
Error (Parser, Error_Attribute_Is_Name
& Get (Local_Name).all, Error_Loc);
end if;
end if;
when Nmtoken =>
if not Is_Valid_Nmtoken (Val.all, Parser.XML_Version) then
Error (Parser, Error_Attribute_Is_Nmtoken
& Get (Local_Name).all, Error_Loc);
end if;
when Nmtokens =>
if not Is_Valid_Nmtokens (Val.all, Parser.XML_Version) then
Error (Parser, Error_Attribute_Is_Nmtoken
& Get (Local_Name).all, Error_Loc);
end if;
when Entity =>
if not Is_Valid_Name (Val.all, Parser.XML_Version) then
Error (Parser, Error_Attribute_Is_Name
& Get (Local_Name).all, Error_Loc);
end if;
Ent := Get (Parser.Entities, Value);
if Ent = null or else not Ent.Unparsed then
Error (Parser, Error_Attribute_Ref_Unparsed_Entity
& Get (Local_Name).all, Error_Loc);
end if;
when Entities =>
declare
Index : Integer := Val'First;
Last, Previous : Integer;
C : Unicode_Char;
begin
Last := Index;
while Last <= Val'Last loop
Previous := Last;
Encoding.Read (Val.all, Last, C);
if C = Unicode.Names.Basic_Latin.Space
or else Last > Val'Last
then
if not Is_Valid_Name (Val (Index .. Previous),
Parser.XML_Version)
then
Error (Parser, Error_Attribute_Is_Name
& Get (Local_Name).all,
Error_Loc);
end if;
Ent := Get
(Parser.Entities,
Find_Symbol (Parser, Val (Index .. Previous)));
if Ent = null or else not Ent.Unparsed then
Error (Parser, Error_Attribute_Ref_Unparsed_Entity
& Get (Local_Name).all,
Error_Loc);
end if;
Index := Last;
end if;
end loop;
end;
when others =>
null;
end case;
end Check_Attribute_Value;
------------
-- Append --
------------
procedure Append
(List : in out Sax_Attribute_List;
Local_Name : Sax.Symbols.Symbol;
Prefix : Sax.Symbols.Symbol;
Att_Type : Attribute_Type := Cdata;
URI : Sax.Symbols.Symbol := No_Symbol;
Value : Sax.Symbols.Symbol;
Location : Sax.Locators.Location;
Default_Decl : Default_Declaration := Default;
If_Unique : Boolean := False)
is
Tmp : Sax_Attribute_Array_Access;
begin
if If_Unique then
for A in 1 .. List.Count loop
if List.List (A).Local_Name = Local_Name
and then List.List (A).Prefix = Prefix
then
return;
end if;
end loop;
end if;
if List.List = null or else List.Count = List.List'Last then
Tmp := List.List;
if Tmp /= null then
List.List := new Sax_Attribute_Array (Tmp'First .. Tmp'Last + 1);
List.List (Tmp'Range) := Tmp.all;
Unchecked_Free (Tmp);
else
List.List := new Sax_Attribute_Array (1 .. 1);
List.Count := 0;
end if;
end if;
-- The URI cannot be resolved at this point, since it will
-- depend on the contents of the document at the place where
-- the attribute is used.
List.Count := List.Count + 1;
List.List (List.Count) := Sax_Attribute'
(Prefix => Prefix,
Local_Name => Local_Name,
Value => Value,
Non_Normalized_Value => Value,
Att_Type => Att_Type,
URI => URI,
Default_Decl => Default_Decl,
Location => Location);
end Append;
---------------------
-- Syntactic_Parse --
---------------------
procedure Syntactic_Parse
(Parser : in out Sax_Reader'Class;
Input : in out Input_Sources.Input_Source'Class)
is
Id : Token := Null_Token;
procedure Parse_Start_Tag;
-- Process an element start and its attributes
procedure Parse_Attributes
(Elem_NS_Id, Elem_Name_Id : Token; Id : in out Token);
-- Process the list of attributes in a start tag, and store them in
-- Parser.Attributes.
-- Id should have been initialized to the first token in the attributes
-- list, and will be left on the first token after it.
-- Return the list of attributes for this element
-- On exit, NS_Count is set to the number of references to Elem_NS_Id
-- among the attributes. The count for other XML_NS that the one of the
-- element is directly increment in the corresponding XML_NS, but for
-- the element we want to keep it virgin until we have called the
-- validation hook.
procedure Resolve_Attribute_Namespaces;
-- For each attributes defined in Parser.Attributes, set its URI for
-- the namespace
procedure Check_And_Define_Namespace
(Prefix, URI : Symbol; Location : Sax.Locators.Location);
-- An attribute defining a namespace was found. Check that the values
-- are valid, and register the new namespace. If Prefix is Null_Token,
-- the default namespace is defined
function Get_String (Str : Token) return String;
function Get_String (First, Last : Token) return String;
pragma Inline (Get_String);
-- Return the string pointed to by the token
procedure Add_Default_Attributes (DTD_Attr : Sax_Attribute_Array_Access);
-- Add all DEFAULT attributes declared in the DTD into the attributes of
-- the current element, if they weren't overriden by the user
procedure Parse_End_Tag;
-- Process an element end
procedure Parse_Doctype;
-- Process the DTD declaration
procedure Parse_Doctype_Contents;
-- Process the DTD's contents
procedure Parse_Entity_Def (Id : in out Token);
-- Parse an processing instruction
procedure End_Element;
-- End the current element. Its namespace prefix and local_name are
-- given in the parameters.
procedure Get_String
(Id : in out Token;
State : Parser_State;
Str_Start, Str_End : out Token;
Normalize : Boolean := False;
Collapse_Spaces : Boolean := False);
-- Get all the character till the end of the string. Id should contain
-- the initial quote that starts the string.
-- On exit, Str_Start is set to the first token of the string, and
-- Str_End to the last token.
-- If Normalize is True, then all space characters are converted to
-- ' '.
-- If Collapse_Spaces is True, then all duplicate spaces sequences are
-- collapsed into a single space character. Leading and trailing spaces
-- are also removed.
procedure Get_Name_NS (Id : in out Token; NS_Id, Name_Id : out Token);
-- Read the next tokens so as to match either a single name or
-- a "ns:name" name.
-- Id should initially point to the candidate token for the name, and
-- will be left on the token following that name.
-- An error is raised if we can't even match a Name.
procedure Get_External
(Id : in out Token;
System_Start, System_End, Public_Start, Public_End : out Token;
Allow_Publicid : Boolean := False);
-- Parse a PUBLIC or SYSTEM definition and its arguments.
-- Id should initially point to the keyword itself, and will be set to
-- the first identifier following the full definition
-- If Allow_Publicid is True, then PUBLIC might be followed by a single
-- string, as in rule [83] of the XML specifications.
procedure Check_Standalone_Value (Id : in out Token);
procedure Check_Encoding_Value (Id : in out Token);
procedure Check_Version_Value (Id : in out Token);
-- Check the arguments for the processing instruction.
-- Each of this procedures gets the arguments from Next_Token, up to,
-- and including, the following space or End_Of_PI character.
-- They raise errors appropriately
procedure Check_Model;
-- Check that the last element inserted matches the model. This
-- procedure should not be called for the root element.
----------------
-- Get_String --
----------------
procedure Get_String
(Id : in out Token;
State : Parser_State;
Str_Start, Str_End : out Token;
Normalize : Boolean := False;
Collapse_Spaces : Boolean := False)
is
T : constant Token := Id;
Saved_State : constant Parser_State := Get_State (Parser);
Possible_End : Token := Null_Token;
C : Unicode_Char;
Index : Natural;
Last_Space : Natural := 0;
Had_Space : Boolean := Collapse_Spaces; -- Avoid leading spaces
begin
if Debug_Internal then
Put_Line ("Get_String Normalize="
& Boolean'Image (Normalize)
& " Collapse_Spaces="
& Boolean'Image (Collapse_Spaces));
end if;
Set_State (Parser, State);
Next_Token (Input, Parser, Id);
Str_Start := Id;
Str_End := Id;
while Id.Typ /= T.Typ and then Id.Typ /= End_Of_Input loop
Str_End := Id;
case Id.Typ is
when Double_String_Delimiter =>
Str_End.First := Parser.Buffer_Length + 1;
Put_In_Buffer (Parser, Quotation_Mark);
Str_End.Last := Parser.Buffer_Length;
Possible_End := Str_End;
Had_Space := False;
when Single_String_Delimiter =>
Str_End.First := Parser.Buffer_Length + 1;
Put_In_Buffer (Parser, Apostrophe);
Str_End.Last := Parser.Buffer_Length;
Possible_End := Str_End;
Had_Space := False;
when Start_Of_Tag =>
if Possible_End = Null_Token then
Fatal_Error (Parser, Error_Attribute_Less_Than, Id);
else
Fatal_Error
(Parser, Error_Attribute_Less_Than_Suggests
& Location (Parser, Possible_End.Location), Id);
end if;
when Char_Ref =>
-- 3.3.3 item 3: character references are kept as is
if Get_String (Id) = Space_Sequence then
if Collapse_Spaces and Had_Space then
Reset_Buffer (Parser, Id);
end if;
Had_Space := True;
Last_Space := Parser.Buffer_Length;
else
Had_Space := False;
end if;
when others =>
if Normalize or Collapse_Spaces then
declare
Str : constant Byte_Sequence :=
Parser.Buffer (Id.First .. Id.Last);
begin
Reset_Buffer (Parser, Id);
Index := Str'First;
while Index <= Str'Last loop
Encoding.Read (Str, Index, C);
-- ??? If we have a character reference, we must
-- replace the character it represents, and not do
-- entity replacement. How to do that, we have lost
-- that information
-- When parsing an attribute value, we should still
-- process white spaces, therefore the test for
-- Ignore_Special
if Is_White_Space (C) then
if not Collapse_Spaces or not Had_Space then
Put_In_Buffer
(Parser, Unicode.Names.Basic_Latin.Space);
end if;
Had_Space := True;
Last_Space := Parser.Buffer_Length;
else
Had_Space := False;
Put_In_Buffer (Parser, C);
end if;
end loop;
end;
Str_End.Last := Parser.Buffer_Length;
end if;
end case;
Next_Token (Input, Parser, Id);
end loop;
if Collapse_Spaces and then Had_Space and then Last_Space /= 0 then
Str_End.Last := Last_Space - 1;
end if;
if Id.Typ = End_Of_Input then
if Possible_End = Null_Token then
Fatal_Error (Parser, Error_Unterminated_String);
else
Fatal_Error (Parser, Error_Unterminated_String_Suggests
& Location (Parser, Possible_End.Location), T);
end if;
end if;
Set_State (Parser, Saved_State);
end Get_String;
------------------
-- Get_External --
------------------
procedure Get_External
(Id : in out Token;
System_Start, System_End, Public_Start, Public_End : out Token;
Allow_Publicid : Boolean := False)
is
Had_Space : Boolean;
C : Unicode_Char;
Index : Natural;
begin
System_Start := Null_Token;
System_End := Null_Token;
Public_Start := Null_Token;
Public_End := Null_Token;
-- Check the arguments for PUBLIC
if Id.Typ = Public then
Next_Token_Skip_Spaces (Input, Parser, Id, Must_Have => True);
if Id.Typ /= Double_String_Delimiter
and then Id.Typ /= Single_String_Delimiter
then
Fatal_Error (Parser, Error_Public_String);
else
Get_String
(Id, Non_Interpreted_String_State, Public_Start, Public_End);
Index := Public_Start.First;
while Index <= Public_End.Last loop
Encoding.Read (Parser.Buffer.all, Index, C);
if not Is_Pubid_Char (C) then
Fatal_Error
(Parser, Error_Public_Invalid & "'"
& Debug_Encode (C) & "'", Public_Start);
end if;
end loop;
end if;
Next_Token (Input, Parser, Id);
Had_Space := (Id.Typ = Space);
if Had_Space then
Next_Token (Input, Parser, Id);
elsif Allow_Publicid then
return;
end if;
if Id.Typ /= Double_String_Delimiter
and then Id.Typ /= Single_String_Delimiter
then
if not Allow_Publicid then
Fatal_Error (Parser, Error_Public_Sysid);
end if;
else
if not Had_Space then
Fatal_Error (Parser, Error_Public_Sysid_Space, Id);
end if;
Get_String
(Id, Non_Interpreted_String_State, System_Start, System_End);
Next_Token (Input, Parser, Id);
end if;
-- Check the arguments for SYSTEM
elsif Id.Typ = System then
Next_Token_Skip_Spaces (Input, Parser, Id, Must_Have => True);
if Id.Typ /= Double_String_Delimiter
and then Id.Typ /= Single_String_Delimiter
then
Fatal_Error (Parser, Error_System_String);
else
Get_String
(Id, Non_Interpreted_String_State, System_Start, System_End);
Next_Token (Input, Parser, Id);
end if;
end if;
end Get_External;
-----------------
-- Get_Name_NS --
-----------------
procedure Get_Name_NS (Id : in out Token; NS_Id, Name_Id : out Token) is
begin
Name_Id := Id;
if Id.Typ = Text then
Fatal_Error
(Parser, Error_Invalid_Name & "'"
& Parser.Buffer (Id.First .. Id.Last) & "'", Id);
-- An empty namespace ? This seems to be useful only for the XML
-- conformance suite, so we only handle the case of a single ':'
-- to mean both an empty prefix and empty local name.
elsif Name_Id.Typ = Colon then
Name_Id.Typ := Text;
NS_Id := Name_Id;
Next_Token (Input, Parser, Id);
elsif Id.Typ /= Name then
Fatal_Error (Parser, Error_Is_Name, Id);
else
Next_Token (Input, Parser, Id);
if Id.Typ = Colon then
NS_Id := Name_Id;
Next_Token (Input, Parser, Name_Id);
if Name_Id.Typ /= Name then
Fatal_Error (Parser, Error_Is_Name);
end if;
Next_Token (Input, Parser, Id);
else
NS_Id := Null_Token;
end if;
end if;
end Get_Name_NS;
----------------------
-- Parse_Entity_Def --
----------------------
procedure Parse_Entity_Def (Id : in out Token) is
Is_Parameter : Token := Null_Token;
Name_Id : Token;
Def_Start, Def_End : Token := Null_Token;
Ndata_Id : Token := Null_Token;
Public_Start, Public_End : Token := Null_Token;
System_Start, System_End : Token := Null_Token;
Had_Space : Boolean;
Sym : Symbol;
begin
Set_State (Parser, Entity_Def_State);
Next_Token_Skip_Spaces (Input, Parser, Name_Id, True);
if Debug_Internal then
Put_Line ("Parsing entity definition "
& Parser.Buffer (Name_Id.First .. Name_Id.Last));
end if;
if Name_Id.Typ = Text
and then Parser.Buffer (Name_Id.First .. Name_Id.Last) =
Percent_Sign_Sequence
then
Is_Parameter := Name_Id;
Next_Token_Skip_Spaces (Input, Parser, Name_Id);
end if;
if Name_Id.Typ /= Name then
Fatal_Error (Parser, Error_Is_Name);
end if;
Check_Valid_Name_Or_NCname (Parser, Name_Id);
Next_Token_Skip_Spaces (Input, Parser, Id, Must_Have => True);
if Id.Typ = Public or else Id.Typ = System then
Get_External
(Id, System_Start, System_End, Public_Start, Public_End);
if Contains_URI_Fragment
(Parser.Buffer (System_Start.First .. System_End.Last))
then
Error (Parser, Error_System_URI, Id);
end if;
Had_Space := (Id.Typ = Space);
if Had_Space then
Next_Token (Input, Parser, Id);
end if;
if Id.Typ = Ndata then
if not Had_Space then
Fatal_Error (Parser, Error_Ndata_Space, Id);
end if;
if Is_Parameter /= Null_Token then
Fatal_Error (Parser, Error_Ndata_ParamEntity, Id);
end if;
Next_Token_Skip_Spaces (Input, Parser, Ndata_Id, True);
if Ndata_Id.Typ /= Text and then Ndata_Id.Typ /= Name then
Fatal_Error (Parser, Error_Ndata_String);
else
Sym := Find_Symbol (Parser, Ndata_Id);
if Parser.Feature_Validation
and then Get (Parser.Notations, Sym) = Null_Notation
then
-- The notation might be declared later in the same DTD
Set (Parser.Notations,
(Name => Sym,
Declaration_Seen => False));
end if;
Next_Token_Skip_Spaces (Input, Parser, Id);
end if;
end if;
elsif Id.Typ = Double_String_Delimiter
or else Id.Typ = Single_String_Delimiter
then
Get_String (Id, Entity_Str_Def_State, Def_Start, Def_End);
Next_Token_Skip_Spaces (Input, Parser, Id);
else
Fatal_Error (Parser, Error_Entity_Definition);
end if;
if Id.Typ /= End_Of_Tag then
Fatal_Error (Parser, Error_Entity_Definition_Unterminated);
end if;
-- Only report the first definition
Sym := Find_Symbol
(Parser,
Parser.Buffer (Is_Parameter.First .. Is_Parameter.Last)
& Parser.Buffer (Name_Id.First .. Name_Id.Last));
if Get (Parser.Entities, Sym) /= null then
null;
elsif Def_End /= Null_Token then
Set (Parser.Entities,
new Entity_Entry'
(Name => Find_Symbol
(Parser,
Parser.Buffer (Is_Parameter.First .. Is_Parameter.Last)
& Parser.Buffer (Name_Id.First .. Name_Id.Last)),
Value => Find_Symbol
(Parser,
Parser.Buffer (Def_Start.First .. Def_End.Last)),
Public => No_Symbol,
Unparsed => False,
External_Declaration => (Parser.Inputs /= null
and then Parser.Inputs.External)
or else Parser.In_External_Entity,
External => False,
Already_Read => False));
if Debug_Internal then
Put_Line ("Internal_Entity_Decl: "
& Parser.Buffer (Name_Id.First .. Name_Id.Last) & "="
& Parser.Buffer (Def_Start.First .. Def_End.Last)
& " length="
& Integer'Image (Def_End.Last - Def_Start.First + 1));
end if;
Internal_Entity_Decl
(Parser,
Name => Parser.Buffer (Is_Parameter.First .. Is_Parameter.Last)
& Parser.Buffer (Name_Id.First .. Name_Id.Last),
Value => Parser.Buffer (Def_Start.First .. Def_End.Last));
elsif Ndata_Id /= Null_Token then
Set (Parser.Entities,
new Entity_Entry'
(Name => Find_Symbol
(Parser,
Parser.Buffer (Is_Parameter.First .. Is_Parameter.Last)
& Parser.Buffer (Name_Id.First .. Name_Id.Last)),
Value => No_Symbol,
Public => No_Symbol,
Unparsed => True,
External_Declaration => (Parser.Inputs /= null
and then Parser.Inputs.External)
or else Parser.In_External_Entity,
External => False,
Already_Read => True));
Unparsed_Entity_Decl
(Parser,
Name => Parser.Buffer (Is_Parameter.First .. Is_Parameter.Last)
& Parser.Buffer (Name_Id.First .. Name_Id.Last),
System_Id =>
Parser.Buffer (System_Start.First .. System_End.Last),
Notation_Name =>
Parser.Buffer (Ndata_Id.First .. Ndata_Id.Last));
else
Set
(Parser.Entities,
new Entity_Entry'
(Name => Find_Symbol
(Parser,
Parser.Buffer (Is_Parameter.First .. Is_Parameter.Last)
& Parser.Buffer (Name_Id.First .. Name_Id.Last)),
Value => Find_Symbol
(Parser,
Parser.Buffer (System_Start.First .. System_End.Last)),
Public => Find_Symbol
(Parser,
Parser.Buffer (Public_Start.First .. Public_End.Last)),
Unparsed => False,
External_Declaration => (Parser.Inputs /= null
and then Parser.Inputs.External)
or else Parser.In_External_Entity,
External => True,
Already_Read => False));
External_Entity_Decl
(Parser,
Name => Parser.Buffer (Is_Parameter.First .. Is_Parameter.Last)
& Parser.Buffer (Name_Id.First .. Name_Id.Last),
Public_Id => Parser.Buffer
(Public_Start.First .. Public_End.Last),
System_Id => Parser.Buffer
(System_Start.First .. System_End.Last));
end if;
if Is_Parameter /= Null_Token then
Reset_Buffer (Parser, Is_Parameter);
else
Reset_Buffer (Parser, Name_Id);
end if;
Set_State (Parser, DTD_State);
end Parse_Entity_Def;
-----------------------
-- Parse_Element_Def --
-----------------------
procedure Parse_Element_Def (Id : in out Token) is
Name_Id : Token;
M : Element_Model_Ptr;
M2 : Content_Model;
NS_Id : Token;
begin
Set_State (Parser, Element_Def_State);
Next_NS_Token_Skip_Spaces (Input, Parser, NS_Id, Name_Id);
if Name_Id.Typ /= Name then
Fatal_Error (Parser, Error_Is_Name);
end if;
Next_Token_Skip_Spaces (Input, Parser, Id, Must_Have => True);
case Id.Typ is
when Empty => M := new Element_Model (Empty);
when Any => M := new Element_Model (Anything);
when Open_Paren =>
Parse_Element_Model
(Input, Parser, M, Attlist => False, Open_Was_Read => True);
when others =>
Fatal_Error (Parser, "Invalid content model: expecting"
& " '(', 'EMPTY' or 'ANY'", Id);
end case;
Next_Token_Skip_Spaces (Input, Parser, Id);
if Id.Typ /= End_Of_Tag then
Free (M);
Fatal_Error (Parser, "Expecting end of ELEMENT definition");
end if;
M2 := Create_Model (M);
Element_Decl
(Parser, Parser.Buffer (Name_Id.First .. Name_Id.Last), M2);
Unref (M2);
if NS_Id /= Null_Token then
Reset_Buffer (Parser, NS_Id);
else
Reset_Buffer (Parser, Name_Id);
end if;
Set_State (Parser, DTD_State);
end Parse_Element_Def;
------------------------
-- Parse_Notation_Def --
------------------------
procedure Parse_Notation_Def (Id : in out Token) is
Public_Start, Public_End : Token := Null_Token;
System_Start, System_End : Token := Null_Token;
Name_Id : Token;
Sym : Symbol;
begin
Set_State (Parser, Element_Def_State);
Next_Token_Skip_Spaces (Input, Parser, Name_Id);
Check_Valid_Name_Or_NCname (Parser, Name_Id);
if Name_Id.Typ /= Name then
Fatal_Error (Parser, Error_Is_Name);
end if;
Next_Token_Skip_Spaces (Input, Parser, Id);
if Id.Typ = Public or else Id.Typ = System then
Get_External
(Id, System_Start, System_End, Public_Start, Public_End, True);
if Id.Typ = Space then
Next_Token (Input, Parser, Id);
end if;
else
Fatal_Error (Parser, Error_Invalid_Notation_Decl);
end if;
if Id.Typ /= End_Of_Tag then
Fatal_Error (Parser, "Expecting end of NOTATION definition");
end if;
if Contains_URI_Fragment
(Parser.Buffer (System_Start.First .. System_End.Last))
then
Error (Parser, Error_System_URI);
end if;
if Parser.Hooks.Notation_Decl /= null then
Parser.Hooks.Notation_Decl
(Parser'Access,
Name => Parser.Buffer (Name_Id.First .. Name_Id.Last),
Public_Id =>
Parser.Buffer (Public_Start.First .. Public_End.Last),
System_Id =>
Parser.Buffer (System_Start.First .. System_End.Last));
end if;
Notation_Decl
(Parser,
Name => Parser.Buffer (Name_Id.First .. Name_Id.Last),
Public_Id => Parser.Buffer (Public_Start.First .. Public_End.Last),
System_Id =>
Parser.Buffer (System_Start.First .. System_End.Last));
if Parser.Feature_Validation then
Sym := Find_Symbol (Parser, Name_Id);
Remove (Parser.Notations, Sym);
Set (Parser.Notations,
(Name => Sym,
Declaration_Seen => True));
end if;
Set_State (Parser, DTD_State);
Reset_Buffer (Parser, Name_Id);
end Parse_Notation_Def;
-----------------------
-- Parse_Attlist_Def --
-----------------------
procedure Parse_Attlist_Def (Id : in out Token) is
M : Element_Model_Ptr;
M2 : Content_Model;
Default_Start, Default_End : Token;
Ename_Id, Ename_NS_Id, Name_Id, NS_Id, Type_Id : Token;
Default_Id : Token;
Attr : Attributes_Table.Element_Ptr;
Default_Decl : Default_Declaration;
Att_Type : Attribute_Type;
Ename, SName : Symbol;
begin
Set_State (Parser, Element_Def_State);
Next_NS_Token_Skip_Spaces (Input, Parser, Ename_NS_Id, Ename_Id);
if Ename_Id.Typ /= Name then
Fatal_Error (Parser, Error_Is_Name, Ename_Id);
end if;
Ename := Find_Symbol (Parser, Ename_Id);
Attr := Get_Ptr (Parser.Default_Atts, Ename);
if Attr = null then
declare
Attr2 : constant Attributes_Entry :=
(Element_Name => Ename,
Attributes => (0, null));
begin
Set (Parser.Default_Atts, Attr2);
Attr := Get_Ptr (Parser.Default_Atts, Ename);
end;
end if;
if Id.Typ = Space then
Next_Token_Skip_Spaces (Input, Parser, Id);
end if;
loop
-- Temporarily disable In_Attlist, so that the names like "NAME"
-- are parsed as names and not as NMTOKEN.
Set_State (Parser, Attribute_Def_Name_State);
Next_Token_Skip_Spaces (Input, Parser, Id);
exit when Id.Typ = End_Of_Tag or else Id.Typ = End_Of_Input;
Get_Name_NS (Id, NS_Id, Name_Id);
SName := Find_Symbol (Parser, Name_Id);
if Id.Typ /= Space then
Fatal_Error (Parser, Error_Expecting_Space, Id); -- 3.3
end if;
Set_State (Parser, Attribute_Def_State);
Next_Token_Skip_Spaces (Input, Parser, Id);
Type_Id := Id;
Default_Start := Null_Token;
Default_End := Null_Token;
case Type_Id.Typ is
when Id_Type => Att_Type := Sax.Attributes.Id;
when Idref => Att_Type := Sax.Attributes.Idref;
when Idrefs => Att_Type := Sax.Attributes.Idrefs;
when Cdata => Att_Type := Sax.Attributes.Cdata;
when Nmtoken => Att_Type := Sax.Attributes.Nmtoken;
when Nmtokens => Att_Type := Sax.Attributes.Nmtokens;
when Entity => Att_Type := Sax.Attributes.Entity;
when Entities => Att_Type := Sax.Attributes.Entities;
when Notation =>
Att_Type := Notation;
Next_Token (Input, Parser, Id);
if Id.Typ /= Space then
Fatal_Error
(Parser, -- 3.3.1
"Space is required between NOTATION keyword"
& " and list of enumerated", Id);
end if;
Parse_Element_Model (Input, Parser, M, True, False);
if Parser.Feature_Validation then
for J in M.List'Range loop
if Get (Parser.Notations, M.List (J).Name) /=
Null_Notation
then
Error
(Parser, Error_Notation_Undeclared
& Get (M.List (J).Name).all, Id);
end if;
end loop;
end if;
when Open_Paren =>
Att_Type := Enumeration;
Parse_Element_Model (Input, Parser, M, True, True);
when others =>
Fatal_Error (Parser, Error_Attlist_Type);
end case;
declare
QName : constant Byte_Sequence :=
Qname_From_Name (Parser, NS_Id, Name_Id);
Default_Val : Symbol;
begin
Next_Token_Skip_Spaces (Input, Parser, Default_Id, True);
if Default_Id.Typ = Implied then
Default_Decl := Sax.Attributes.Implied;
elsif Default_Id.Typ = Required then
Default_Decl := Sax.Attributes.Required;
else
Id := Default_Id;
if Default_Id.Typ = Fixed then
Next_Token_Skip_Spaces (Input, Parser, Id, True);
Default_Decl := Sax.Attributes.Fixed;
else
Default_Decl := Sax.Attributes.Default;
end if;
if Id.Typ = Double_String_Delimiter
or else Id.Typ = Single_String_Delimiter
then
Get_String
(Id, Attlist_Str_Def_State, Default_Start, Default_End,
Normalize => True, Collapse_Spaces => True);
-- Errata 9 on XML 1.0 specs: the default value must be
-- syntactically correct. Validity will only be checked
-- if the attribute is used.
Default_Val := Find_Symbol
(Parser, Default_Start, Default_End);
if Parser.Feature_Validation then
Check_Attribute_Value
(Parser,
Local_Name => SName,
Typ => Att_Type,
Value => Default_Val,
Error_Loc => Default_Start);
end if;
else
Fatal_Error
(Parser, "Invalid default value for attribute");
end if;
end if;
if Parser.Feature_Validation
and then Att_Type = Sax.Attributes.Id
and then Default_Decl /= Sax.Attributes.Implied
and then Default_Decl /= Sax.Attributes.Required
then
Error
(Parser,
"Default value for an ID attribute must be"
& " IMPLIED or REQUIRED",
Default_Id);
end if;
-- Always report the attribute, even when we know the value
-- won't be used. We can't do it coherently otherwise, in case
-- an attribute is seen in the external subset, and then
-- overriden in the internal subset.
M2 := Create_Model (M);
Attribute_Decl
(Parser,
Ename => Parser.Buffer (Ename_Id.First .. Ename_Id.Last),
Aname => QName,
Typ => Att_Type,
Content => M2,
Value_Default => Default_Decl,
Value => Parser.Buffer
(Default_Start.First .. Default_End.Last));
Unref (M2);
Append
(List => Attr.Attributes,
If_Unique => True,
Location => Name_Id.Location,
Local_Name => SName,
Prefix => Find_Symbol (Parser, NS_Id),
Value => Default_Val,
Att_Type => Att_Type,
Default_Decl => Default_Decl);
end;
-- M will be freed automatically when the Default_Atts field is
-- freed. However, we need to reset it for the next attribute
-- in the list.
M := null;
if NS_Id /= Null_Token then
Reset_Buffer (Parser, NS_Id);
else
Reset_Buffer (Parser, Name_Id);
end if;
Set_State (Parser, Element_Def_State);
end loop;
if Id.Typ /= End_Of_Tag then
Fatal_Error (Parser, "Expecting end of ATTLIST definition");
end if;
Set_State (Parser, DTD_State);
if Ename_NS_Id /= Null_Token then
Reset_Buffer (Parser, Ename_NS_Id);
else
Reset_Buffer (Parser, Ename_Id);
end if;
exception
when others =>
Free (M);
raise;
end Parse_Attlist_Def;
-----------------
-- Check_Model --
-----------------
procedure Check_Model is
begin
null;
end Check_Model;
----------------
-- Get_String --
----------------
function Get_String (Str : Token) return String is
begin
return Parser.Buffer (Str.First .. Str.Last);
end Get_String;
----------------
-- Get_String --
----------------
function Get_String (First, Last : Token) return String is
begin
return Parser.Buffer (First.First .. Last.Last);
end Get_String;
--------------------------------
-- Check_And_Define_Namespace --
--------------------------------
procedure Check_And_Define_Namespace
(Prefix, URI : Symbol; Location : Sax.Locators.Location) is
begin
if Prefix = Empty_String then
-- [2] Empty value is legal for the default namespace, and
-- provides unbinding
null;
else
if Prefix = Parser.Xmlns_Sequence then
Fatal_Error -- NS 3
(Parser, "Cannot redefine the xmlns prefix", Location);
elsif URI = Empty_String then
Fatal_Error
(Parser, -- NS 2.2
"Cannot use an empty URI for namespaces", Location);
elsif Prefix = Parser.Xml_Sequence then
if URI /= Parser.Namespaces_URI_Sequence then
Fatal_Error -- NS 3
(Parser, "Cannot redefine the xml prefix", Location);
end if;
elsif URI = Parser.Namespaces_URI_Sequence then
Fatal_Error
(Parser, -- NS 3
"Cannot bind the namespace URI to a prefix other"
& " than xml", Location);
end if;
end if;
if URI /= Empty_String
and then not Is_Valid_IRI
(Get (URI).all, Version => Parser.XML_Version)
then
if Parser.Feature_Allow_Relative_IRI then
Warning
(Parser,
"Invalid absolute IRI (Internationalized Resource"
& " Identifier) for namespace: """ & Get (URI).all & """",
Location);
else
Error
(Parser,
"Invalid absolute IRI (Internationalized Resource"
& " Identifier) for namespace: """ & Get (URI).all & """",
Location);
-- NS 2
end if;
end if;
Add_Namespace (Parser, Parser.Current_Node, Prefix, URI);
end Check_And_Define_Namespace;
----------------------------
-- Add_Default_Attributes --
----------------------------
procedure Add_Default_Attributes
(DTD_Attr : Sax_Attribute_Array_Access)
is
Found : Boolean;
Is_Xmlns : Boolean;
begin
-- Add all the default attributes to the element.
-- We shouldn't add an attribute if it was overriden by the user
if DTD_Attr /= null then
for J in DTD_Attr'Range loop
-- We must compare Qnames, since namespaces haven't been
-- resolved in the default attributes.
if DTD_Attr (J).Default_Decl = Default
or else DTD_Attr (J).Default_Decl = Fixed
then
Found := False;
for A in 1 .. Parser.Attributes.Count loop
if Parser.Attributes.List (A).Local_Name =
DTD_Attr (J).Local_Name
and then Parser.Attributes.List (A).Prefix =
DTD_Attr (J).Prefix
then
Found := True;
exit;
end if;
end loop;
if not Found then
Is_Xmlns := DTD_Attr (J).Prefix = Parser.Xmlns_Sequence;
if Parser.Feature_Namespace_Prefixes
or else not Is_Xmlns
then
Append
(List => Parser.Attributes,
If_Unique => True,
Location => No_Location,
Local_Name => DTD_Attr (J).Local_Name,
Prefix => DTD_Attr (J).Prefix,
Value => DTD_Attr (J).Value,
Att_Type => DTD_Attr (J).Att_Type,
Default_Decl => DTD_Attr (J).Default_Decl);
end if;
-- Is this a namespace declaration ?
if Is_Xmlns then
-- Following warning is because for parser that don't
-- read external DTDs, the behavior would be different
-- for the same document.
Warning
(Parser,
"namespace-declaring attribute inserted via "
& "DTD defaulting mechanisms are not good style");
Add_Namespace
(Parser, Parser.Current_Node,
Prefix => DTD_Attr (J).Local_Name,
URI => DTD_Attr (J).Value);
end if;
end if;
end if;
end loop;
end if;
end Add_Default_Attributes;
----------------------------------
-- Resolve_Attribute_Namespaces --
----------------------------------
procedure Resolve_Attribute_Namespaces is
NS : XML_NS;
begin
if Parser.Feature_Namespace then
for J in 1 .. Parser.Attributes.Count loop
Find_NS (Parser, Parser.Attributes.List (J).Prefix, NS,
Include_Default_NS => False);
if NS = No_XML_NS then
Fatal_Error
(Parser, Error_Prefix_Not_Declared
& Get (Parser.Attributes.List (J).Prefix).all);
end if;
for A in 1 .. J - 1 loop
if Parser.Attributes.List (A).URI = Get_URI (NS)
and then Parser.Attributes.List (A).Local_Name =
Parser.Attributes.List (J).Local_Name
then
Fatal_Error -- 3.1
(Parser, "Attributes may appear only once: "
& To_QName
(Get_URI (NS),
Parser.Attributes.List (J).Local_Name),
Parser.Attributes.List (J).Location);
end if;
end loop;
Parser.Attributes.List (J).URI := Get_URI (NS);
end loop;
end if;
end Resolve_Attribute_Namespaces;
----------------------
-- Parse_Attributes --
----------------------
procedure Parse_Attributes
(Elem_NS_Id, Elem_Name_Id : Token; Id : in out Token)
is
Elem : constant Symbol := Find_Symbol
(Parser, Qname_From_Name (Parser, Elem_NS_Id, Elem_Name_Id));
Attr : constant Sax_Attribute_List := Get
(Parser.Default_Atts, Elem).Attributes;
-- The attributes as defined in the DTD
Attr_NS_Id : Token;
Attr_Name_Id : Token;
Value_Start : Token;
Value_End : Token;
Add_Attr : Boolean;
A : Integer;
Attr_Name, Attr_Prefix, Attr_Value : Symbol;
Attr_Type : Attribute_Type;
function Find_Declaration return Integer;
-- Return the position of the declaration for Attr_Prefix:Attr_Name
-- in Attr, or -1 if no declaration exists
procedure Check_Required_Attributes;
-- Check whether all required attributes have been defined
----------------------
-- Find_Declaration --
----------------------
function Find_Declaration return Integer is
begin
if Attr.List /= null then
-- First test: same prefix and local name. We will test later
-- for a same URI
for A in Attr.List'First .. Attr.Count loop
if Attr.List (A).Local_Name = Attr_Name
and then Attr.List (A).Prefix = Attr_Prefix
then
return A;
end if;
end loop;
end if;
return -1;
end Find_Declaration;
-------------------------------
-- Check_Required_Attributes --
-------------------------------
procedure Check_Required_Attributes is
Found : Boolean;
begin
if Parser.Feature_Validation and then Attr.List /= null then
for A in Attr.List'First .. Attr.Count loop
if Attr.List (A).Default_Decl = Required then
Found := False;
for T in 1 .. Parser.Attributes.Count loop
if Parser.Attributes.List (T).Local_Name =
Attr.List (A).Local_Name
and then Parser.Attributes.List (T).Prefix =
Attr.List (A).Prefix
then
Found := True;
exit;
end if;
end loop;
if not Found then
Error
(Parser, "[VC 3.3.2] Required attribute '"
& To_QName (Attr.List (A).Prefix,
Attr.List (A).Local_Name)
& "' must be defined");
end if;
end if;
end loop;
end if;
end Check_Required_Attributes;
begin
Parser.Attributes.Count := 0;
while Id.Typ /= End_Of_Tag
and then Id.Typ /= End_Of_Input
and then Id.Typ /= End_Of_Start_Tag
loop
Get_Name_NS (Id, Attr_NS_Id, Attr_Name_Id);
if Id.Typ = Space then
Next_Token (Input, Parser, Id);
end if;
if Id.Typ /= Equal then
Fatal_Error -- 3.1
(Parser, "Attributes must have an explicit value", Id);
end if;
Attr_Name := Find_Symbol (Parser, Attr_Name_Id);
Attr_Prefix := Find_Symbol (Parser, Attr_NS_Id);
A := Find_Declaration;
Next_Token_Skip_Spaces (Input, Parser, Id);
if Id.Typ /= Double_String_Delimiter
and then Id.Typ /= Single_String_Delimiter
then
Fatal_Error -- 3.1
(Parser, "Attribute values must be quoted", Id);
end if;
-- 3.3.3: If the attribute's type is not CDATA, we must
-- normalize it, ie collapse sequence of spaces.
-- ??? What if the information comes from an XML Schema instead
-- of a DTD
-- ??? That should be done only after we have processed the
-- namespaces, otherwise we do not know what attribute we are
-- dealing with
-- In XML Schema 1.1 Part 1, Section 3.1.4, it is indicated that
-- we should always normalize attribute values according to the
-- whitespace property of their type. As a result, we do not
-- normalize here by default if the attribute was registered, and
-- it will be done by the schema parser if we are using one
-- (see Hook_Start_Element).
Get_String
(Id, Attr_Value_State, Value_Start, Value_End,
Normalize => True,
Collapse_Spaces => A /= -1
and then Attr.List (A).Att_Type /= Cdata);
Attr_Value := Find_Symbol (Parser, Value_Start, Value_End);
Add_Attr := True;
-- Is this a namespace declaration ?
if Parser.Feature_Namespace
and then Attr_Prefix = Parser.Xmlns_Sequence
then
Check_And_Define_Namespace
(Prefix => Attr_Name,
URI => Attr_Value,
Location => Attr_Name_Id.Location);
Add_Attr := Parser.Feature_Namespace_Prefixes;
-- Is this the declaration of the default namespace (xmlns="uri")
elsif Parser.Feature_Namespace
and then Attr_NS_Id = Null_Token
and then Attr_Name = Parser.Xmlns_Sequence
then
if Get (Attr_Value).all = Xmlns_URI_Sequence
or else Get (Attr_Value).all = Namespaces_URI_Sequence
then
Fatal_Error
(Parser,
"The xml namespace cannot be declared as the default"
& " namespace");
end if;
-- We might have a FIXED declaration for this attribute in the
-- DTD, as per the XML Conformance testsuite
if Parser.Feature_Validation
and then A /= -1
then
if Attr.List (A).Default_Decl = Fixed
and then Attr.List (A).Value /= Attr_Value
then
Error
(Parser,
"[VC 3.3.2] xmlns attribute doesn't match FIXED value",
Value_Start);
end if;
end if;
Check_And_Define_Namespace
(Prefix => Empty_String,
URI => Attr_Value,
Location => Attr_Name_Id.Location);
Add_Attr := Parser.Feature_Namespace_Prefixes;
else
-- All attributes must be defined (including xml:lang, that
-- requires additional testing afterwards)
if Parser.Feature_Validation then
if Attr.List = null then
Error
(Parser, "[VC] No attribute allowed for element "
& Get (Parser.Current_Node.Name).all,
Attr_Name_Id);
elsif A = -1 then
Error
(Parser, "[VC] Attribute not declared in DTD: "
& To_QName (Attr_Prefix, Attr_Name),
Attr_Name_Id);
end if;
end if;
if Get_String (Attr_NS_Id) = Xml_Sequence then
if Get_String (Attr_Name_Id) = Lang_Sequence then
Test_Valid_Lang
(Parser, Get_String (Value_Start, Value_End));
elsif Get_String (Attr_Name_Id) = Space_Word_Sequence then
Test_Valid_Space
(Parser, Get_String (Value_Start, Value_End));
end if;
end if;
end if;
-- Register the attribute in the temporary list, until we can
-- properly resolve namespaces
if Add_Attr then
if Debug_Internal then
Put_Line
("Register attribute: "
& Qname_From_Name (Parser, Attr_NS_Id, Attr_Name_Id)
& " value=" & Get_String (Value_Start, Value_End));
end if;
if A /= -1 then
if Attr.List (A).Default_Decl = Fixed
and then Attr.List (A).Value /= Attr_Value
then
Error
(Parser, "[VC 3.3.2] Fixed attribute '"
& To_QName (Attr_Prefix, Attr_Name)
& "' must have the defined value",
Attr_Name_Id.Location);
end if;
Attr_Type := Attr.List (A).Att_Type;
else
Attr_Type := Cdata;
end if;
Append
(List => Parser.Attributes,
If_Unique => False,
Location => Attr_Name_Id.Location,
Local_Name => Attr_Name,
Prefix => Attr_Prefix,
Att_Type => Attr_Type,
Value => Attr_Value);
end if;
if Attr_NS_Id /= Null_Token then
Reset_Buffer (Parser, Attr_NS_Id);
else
Reset_Buffer (Parser, Attr_Name_Id);
end if;
Next_Token (Input, Parser, Id);
if Id.Typ = Space then
Next_Token (Input, Parser, Id);
elsif Id.Typ /= End_Of_Tag and then Id.Typ /= End_Of_Start_Tag then
Fatal_Error (Parser, Error_Expecting_Space, Id);
end if;
end loop;
Check_Required_Attributes;
Add_Default_Attributes (Attr.List);
-- Check attribute values. We must do that after adding the default
-- attributes, so that they are properly checked as well. It would be
-- nice to be able to check them only once, but that can't be done
-- when they are declared (since they might be referencing entities
-- declared after them in the DTD)
if Parser.Feature_Validation then
for Att in 1 .. Parser.Attributes.Count loop
Check_Attribute_Value
(Parser,
Local_Name => Parser.Attributes.List (Att).Local_Name,
Typ => Parser.Attributes.List (Att).Att_Type,
Value => Parser.Attributes.List (Att).Value,
Error_Loc => Elem_Name_Id);
end loop;
end if;
end Parse_Attributes;
---------------------
-- Parse_Start_Tag --
---------------------
procedure Parse_Start_Tag is
Open_Id : constant Token := Id;
Elem_Name_Id, Elem_NS_Id : Token;
NS : XML_NS;
begin
Set_State (Parser, Tag_State);
Parser.Current_Node := new Element'
(NS => No_XML_NS,
Name => No_Symbol,
Namespaces => No_XML_NS,
Start => Id.Location,
Start_Tag_End => Id.Location,
Parent => Parser.Current_Node);
Next_Token (Input, Parser, Id);
Get_Name_NS (Id, Elem_NS_Id, Elem_Name_Id);
Parser.Current_Node.Name := Find_Symbol (Parser, Elem_Name_Id);
if Parser.Current_Node.Parent = null then
Parser.Num_Toplevel_Elements := Parser.Num_Toplevel_Elements + 1;
if Parser.Num_Toplevel_Elements > 1 then
Fatal_Error -- 2.1
(Parser, "Too many children for top-level node,"
& " when adding <"
& Qname_From_Name (Parser, Elem_NS_Id, Elem_Name_Id)
& ">", Open_Id);
end if;
if Parser.Feature_Validation then
if Parser.DTD_Name = No_Symbol then
Error -- VC 2.8
(Parser, "No DTD defined for this document", Id);
elsif Parser.DTD_Name /= Parser.Current_Node.Name then
Error
(Parser, "[VC 2.8] Name of root element doesn't match name"
& " of DTD ('"
& Get (Parser.DTD_Name).all & "')", Id);
end if;
end if;
elsif Parser.Feature_Validation then
Check_Model;
end if;
if Elem_NS_Id /= Null_Token
and then Get_String (Elem_NS_Id) = Xmlns_Sequence
then
Fatal_Error (Parser, "Elements must not have the prefix xmlns");
end if;
-- Call the hook before checking the attributes. This might mean we
-- are passing incorrect attributes (or missing ones), but the hook
-- is used for validation (otherwise standard users should use
-- Start_Element itself).
-- We want the count of elements in the NS to not include the current
-- context.
if Debug_Internal then
Put_Line
("Start_Element "
& Qname_From_Name (Parser, Elem_NS_Id, Elem_Name_Id));
end if;
-- We need to process the attributes first, because they might define
-- the namespace for the element
if Id.Typ = Space then
Next_Token (Input, Parser, Id);
Parse_Attributes (Elem_NS_Id, Elem_Name_Id, Id);
elsif Id.Typ /= End_Of_Tag
and then Id.Typ /= End_Of_Start_Tag
then
Fatal_Error (Parser, Error_Expecting_Space, Id);
else
-- We still need to check the attributes, in case we have none but
-- some where required
Parse_Attributes (Elem_NS_Id, Elem_Name_Id, Id);
end if;
Resolve_Attribute_Namespaces;
-- And report the elements to the callbacks
Set_State (Parser, Default_State);
Find_NS (Parser, Elem_NS_Id, NS);
Parser.Current_Node.NS := NS;
if Parser.Hooks.Start_Element /= null then
Parser.Hooks.Start_Element
(Parser'Unchecked_Access, Parser.Current_Node,
Parser.Attributes'Access);
end if;
-- This does not take into account the use of the namespace by the
-- attributes.
-- ??? That would be costly to again do a Find_NS for each of the
-- attributes. ??? We don't do a Find_NS anymore, so that would be
-- doable in fact.
Increment_Count (NS);
Parser.Current_Node.Start_Tag_End := Get_Location (Parser.Locator);
pragma Warnings (Off, "overlaps with actual");
Start_Element
(Parser,
NS => NS,
Local_Name => Parser.Current_Node.Name,
Atts => Parser.Attributes);
pragma Warnings (On, "overlaps with actual");
if Id.Typ = End_Of_Start_Tag then
End_Element;
end if;
if Elem_NS_Id /= Null_Token then
Reset_Buffer (Parser, Elem_NS_Id);
else
Reset_Buffer (Parser, Elem_Name_Id);
end if;
if Id.Typ = End_Of_Input then
Fatal_Error (Parser, "Unexpected end of stream");
end if;
end Parse_Start_Tag;
----------------------------
-- Parse_Doctype_Contents --
----------------------------
procedure Parse_Doctype_Contents is
Start_Id : Symbol;
Num_Include : Natural := 0;
-- Number of 0 then
Num_Ignore := Num_Ignore + 1;
else
Num_Include := Num_Include + 1;
end if;
elsif Id.Typ = End_Conditional then
if Num_Include + Num_Ignore = 0 then
Fatal_Error (Parser, Error_Unexpected_Chars3, Id);
elsif Num_Ignore > 0 then
Num_Ignore := Num_Ignore - 1;
else
Num_Include := Num_Include - 1;
end if;
elsif Id.Typ = End_Of_Input then
exit;
elsif Num_Ignore = 0 then
case Id.Typ is
when End_Of_Tag | Internal_DTD_End =>
exit;
when Entity_Def => Parse_Entity_Def (Id);
when Element_Def => Parse_Element_Def (Id);
when Notation => Parse_Notation_Def (Id);
when Attlist_Def => Parse_Attlist_Def (Id);
when Text | Name =>
if Id.First < Id.Last then
Fatal_Error
(Parser, "Unexpected character in the DTD");
else
Reset_Buffer (Parser, Id);
end if;
when Comment =>
Comment (Parser, Parser.Buffer (Id.First .. Id.Last));
Reset_Buffer (Parser, Id);
when Start_Of_PI =>
Parse_PI (Id);
when others =>
Fatal_Error -- 2.8
(Parser, "Element not allowed in the DTD", Id);
end case;
else
Reset_Buffer (Parser, Id);
end if;
-- XML 1.0 Errata 14 or XML 1.1 section 4.3.2: nesting of entities
-- doesn't apply for well-formedness in the DTD
if Parser.Feature_Validation then
if Start_Id /= Id.Location.System_Id then
Error (Parser, Error_Entity_Self_Contained, Id);
end if;
end if;
end loop;
if Num_Ignore + Num_Include /= 0 then
Fatal_Error -- 3.4
(Parser, "Conditional section must be properly terminated",
Id);
end if;
end Parse_Doctype_Contents;
-------------------
-- Parse_Doctype --
-------------------
procedure Parse_Doctype is
Public_Start, Public_End : Token := Null_Token;
System_Start, System_End : Token := Null_Token;
Name_Id : Token;
NS_Id : Token;
begin
Set_State (Parser, DTD_State);
Next_NS_Token_Skip_Spaces (Input, Parser, NS_Id, Name_Id);
if Name_Id.Typ /= Name then
Fatal_Error (Parser, "Expecting name after Parser.Buffer (Name_Id.First .. Name_Id.Last),
Public_Id => Parser.Buffer (Public_Start.First .. Public_End.Last),
System_Id =>
Parser.Buffer (System_Start.First .. System_End.Last));
if Parser.Feature_Validation then
Parser.DTD_Name := Find_Symbol (Parser, Name_Id);
end if;
if Id.Typ = Internal_DTD_Start then
Parse_Doctype_Contents;
if Id.Typ /= Internal_DTD_End then
Fatal_Error -- 2.8
(Parser, "Expecting end of internal subset ']>'", Id);
end if;
elsif Id.Typ /= End_Of_Tag then
Fatal_Error (Parser, "Expecting end of DTD");
end if;
-- Read the external subset if required. This needs to be read
-- after the internal subset only, so that the latter gets
-- priority (XML specifications 2.8)
if System_End.Last >= System_Start.First then
declare
Loc : constant Sax.Locators.Location :=
Get_Location (Parser.Locator);
System : constant Symbol :=
Find_Symbol
(Parser,
Parser.Buffer (System_Start.First .. System_End.Last));
URI : constant Symbol :=
Resolve_URI (Parser, System_Id (Parser), System);
In_External : constant Boolean := Parser.In_External_Entity;
Input_F : File_Input;
Saved_Last_Read : constant Unicode_Char := Parser.Last_Read;
begin
Open (Get (URI).all, Input_F);
-- Protect against the case where the last character read was
-- a LineFeed.
Parser.Last_Read := Unicode_Char'Val (16#00#);
Parser.Last_Read_Is_Valid := False;
Set_Line_Number (Parser.Locator, 1);
Set_Column_Number (Parser.Locator, Prolog_Size (Input_F));
Set_System_Id (Parser.Locator, URI);
Set_Public_Id (Parser.Locator, System);
if NS_Id /= Null_Token then
Reset_Buffer (Parser, NS_Id);
else
Reset_Buffer (Parser, Name_Id);
end if;
Parser.In_External_Entity := True;
Syntactic_Parse (Parser, Input_F);
Close (Input_F);
Parser.In_External_Entity := In_External;
Set_Location (Parser.Locator, Loc);
Parser.Last_Read := Saved_Last_Read;
Parser.Last_Read_Is_Valid := True;
exception
when Name_Error =>
Close (Input_F);
Error
(Parser,
"External subset not found: "
& Parser.Buffer (System_Start.First .. System_End.Last),
Id);
if NS_Id /= Null_Token then
Reset_Buffer (Parser, NS_Id);
else
Reset_Buffer (Parser, Name_Id);
end if;
when others =>
Close (Input_F);
raise;
end;
else
if NS_Id /= Null_Token then
Reset_Buffer (Parser, NS_Id);
else
Reset_Buffer (Parser, Name_Id);
end if;
end if;
-- Check that all declarations are fully declared
if Parser.Feature_Validation then
declare
Iter : Notations_Table.Iterator := First (Parser.Notations);
begin
while Iter /= Notations_Table.No_Iterator loop
if not Current (Iter).Declaration_Seen then
Error (Parser, Error_Notation_Undeclared
& Get (Current (Iter).Name).all);
end if;
Next (Parser.Notations, Iter);
end loop;
end;
end if;
Parser.In_External_Entity := False;
End_DTD (Parser);
Set_State (Parser, Default_State);
end Parse_Doctype;
-----------------
-- End_Element --
-----------------
procedure End_Element is
begin
if Parser.Hooks.End_Element /= null then
Parser.Hooks.End_Element
(Parser'Unchecked_Access, Parser.Current_Node);
end if;
End_Element
(Parser, NS => Parser.Current_Node.NS,
Local_Name => Parser.Current_Node.Name);
-- Tag must end in the same entity
if Parser.Feature_Validation
and then
Id.Location.System_Id /= Parser.Current_Node.Start.System_Id
then
Error (Parser, Error_Entity_Self_Contained, Id);
end if;
Close_Namespaces (Parser, Parser.Current_Node.Namespaces);
-- Move back to the parent node (after freeing the current node)
Free (Parser.Current_Node);
end End_Element;
-------------------
-- Parse_End_Tag --
-------------------
procedure Parse_End_Tag is
Open_Id : constant Token := Id;
NS_Id, Name_Id : Token := Null_Token;
begin
Set_State (Parser, Tag_State);
Next_Token (Input, Parser, Id);
Get_Name_NS (Id, NS_Id, Name_Id);
if Id.Typ = Space then
Next_Token (Input, Parser, Id);
end if;
if Id.Typ /= End_Of_Tag then
Fatal_Error (Parser, "Tags must end with a '>' symbol", Id);
-- 3.1
end if;
if Parser.Current_Node = null then
Fatal_Error -- 3
(Parser, "No start tag found for this end tag", Id);
end if;
-- Tag must end in the same entity
if Parser.Feature_Validation
and then Id.Location.System_Id /=
Parser.Current_Node.Start.System_Id
then
Error (Parser, Error_Entity_Self_Contained, Id);
end if;
if Parser.Current_Node = null then
Fatal_Error
(Parser, -- WF element type match
"Unexpected closing tag", Open_Id);
elsif Parser.Buffer (NS_Id.First .. NS_Id.Last) /=
Get (Get_Prefix (Parser.Current_Node.NS)).all
or else Parser.Buffer (Name_Id.First .. Name_Id.Last) /=
Get (Parser.Current_Node.Name).all
then
-- Well-Formedness Constraint: Element Type Match
if Get_Prefix (Parser.Current_Node.NS) /= Empty_String then
Fatal_Error
(Parser, -- WF element type match
"Name differ for closing tag (expecting "
& Get (Get_Prefix (Parser.Current_Node.NS)).all
& ':' & Get (Parser.Current_Node.Name).all
& ", opened line"
& Integer'Image (Parser.Current_Node.Start.Line)
& ')',
Open_Id);
else
Fatal_Error
(Parser, -- WF element type match
"Name differ for closing tag ("
& "expecting " & Get (Parser.Current_Node.Name).all
& ", opened line"
& Integer'Image (Parser.Current_Node.Start.Line)
& ')',
Open_Id);
end if;
end if;
End_Element;
Set_State (Parser, Default_State);
if NS_Id /= Null_Token then
Reset_Buffer (Parser, NS_Id);
else
Reset_Buffer (Parser, Name_Id);
end if;
end Parse_End_Tag;
-------------------------
-- Check_Version_Value --
-------------------------
procedure Check_Version_Value (Id : in out Token) is
C : Unicode_Char;
J : Natural;
Value_Start, Value_End : Token;
Tmp_Version : XML_Versions;
begin
Next_Token_Skip_Spaces (Input, Parser, Id);
if Id.Typ /= Equal then
Fatal_Error (Parser, "Expecting '=' sign", Id);
end if;
Next_Token_Skip_Spaces (Input, Parser, Id);
if Id.Typ /= Double_String_Delimiter
and then Id.Typ /= Single_String_Delimiter
then
Fatal_Error (Parser, "Expecting version value", Id);
end if;
Get_String (Id, Attr_Value_State, Value_Start, Value_End);
J := Value_Start.First;
while J <= Value_End.Last loop
Encoding.Read (Parser.Buffer.all, J, C);
if not (C in Latin_Small_Letter_A .. Latin_Small_Letter_Z)
and then
not (C in Latin_Capital_Letter_A .. Latin_Capital_Letter_Z)
and then not (C in Digit_Zero .. Digit_Nine)
and then C /= Low_Line
and then C /= Full_Stop
and then C /= Unicode.Names.Basic_Latin.Colon
and then C /= Hyphen_Minus
then
Fatal_Error -- 2.8
(Parser, "Illegal version number in processing"
& " instruction", Value_Start);
end if;
end loop;
if Parser.Buffer (Value_Start.First .. Value_End.Last) = "1.1" then
Tmp_Version := XML_1_1;
elsif Parser.Buffer (Value_Start.First .. Value_End.Last) = "1.0" then
Tmp_Version := XML_1_0;
else
case Parser.XML_Version is
when XML_1_0_Third_Edition
| XML_1_0_Fourth_Edition =>
Error
(Parser, "Unsupported version of XML: "
& Parser.Buffer (Value_Start.First .. Value_End.Last));
when XML_1_0_Fifth_Edition
| XML_1_0
| XML_1_1 =>
null;
end case;
end if;
if Parser.In_External_Entity
and then
((Tmp_Version = XML_1_1
and then Parser.XML_Version /= XML_1_1)
or else
(Tmp_Version /= XML_1_1
and then Parser.XML_Version = XML_1_1))
then
Fatal_Error
(Parser,
"External entity doesn't have the same"
& " XML version as document");
end if;
-- Override the version in the parser, but only if the one set
-- doesn't match yet. In particular, this allows users to set their
-- preferred edition of XML 1.0
if Tmp_Version = XML_1_1
and then Parser.XML_Version /= XML_1_1
then
Parser.XML_Version := XML_1_1;
elsif Tmp_Version = XML_1_0
and then Parser.XML_Version = XML_1_1
then
Parser.XML_Version := XML_1_0;
end if;
Next_Token (Input, Parser, Id);
if Id.Typ = Space then
Next_Token (Input, Parser, Id);
elsif Id.Typ /= End_Of_PI then
Fatal_Error (Parser, "values must be separated by spaces", Id);
end if;
end Check_Version_Value;
--------------------------
-- Check_Encoding_Value --
--------------------------
procedure Check_Encoding_Value (Id : in out Token) is
Inp : Input_Source_Access := Input'Unchecked_Access;
C : Unicode_Char;
J : Natural;
Value_Start, Value_End : Token;
Tmp : Positive;
begin
-- If we are parsing an external entity, everything applies to it.
-- See test xmltest/valid/ext-sa/008.xml
if Parser.Inputs /= null then
Inp := Parser.Inputs.Input;
end if;
Next_Token_Skip_Spaces (Inp.all, Parser, Id);
if Id.Typ /= Equal then
Fatal_Error (Parser, "Expecting '=' sign");
end if;
Next_Token_Skip_Spaces (Inp.all, Parser, Id);
if Id.Typ /= Double_String_Delimiter
and then Id.Typ /= Single_String_Delimiter
then
Fatal_Error (Parser, "Expecting encoding value");
end if;
Get_String (Id, Attr_Value_State, Value_Start, Value_End);
if Value_End.Last < Value_Start.First then
Fatal_Error -- 4.3.3
(Parser, "Empty value for encoding not allowed");
else
Tmp := Value_Start.First;
Encoding.Read (Parser.Buffer.all, Tmp, C);
if not (C in Latin_Small_Letter_A .. Latin_Small_Letter_Z)
and then not
(C in Latin_Capital_Letter_A .. Latin_Capital_Letter_Z)
then
Fatal_Error -- 4.3.3
(Parser, "Illegal character '"
& Debug_Encode (C) & "' in encoding value", Value_Start);
end if;
J := Value_Start.First + Encoding.Width (C);
while J <= Value_End.Last loop
Encoding.Read (Parser.Buffer.all, J, C);
if not (C in Latin_Small_Letter_A .. Latin_Small_Letter_Z)
and then not
(C in Latin_Capital_Letter_A .. Latin_Capital_Letter_Z)
and then not (C in Digit_Zero .. Digit_Nine)
and then C /= Full_Stop
and then C /= Low_Line
and then C /= Hyphen_Minus
then
Fatal_Error -- 4.3.3
(Parser, "Illegal character '"
& Debug_Encode (C) & "' in encoding value",
Value_Start);
end if;
end loop;
end if;
-- Check we indeed have a following space
Next_Token (Inp.all, Parser, Id);
if Id.Typ = Space then
Next_Token (Inp.all, Parser, Id);
elsif Id.Typ /= End_Of_PI then
Fatal_Error (Parser, "values must be separated by spaces", Id);
end if;
-- Change the encoding for the streams, if needed
Set_Stream_Encoding
(Inp.all, Parser.Buffer (Value_Start.First .. Value_End.Last));
end Check_Encoding_Value;
----------------------------
-- Check_Standalone_Value --
----------------------------
procedure Check_Standalone_Value (Id : in out Token) is
Value_Start, Value_End : Token;
begin
Next_Token_Skip_Spaces (Input, Parser, Id);
if Id.Typ /= Equal then
Fatal_Error (Parser, "Expecting '=' sign");
end if;
Next_Token_Skip_Spaces (Input, Parser, Id);
if Id.Typ /= Double_String_Delimiter
and then Id.Typ /= Single_String_Delimiter
then
Fatal_Error
(Parser, "Parameter to 'standalone' must be quoted", Id);
end if;
Get_String (Id, Attr_Value_State, Value_Start, Value_End);
if Parser.Buffer (Value_Start.First .. Value_End.Last) /= Yes_Sequence
and then Parser.Buffer (Value_Start.First .. Value_End.Last) /=
No_Sequence
then
Fatal_Error
(Parser, -- 2.9 [32]
"Invalid value for standalone parameter in ",
Value_Start);
end if;
Parser.Standalone_Document :=
Parser.Buffer (Value_Start.First .. Value_End.Last) =
Yes_Sequence;
Next_Token (Input, Parser, Id);
if Id.Typ = Space then
Next_Token (Input, Parser, Id);
elsif Id.Typ /= End_Of_PI then
Fatal_Error (Parser, "values must be separated by spaces", Id);
end if;
end Check_Standalone_Value;
--------------
-- Parse_PI --
--------------
procedure Parse_PI (Id : in out Token) is
State : constant Parser_State := Get_State (Parser);
Open_Id : constant Token := Id;
Name_Id, Data_Start : Token;
Data_End : Token := Null_Token;
begin
Set_State (Parser, PI_State);
Next_Token (Input, Parser, Name_Id);
if Name_Id.Typ /= Name then
Fatal_Error
(Parser, -- 2.6
"Processing Instruction must specify a target name",
Name_Id);
end if;
Check_Valid_Name_Or_NCname (Parser, Name_Id);
Next_Token (Input, Parser, Id);
if Id.Typ /= Space and then Id.Typ /= End_Of_PI then
Fatal_Error (Parser, "Must have space between target and data");
elsif Id.Typ = Space then
Next_Token (Input, Parser, Id);
end if;
-- Special handling for
if Parser.Buffer (Name_Id.First .. Name_Id.Last) = Xml_Sequence then
if Open_Id.Location.Line /= 1
or else
(Parser.Inputs = null
and then Open_Id.Location.Column /= 1 + Prolog_Size (Input))
or else
(Parser.Inputs /= null
and then Open_Id.Location.Column /=
1 + Prolog_Size (Parser.Inputs.Input.all))
or else (Parser.Inputs /= null
and then not Parser.Inputs.External)
then
Fatal_Error
(Parser, -- 2.8
" instruction must be first in document",
Open_Id);
end if;
-- ??? No true for text declaratinos 4.3.1 (external parsed
-- entities)
Set_State (Parser, Tag_State);
if Parser.Buffer (Id.First .. Id.Last) = Version_Sequence then
Check_Version_Value (Id);
elsif not Parser.In_External_Entity then
Fatal_Error
(Parser, "'version' must be the first argument to ",
Id);
end if;
if Id.Typ = Name
and then Parser.Buffer (Id.First .. Id.Last) = Encoding_Sequence
then
Check_Encoding_Value (Id);
elsif Parser.In_External_Entity then
Fatal_Error
(Parser, "'encoding' must be specified for in"
& " external entities", Id);
end if;
if not Parser.In_External_Entity
and then Id.Typ = Name
and then Parser.Buffer (Id.First .. Id.Last) =
Standalone_Sequence
then
Check_Standalone_Value (Id);
end if;
if Id.Typ /= End_Of_PI then
if Parser.In_External_Entity then
Fatal_Error
(Parser,
"Text declarations in external entity cannot"
& " specify parameters other than 'version' and"
& " 'encoding'", Id);
else
Fatal_Error
(Parser,
" arguments can only be 'version', 'encoding' or"
& " 'standalone', in that order", Id);
end if;
end if;
else
-- (2.6)[17]: Name can not be 'xml' (case insensitive)
declare
C : Unicode_Char;
J : Natural := Name_Id.First;
begin
Encoding.Read (Parser.Buffer.all, J, C);
if C = Latin_Small_Letter_X
or else C = Latin_Capital_Letter_X
then
Encoding.Read (Parser.Buffer.all, J, C);
if C = Latin_Capital_Letter_M
or else C = Latin_Small_Letter_M
then
Encoding.Read (Parser.Buffer.all, J, C);
if (C = Latin_Capital_Letter_L
or else C = Latin_Small_Letter_L)
and then J = Name_Id.Last + 1
then
Fatal_Error
(Parser, -- 2.6
"'"
& Parser.Buffer (Name_Id.First .. Name_Id.Last)
& "' is not a valid processing instruction target",
Name_Id);
end if;
end if;
end if;
end;
Data_Start := Id;
while Id.Typ /= End_Of_PI and then Id.Typ /= End_Of_Input loop
Data_End := Id;
if Id.Typ = Double_String_Delimiter then
Put_In_Buffer (Parser, """");
Data_End.Last := Data_End.Last + 1;
elsif Id.Typ = Single_String_Delimiter then
Put_In_Buffer (Parser, "'");
Data_End.Last := Data_End.Last + 1;
end if;
Next_Token (Input, Parser, Id);
end loop;
if Id.Typ = End_Of_Input then
Fatal_Error -- 2.6
(Parser, "Processing instruction must end with '?>'",
Open_Id);
end if;
Processing_Instruction
(Parser,
Target => Parser.Buffer (Name_Id.First .. Name_Id.Last),
Data => Parser.Buffer (Data_Start.First .. Data_End.Last));
end if;
Set_State (Parser, State);
Reset_Buffer (Parser, Name_Id);
end Parse_PI;
begin
-- Initialize the parser with the first character of the stream.
if Eof (Input) then
return;
end if;
Next_Char (Input, Parser);
if Parser.State.In_DTD then
Parse_Doctype_Contents;
end if;
loop
-- Unless in string, buffer should be empty at this point. Strings
-- are special-cased just in case we are currently substituting
-- entities while in a string.
pragma Assert (Parser.State.Ignore_Special
or else Parser.Buffer_Length = 0);
Next_Token (Input, Parser, Id,
Coalesce_Space => Parser.Current_Node /= null);
exit when Id.Typ = End_Of_Input;
case Id.Typ is
when Start_Of_PI =>
Parse_PI (Id);
when Cdata_Section =>
if Parser.Current_Node = null then
Fatal_Error -- 2.1
(Parser, "Non-white space found at top level", Id);
end if;
Start_Cdata (Parser);
if Parser.Hooks.Characters /= null then
Parser.Hooks.Characters
(Parser'Unchecked_Access,
Parser.Buffer (Id.First .. Id.Last));
end if;
Characters (Parser, Parser.Buffer (Id.First .. Id.Last));
End_Cdata (Parser);
Reset_Buffer (Parser, Id);
when Text | Name =>
if Parser.Current_Node = null then
Fatal_Error -- 2.1
(Parser, "Non-white space found at top level", Id);
end if;
if Parser.Hooks.Characters /= null then
Parser.Hooks.Characters
(Parser'Unchecked_Access,
Parser.Buffer (Id.First .. Id.Last));
end if;
Characters (Parser, Parser.Buffer (Id.First .. Id.Last));
Reset_Buffer (Parser, Id);
when Sax.Readers.Space =>
-- If "xml:space" attribute is preserve
-- then same as Text
if Parser.Hooks.Whitespace /= null then
Parser.Hooks.Whitespace
(Parser'Unchecked_Access,
Parser.Buffer (Id.First .. Id.Last));
end if;
Ignorable_Whitespace
(Parser, Parser.Buffer (Id.First .. Id.Last));
Reset_Buffer (Parser, Id);
when Comment =>
Comment (Parser, Parser.Buffer (Id.First .. Id.Last));
Reset_Buffer (Parser, Id);
when Start_Of_Tag =>
Parse_Start_Tag;
when Start_Of_End_Tag =>
Parse_End_Tag;
when Doctype_Start =>
Parse_Doctype;
when others =>
Fatal_Error (Parser, "Currently ignored: "
& Token_Type'Image (Id.Typ));
end case;
end loop;
end Syntactic_Parse;
----------
-- Free --
----------
procedure Free (Parser : in out Sax_Reader'Class) is
Tmp, Tmp2 : Element_Access;
begin
Close_Inputs (Parser, Parser.Inputs);
Close_Inputs (Parser, Parser.Close_Inputs);
Free (Parser.Default_Namespaces);
Free (Parser.Buffer);
Parser.Buffer_Length := 0;
Parser.Attributes.Count := 0;
Unchecked_Free (Parser.Attributes.List);
-- Free the nodes, in case there are still some open
Tmp := Parser.Current_Node;
while Tmp /= null loop
Tmp2 := Tmp.Parent;
Free (Tmp);
Tmp := Tmp2;
end loop;
-- Free the content model for the default attributes
-- is done automatically when the attributes are reset
if Parser.Hooks.Data /= null then
Free (Parser.Hooks.Data.all);
Unchecked_Free (Parser.Hooks.Data);
end if;
-- Free the internal tables
Reset (Parser.Entities);
Reset (Parser.Default_Atts);
Reset (Parser.Notations);
Free (Parser.Locator);
end Free;
---------------
-- Set_Hooks --
---------------
procedure Set_Hooks
(Handler : in out Sax_Reader;
Data : Hook_Data_Access := null;
Start_Element : Start_Element_Hook := null;
End_Element : End_Element_Hook := null;
Characters : Characters_Hook := null;
Whitespace : Whitespace_Hook := null;
Doc_Locator : Set_Doc_Locator_Hook := null;
Notation_Decl : Notation_Decl_Hook := null) is
begin
if Handler.Hooks.Data /= null then
Free (Handler.Hooks.Data.all);
Unchecked_Free (Handler.Hooks.Data);
end if;
Handler.Hooks :=
(Data => Data,
Start_Element => Start_Element,
End_Element => End_Element,
Characters => Characters,
Whitespace => Whitespace,
Doc_Locator => Doc_Locator,
Notation_Decl => Notation_Decl);
end Set_Hooks;
------------------------
-- Initialize_Symbols --
------------------------
procedure Initialize_Symbols (Parser : in out Sax_Reader) is
begin
if Parser.Lt_Sequence = No_Symbol then
if Get (Parser.Symbols) = null then
if Debug_Internal then
Put_Line ("Initialize_Symbols: creating new table");
end if;
Parser.Symbols := Sax.Utils.Allocate;
end if;
Parser.Lt_Sequence := Find_Symbol (Parser, Lt_Sequence);
Parser.Gt_Sequence := Find_Symbol (Parser, Gt_Sequence);
Parser.Amp_Sequence := Find_Symbol (Parser, Amp_Sequence);
Parser.Apos_Sequence := Find_Symbol (Parser, Apos_Sequence);
Parser.Quot_Sequence := Find_Symbol (Parser, Quot_Sequence);
Parser.Xmlns_Sequence := Find_Symbol (Parser, Xmlns_Sequence);
Parser.Xml_Sequence := Find_Symbol (Parser, Xml_Sequence);
Parser.Symbol_Percent := Find_Symbol (Parser, "%");
Parser.Symbol_Ampersand := Find_Symbol (Parser, "&");
Parser.Namespaces_URI_Sequence :=
Find_Symbol (Parser, Namespaces_URI_Sequence);
end if;
end Initialize_Symbols;
----------------------
-- Close_Namespaces --
----------------------
procedure Close_Namespaces
(Parser : in out Sax_Reader'Class; List : XML_NS)
is
NS : XML_NS := List;
begin
while NS /= No_XML_NS loop
if Get_Prefix (NS) /= Empty_String
and then Get_Prefix (NS) /= Parser.Xmlns_Sequence
then
End_Prefix_Mapping (Parser, Get_Prefix (NS));
end if;
NS := Next_In_List (NS);
end loop;
end Close_Namespaces;
-----------
-- Parse --
-----------
procedure Parse
(Parser : in out Sax_Reader;
Input : in out Input_Sources.Input_Source'Class) is
begin
Initialize_Symbols (Parser);
Parser.Locator := Sax.Locators.Create;
Parser.Public_Id := Find_Symbol (Parser, Get_Public_Id (Input));
Set_Public_Id (Parser.Locator, Parser.Public_Id);
Parser.System_Id := Find_Symbol (Parser, Get_System_Id (Input));
Set_System_Id (Parser.Locator, Parser.System_Id);
Set_Column_Number (Parser.Locator, Prolog_Size (Input));
Set_Line_Number (Parser.Locator, 1);
Parser.Lookup_Char := Unicode.Unicode_Char'Last;
Parser.Current_Node := null;
Parser.Num_Toplevel_Elements := 0;
Parser.Previous_Char_Was_CR := False;
Parser.Ignore_State_Special := False;
Parser.In_External_Entity := False;
Parser.Last_Read_Is_Valid := False;
Parser.Buffer := new Byte_Sequence (1 .. Initial_Buffer_Length);
Set_State (Parser, Default_State);
pragma Warnings (Off, "overlaps with actual");
Add_Namespace_No_Event
(Parser,
Prefix => Parser.Xml_Sequence,
URI => Find_Symbol
(Parser,
Encodings.From_Utf32
(Basic_8bit.To_Utf32 ("http://www.w3.org/XML/1998/namespace"))));
Add_Namespace_No_Event
(Parser, Parser.Xmlns_Sequence, Parser.Xmlns_Sequence);
Add_Namespace_No_Event (Parser, Empty_String, Empty_String);
if Parser.Hooks.Doc_Locator /= null then
Parser.Hooks.Doc_Locator (Parser, Parser.Locator);
end if;
Set_Document_Locator (Sax_Reader'Class (Parser), Parser.Locator);
Start_Document (Sax_Reader'Class (Parser));
Syntactic_Parse (Sax_Reader'Class (Parser), Input);
Close_Namespaces (Parser, Parser.Default_Namespaces);
pragma Warnings (On, "overlaps with actual");
-- All the nodes must have been closed at the end of the document
if Parser.Current_Node /= null then
Fatal_Error -- 2.1
(Parser, "Node <" & Get (Parser.Current_Node.Name).all
& "> is not closed");
end if;
if Parser.Num_Toplevel_Elements = 0 then
Fatal_Error (Parser, "No root element specified"); -- 2.1
end if;
End_Document (Sax_Reader'Class (Parser));
Free (Parser);
exception
when others =>
Free (Parser);
raise;
end Parse;
----------
-- Hash --
----------
function Hash (Str : String) return Unsigned_32 is
Result : Unsigned_32 := Str'Length;
begin
for J in Str'Range loop
Result := Rotate_Left (Result, 1) +
Unsigned_32 (Character'Pos (Str (J)));
end loop;
return Result;
end Hash;
-------------
-- Get_Key --
-------------
function Get_Key (Entity : Entity_Entry_Access) return Symbol is
begin
return Entity.Name;
end Get_Key;
----------
-- Free --
----------
procedure Free (Att : in out Attributes_Entry) is
begin
Unchecked_Free (Att.Attributes.List);
Att.Attributes.Count := 0;
end Free;
-------------
-- Get_Key --
-------------
function Get_Key (Att : Attributes_Entry) return Symbol is
begin
return Att.Element_Name;
end Get_Key;
----------
-- Free --
----------
procedure Free (Notation : in out Notation_Entry) is
pragma Unreferenced (Notation);
begin
null;
end Free;
-------------
-- Get_Key --
-------------
function Get_Key (Notation : Notation_Entry) return Symbol is
begin
return Notation.Name;
end Get_Key;
-----------------
-- Get_Feature --
-----------------
function Get_Feature (Parser : Sax_Reader; Name : String) return Boolean is
begin
if Name = Namespace_Feature then
return Parser.Feature_Namespace;
elsif Name = Namespace_Prefixes_Feature then
return Parser.Feature_Namespace_Prefixes;
elsif Name = External_General_Entities_Feature then
return Parser.Feature_External_General_Entities;
elsif Name = External_Parameter_Entities_Feature then
return Parser.Feature_External_Parameter_Entities;
elsif Name = Validation_Feature then
return Parser.Feature_Validation;
elsif Name = Parameter_Entities_Feature then
return False; -- ??? Unsupported for now
elsif Name = Test_Valid_Chars_Feature then
return Parser.Feature_Test_Valid_Chars;
elsif Name = Allow_Relative_IRI_Feature then
return Parser.Feature_Allow_Relative_IRI;
elsif Name = Schema_Validation_Feature then
return Parser.Feature_Schema_Validation;
end if;
return False;
end Get_Feature;
-----------------
-- Set_Feature --
-----------------
procedure Set_Feature
(Parser : in out Sax_Reader; Name : String; Value : Boolean) is
begin
if Name = Namespace_Feature then
Parser.Feature_Namespace := Value;
elsif Name = Namespace_Prefixes_Feature then
Parser.Feature_Namespace_Prefixes := Value;
elsif Name = External_General_Entities_Feature then
Parser.Feature_External_General_Entities := Value;
elsif Name = External_Parameter_Entities_Feature then
Parser.Feature_External_Parameter_Entities := Value;
elsif Name = Validation_Feature then
Parser.Feature_Validation := Value;
elsif Name = Test_Valid_Chars_Feature then
Parser.Feature_Test_Valid_Chars := Value;
elsif Name = Schema_Validation_Feature then
Parser.Feature_Schema_Validation := Value;
elsif Name = Allow_Relative_IRI_Feature then
Parser.Feature_Allow_Relative_IRI := Value;
end if;
end Set_Feature;
-----------------
-- Fatal_Error --
-----------------
procedure Fatal_Error
(Handler : in out Sax_Reader; Except : Sax_Parse_Exception'Class)
is
pragma Warnings (Off, Handler);
begin
Raise_Exception
(XML_Fatal_Error'Identity,
Get_Message (Except));
end Fatal_Error;
--------------------------
-- Start_Prefix_Mapping --
--------------------------
procedure Start_Prefix_Mapping
(Handler : in out Reader;
Prefix : Sax.Symbols.Symbol;
URI : Sax.Symbols.Symbol)
is
begin
Start_Prefix_Mapping
(Reader'Class (Handler), Get (Prefix).all, Get (URI).all);
end Start_Prefix_Mapping;
------------------------
-- End_Prefix_Mapping --
------------------------
procedure End_Prefix_Mapping (Handler : in out Reader; Prefix : Symbol) is
begin
End_Prefix_Mapping
(Reader'Class (Handler), Get (Prefix).all);
end End_Prefix_Mapping;
-------------------
-- Start_Element --
-------------------
procedure Start_Element
(Handler : in out Reader;
NS : Sax.Utils.XML_NS;
Local_Name : Sax.Symbols.Symbol;
Atts : Sax_Attribute_List)
is
Attributes : Sax.Attributes.Attributes := Create_Attribute_List (Atts);
begin
Start_Element
(Reader'Class (Handler),
Namespace_URI => Get (Get_URI (NS)).all,
Local_Name => Get (Local_Name).all,
Qname => Qname_From_Name (Get_Prefix (NS), Local_Name),
Atts => Attributes);
Clear (Attributes);
exception
when others =>
Clear (Attributes);
raise;
end Start_Element;
-----------------
-- End_Element --
-----------------
procedure End_Element
(Handler : in out Reader;
NS : Sax.Utils.XML_NS;
Local_Name : Sax.Symbols.Symbol) is
begin
End_Element
(Reader'Class (Handler),
Namespace_URI => Get (Get_URI (NS)).all,
Local_Name => Get (Local_Name).all,
Qname => Qname_From_Name (Get_Prefix (NS), Local_Name));
end End_Element;
--------------------
-- Skipped_Entity --
--------------------
procedure Skipped_Entity
(Handler : in out Reader;
Name : Sax.Symbols.Symbol) is
begin
Skipped_Entity (Reader'Class (Handler), Get (Name).all);
end Skipped_Entity;
------------------
-- Start_Entity --
------------------
procedure Start_Entity
(Handler : in out Reader;
Name : Sax.Symbols.Symbol) is
begin
Start_Entity (Reader'Class (Handler), Get (Name).all);
end Start_Entity;
----------------
-- End_Entity --
----------------
procedure End_Entity
(Handler : in out Reader;
Name : Sax.Symbols.Symbol) is
begin
End_Entity (Reader'Class (Handler), Get (Name).all);
end End_Entity;
--------------------
-- Resolve_Entity --
--------------------
function Resolve_Entity
(Handler : Sax_Reader;
Public_Id : Unicode.CES.Byte_Sequence;
System_Id : Unicode.CES.Byte_Sequence)
return Input_Sources.Input_Source_Access
is
pragma Warnings (Off, Handler);
pragma Warnings (Off, Public_Id);
pragma Warnings (Off, System_Id);
begin
return null;
end Resolve_Entity;
--------------------
-- Get_Hooks_Data --
--------------------
function Get_Hooks_Data (Handler : Sax_Reader) return Hook_Data_Access is
begin
return Handler.Hooks.Data;
end Get_Hooks_Data;
------------------------------------
-- Use_Basename_In_Error_Messages --
------------------------------------
procedure Use_Basename_In_Error_Messages
(Parser : in out Sax_Reader;
Use_Basename : Boolean := True)
is
begin
Parser.Basename_In_Messages := Use_Basename;
end Use_Basename_In_Error_Messages;
------------------------------------
-- Use_Basename_In_Error_Messages --
------------------------------------
function Use_Basename_In_Error_Messages
(Parser : Sax_Reader) return Boolean is
begin
return Parser.Basename_In_Messages;
end Use_Basename_In_Error_Messages;
------------
-- Get_NS --
------------
function Get_NS (Elem : Element_Access) return XML_NS is
begin
return Elem.NS;
end Get_NS;
--------------------
-- Get_Local_Name --
--------------------
function Get_Local_Name (Elem : Element_Access) return Symbol is
begin
return Elem.Name;
end Get_Local_Name;
--------------
-- To_QName --
--------------
function To_QName
(Namespace_URI, Local_Name : Sax.Symbols.Symbol)
return Unicode.CES.Byte_Sequence is
begin
if Namespace_URI = Empty_String then
return Get (Local_Name).all;
else
return '{' & Get (Namespace_URI).all & '}' & Get (Local_Name).all;
end if;
end To_QName;
--------------
-- To_QName --
--------------
function To_QName
(Elem : Element_Access) return Unicode.CES.Byte_Sequence is
begin
return To_QName (Get_URI (Elem.NS), Elem.Name);
end To_QName;
----------------------
-- Set_Symbol_Table --
----------------------
procedure Set_Symbol_Table
(Parser : in out Sax_Reader;
Symbols : Symbol_Table) is
begin
Parser.Lt_Sequence := No_Symbol;
Parser.Symbols := Symbols;
end Set_Symbol_Table;
----------------------
-- Get_Symbol_Table --
----------------------
function Get_Symbol_Table (Parser : Sax_Reader'Class) return Symbol_Table is
begin
return Parser.Symbols;
end Get_Symbol_Table;
---------------
-- Get_Index --
---------------
function Get_Index
(List : Sax_Attribute_List;
URI : Sax.Symbols.Symbol;
Local_Name : Sax.Symbols.Symbol) return Integer is
begin
for A in 1 .. List.Count loop
if List.List (A).URI = URI
and then List.List (A).Local_Name = Local_Name
then
return A;
end if;
end loop;
return -1;
end Get_Index;
---------------
-- Get_Index --
---------------
function Get_Index
(Handler : Sax_Reader'Class;
List : Sax_Attribute_List;
URI : Unicode.CES.Byte_Sequence;
Local_Name : Unicode.CES.Byte_Sequence) return Integer is
begin
return Get_Index
(List,
URI => Find_Symbol (Handler, URI),
Local_Name => Find_Symbol (Handler, Local_Name));
end Get_Index;
---------------
-- Get_Value --
---------------
function Get_Value
(List : Sax_Attribute_List; Index : Integer) return Sax.Symbols.Symbol is
begin
if Index < 0 then
return No_Symbol;
else
return List.List (Index).Value;
end if;
end Get_Value;
---------------
-- Set_Value --
---------------
procedure Set_Value
(List : Sax_Attribute_List;
Index : Integer;
Val : Sax.Symbols.Symbol) is
begin
List.List (Index).Value := Val;
end Set_Value;
------------------
-- Get_Location --
------------------
function Get_Location
(List : Sax_Attribute_List; Index : Integer) return Sax.Locators.Location
is
begin
if Index < 0 then
return No_Location;
else
return List.List (Index).Location;
end if;
end Get_Location;
------------------------
-- Start_Tag_Location --
------------------------
function Start_Tag_Location
(Elem : Element_Access) return Sax.Locators.Location is
begin
return Elem.Start;
end Start_Tag_Location;
----------------------------
-- Start_Tag_End_Location --
----------------------------
function Start_Tag_End_Location
(Elem : Element_Access) return Sax.Locators.Location is
begin
return Elem.Start_Tag_End;
end Start_Tag_End_Location;
------------------------------
-- Get_Non_Normalized_Value --
------------------------------
function Get_Non_Normalized_Value
(List : Sax_Attribute_List; Index : Integer) return Sax.Symbols.Symbol is
begin
return List.List (Index).Non_Normalized_Value;
end Get_Non_Normalized_Value;
--------------------------
-- Get_Value_As_Boolean --
--------------------------
function Get_Value_As_Boolean
(List : Sax_Attribute_List; Index : Integer; Default : Boolean := False)
return Boolean
is
Val : Symbol;
begin
if Index < 0 then
return Default;
else
Val := Get_Value (List, Index);
return Get (Val).all = "true" or else Get (Val).all = "1";
end if;
end Get_Value_As_Boolean;
--------------------------
-- Set_Normalized_Value --
--------------------------
procedure Set_Normalized_Value
(List : Sax_Attribute_List; Index : Integer; Value : Sax.Symbols.Symbol)
is
begin
List.List (Index).Value := Value;
end Set_Normalized_Value;
--------------
-- Get_Type --
--------------
function Get_Type
(List : Sax_Attribute_List; Index : Integer)
return Sax.Attributes.Attribute_Type is
begin
return List.List (Index).Att_Type;
end Get_Type;
--------------
-- Set_Type --
--------------
procedure Set_Type
(List : Sax_Attribute_List; Index : Integer;
Typ : Sax.Attributes.Attribute_Type) is
begin
List.List (Index).Att_Type := Typ;
end Set_Type;
----------------
-- Get_Length --
----------------
function Get_Length (List : Sax_Attribute_List) return Natural is
begin
return List.Count;
end Get_Length;
----------------
-- Get_Prefix --
----------------
function Get_Prefix
(List : Sax_Attribute_List; Index : Integer) return Sax.Symbols.Symbol is
begin
return List.List (Index).Prefix;
end Get_Prefix;
--------------
-- Get_Name --
--------------
function Get_Name
(List : Sax_Attribute_List; Index : Integer) return Qualified_Name is
begin
return (NS => List.List (Index).URI,
Local => List.List (Index).Local_Name);
end Get_Name;
---------------
-- Get_Qname --
---------------
function Get_Qname
(List : Sax_Attribute_List; Index : Integer)
return Unicode.CES.Byte_Sequence
is
begin
return Qname_From_Name (List.List (Index).Prefix,
List.List (Index).Local_Name);
end Get_Qname;
----------------------
-- Current_Location --
----------------------
function Current_Location
(Handler : Sax_Reader) return Sax.Locators.Location is
begin
return Get_Location (Handler.Locator);
end Current_Location;
---------------------
-- Set_XML_Version --
---------------------
procedure Set_XML_Version
(Parser : in out Sax_Reader; XML : XML_Versions := XML_1_0_Fifth_Edition)
is
begin
if XML = XML_1_0 then
Parser.XML_Version := XML_1_0_Fifth_Edition;
else
Parser.XML_Version := XML;
end if;
end Set_XML_Version;
---------------------
-- Get_XML_Version --
---------------------
function Get_XML_Version (Parser : Sax_Reader) return XML_Versions is
begin
return Parser.XML_Version;
end Get_XML_Version;
end Sax.Readers;