------------------------------------------------------------------------------
-- XML/Ada - An XML suite for Ada95 --
-- --
-- Copyright (C) 2003-2012, 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. --
-- --
-- --
-- --
-- --
-- --
-- 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 Unicode; use Unicode;
with Unicode.CES; use Unicode.CES;
with Sax.Locators; use Sax.Locators;
with Sax.Utils; use Sax.Utils;
with Sax.Readers; use Sax.Readers;
with Sax.Symbols; use Sax.Symbols;
with Schema.Simple_Types; use Schema.Simple_Types;
with Schema.Validators; use Schema.Validators;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
with Ada.Unchecked_Deallocation;
with Schema.Schema_Readers; use Schema.Schema_Readers;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
package body Schema.Readers is
use Schema_State_Machines, Schema_State_Machines_PP;
use Schema_State_Machines_Matchers;
procedure Print is new Schema_State_Machines_Matchers.Debug_Print
(Schema_State_Machines_PP.Node_Label);
procedure Internal_Characters
(Handler : access validating_reader'class;
Ch : Unicode.CES.byte_sequence);
-- Store Ch in the current sequence of characters. This is needed to
-- collapse multiple calls to Characters and Ignorable_Whitespace into a
-- single string, for validation purposes.
procedure Validate_Current_Characters
(Handler : access validating_reader'class;
Loc : location);
-- Validate the current set of characters
procedure Reset (Parser : in out validating_reader);
-- Reset the state of the parser so that we can parse other documents.
-- This doesn't reset the grammar
procedure Hook_Start_Element
(Handler : access sax_reader'class;
Elem : element_access;
Atts : in out sax_attribute_list);
procedure Hook_End_Element
(Handler : access sax_reader'class;
Elem : element_access);
procedure Hook_Characters
(Handler : access sax_reader'class;
Ch : Unicode.CES.byte_sequence);
procedure Hook_Ignorable_Whitespace
(Handler : access sax_reader'class;
Ch : Unicode.CES.byte_sequence);
procedure Hook_Notation_Decl
(Handler : access sax_reader'class;
Name : Unicode.CES.byte_sequence;
Public_Id : Unicode.CES.byte_sequence;
System_Id : Unicode.CES.byte_sequence);
-- See for the corresponding primitive operations. These provide the
-- necessary validation hooks.
-----------------
-- Set_Grammar --
-----------------
procedure Set_Grammar
(Reader : in out validating_reader;
Grammar : Schema.Validators.xml_grammar)
is
use Symbol_Table_Pointers;
begin
if Debug then
Debug_Output ("Set_Grammar");
end if;
if Grammar /= No_Grammar then
if Get (Get_Symbol_Table (Reader)) = null then
if Debug then
Debug_Output ("Set reader's symbol table from grammar");
end if;
Set_Symbol_Table (Reader, Get_Symbol_Table (Grammar));
elsif Get_Symbol_Table (Grammar) =
Symbol_Table_Pointers.Null_Pointer
then
if Debug then
Debug_Output ("Set grammar's symbol table from reader");
end if;
Set_Symbol_Table (Grammar, Get_Symbol_Table (Reader));
elsif Get_Symbol_Table (Reader) /= Get_Symbol_Table (Grammar) then
raise XML_Fatal_Error
with "The grammar and the reader must use the same symbol table";
end if;
end if;
Reader.Grammar := Grammar;
end Set_Grammar;
----------------------
-- Set_Symbol_Table --
----------------------
overriding procedure Set_Symbol_Table
(Parser : in out validating_reader;
Symbols : Sax.Utils.symbol_table)
is
use Symbol_Table_Pointers;
begin
if Parser.Grammar /= No_Grammar
and then Get_Symbol_Table (Parser.Grammar) /= Symbols
then
raise XML_Fatal_Error
with "The grammar and the reader must use the same symbol table";
end if;
if Symbols /= Get_Symbol_Table (Parser) then
Parser.Xmlns := No_Symbol; -- Will force another lookup next time
Set_Symbol_Table (sax_reader (Parser), Symbols);
end if;
end Set_Symbol_Table;
-----------------
-- Get_Grammar --
-----------------
function Get_Grammar
(Reader : validating_reader) return Schema.Validators.xml_grammar
is
begin
return Reader.Grammar;
end Get_Grammar;
---------------------
-- To_Absolute_URI --
---------------------
function To_Absolute_URI
(Handler : validating_reader;
URI : symbol) return symbol
is
U : constant cst_byte_sequence_access := Get (URI);
begin
if URI = Empty_String then
return URI;
elsif U (U'first) /= '/' and then U (U'first) /= '\' then
return Find_Symbol
(Handler,
Dir_Name (Get (Handler.Current_Location.System_Id).all) & U.all);
else
return URI;
end if;
end To_Absolute_URI;
--------------------
-- Parse_Grammars --
--------------------
procedure Parse_Grammars
(Handler : access validating_reader'class;
Schema_Location : symbol;
Do_Create_NFA : Boolean)
is
URI : symbol := No_Symbol;
procedure Callback (Ch : byte_sequence);
procedure Callback (Ch : byte_sequence) is
begin
if URI = No_Symbol then
URI := Find_Symbol (Handler.all, Ch);
else
Parse_Grammar
(Handler,
URI => URI,
Xsd_File => Find_Symbol (Handler.all, Ch),
Do_Create_NFA => Do_Create_NFA);
URI := No_Symbol;
end if;
end Callback;
procedure For_Each is new For_Each_Item (Callback);
begin
For_Each (Get (Schema_Location).all);
end Parse_Grammars;
---------------------------------
-- Validate_Current_Characters --
---------------------------------
procedure Validate_Current_Characters
(Handler : access validating_reader'class;
Loc : location)
is
Is_Empty : Boolean;
Whitespace : whitespace_restriction := preserve;
NFA : constant schema_nfa_access := Get_NFA (Handler.Grammar);
S : state;
Descr : access type_descr;
Fixed : symbol := No_Symbol;
Default : symbol := No_Symbol;
Data : state_data;
Ty : type_index;
Is_Equal : Boolean;
begin
if Debug then
Print (Handler.Matcher, dump_compact, "Validate_Current_Char: ");
end if;
-- Handling of nil elements
if Handler.Is_Nil then
if Handler.Characters_Count /= 0 then
Validation_Error
(Handler,
"No character content allowed because the element is 'nilled'",
Loc);
end if;
return; -- Content is always considered valid
end if;
-- Check all active states to find our whitespace normalization rules,
-- and whether elements have fixed values. Note that the fixed value
-- is attached to an state with a nested state (ie the state
-- representing the element itself).
declare
Iter : active_state_iterator :=
For_Each_Active_State
(Handler.Matcher,
Ignore_If_Nested => True,
Ignore_If_Default => True);
begin
loop
S := Current (Handler.Matcher, Iter);
exit when S = No_State;
Data := Current_Data (Handler.Matcher, Iter);
if Fixed = No_Symbol then
Fixed := Data.Fixed;
-- Get the "fixed" value from the element
-- (if it has a complexType)
if Fixed = No_Symbol and then Has_Parent (Iter) then
Fixed := Current_Data (Handler.Matcher, Parent (Iter)).Fixed;
end if;
end if;
if Default = No_Symbol then
Default := Data.Default;
if Default = No_Symbol and then Has_Parent (Iter) then
Default :=
Current_Data (Handler.Matcher, Parent (Iter)).Default;
end if;
end if;
-- Unless we have a type
if Data.Simple /= No_Type_Index then
Descr := Get_Type_Descr (NFA, Data.Simple);
if Descr.Simple_Content /= No_Simple_Type_Index then
Whitespace :=
Get_Simple_Type
(Get_NFA (Handler.Grammar),
Descr.Simple_Content)
.Whitespace;
end if;
end if;
Next (Handler.Matcher, Iter);
end loop;
end;
Is_Empty := Handler.Characters_Count = 0;
if not Is_Empty then
if Debug then
Debug_Output ("Normalize whitespace: " & Whitespace'img);
end if;
Normalize_Whitespace
(Whitespace,
Handler.Characters.all,
Handler.Characters_Count);
end if;
-- in 3.3.1: if the element is empty, the "fixed" value
-- should be used for it, just as for "default"
-- Characters (Handler.all, Get (Get_Fixed (Handler)).all);
if Is_Empty and then Fixed /= No_Symbol then
Internal_Characters (Handler, Get (Fixed).all);
Is_Empty := Handler.Characters_Count = 0;
if Debug then
Debug_Output
("Substitute fixed value for empty characters:" &
Get (Fixed).all);
end if;
end if;
-- If still empty, use the default value
if Is_Empty and then Default /= No_Symbol then
Internal_Characters (Handler, Get (Default).all);
Is_Empty := Handler.Characters_Count = 0;
if Debug then
Debug_Output
("Substitute default value for empty characters:" &
Get (Default).all);
end if;
end if;
declare
Iter : active_state_iterator :=
For_Each_Active_State
(Handler.Matcher,
Ignore_If_Nested => True,
Ignore_If_Default => True);
begin
loop
S := Current (Handler.Matcher, Iter);
exit when S = No_State;
Ty := Current_Data (Handler.Matcher, Iter).Simple;
if Ty /= No_Type_Index then
Descr := Get_Type_Descr (NFA, Ty);
if Descr.Simple_Content /= No_Simple_Type_Index then
if Debug and not Is_Empty then
Debug_Output
("Validate characters (" &
To_QName (Descr.Name) &
"): " &
Handler.Characters (1 .. Handler.Characters_Count) &
"--");
end if;
if Handler.Characters_Count = 0 then
Validate_Simple_Type
(Handler,
Descr.Simple_Content,
"",
Loc => Loc);
else
Validate_Simple_Type
(Handler,
Descr.Simple_Content,
Handler.Characters (1 .. Handler.Characters_Count),
Loc => Loc);
end if;
elsif not Descr.Mixed and then not Is_Empty then
if Debug then
Debug_Output
("No character data for " &
To_QName (Descr.Name) &
S'img);
Debug_Output
("Got " &
Handler.Characters
(1 .. Integer'min (20, Handler.Characters_Count)) &
"--");
end if;
Validation_Error
(Handler,
"No character data allowed by content model",
Loc);
end if;
-- We now know we have a valid character content, and we need
-- to check it is equal to the fixed value. We also know that
-- fixed matches the type, since it was checked when the XSD
-- was parsed.
if Fixed /= No_Symbol then
if Debug then
Debug_Output
("Element has fixed value: """ & Get (Fixed).all & '"');
end if;
if Descr.Simple_Content /= No_Simple_Type_Index then
Is_Equal :=
Equal
(Reader => Handler,
Simple_Type => Descr.Simple_Content,
Ch1 => Fixed,
Ch2 =>
Handler.Characters
(1 .. Handler.Characters_Count));
else
Is_Equal :=
Get (Fixed).all =
Handler.Characters (1 .. Handler.Characters_Count);
end if;
if not Is_Equal then
Validation_Error
(Handler,
"Invalid character content (fixed to """ &
Get (Fixed).all &
""")");
end if;
end if;
end if;
Next (Handler.Matcher, Iter);
end loop;
end;
Handler.Characters_Count := 0;
end Validate_Current_Characters;
------------------------
-- Hook_Notation_Decl --
------------------------
procedure Hook_Notation_Decl
(Handler : access sax_reader'class;
Name : Unicode.CES.byte_sequence;
Public_Id : Unicode.CES.byte_sequence;
System_Id : Unicode.CES.byte_sequence)
is
pragma unreferenced (Public_Id, System_Id);
H : constant validating_reader_access :=
validating_reader_access (Handler);
begin
Add_Notation (Get_NFA (H.Grammar), Find_Symbol (H.all, Name));
end Hook_Notation_Decl;
------------------------
-- Hook_Start_Element --
------------------------
procedure Hook_Start_Element
(Handler : access sax_reader'class;
Elem : element_access;
Atts : in out sax_attribute_list)
is
H : constant validating_reader_access :=
validating_reader_access (Handler);
No_Index : constant Integer :=
Get_Index (Atts, H.XML_Instance_URI, H.No_Namespace_Schema_Location);
Location_Index : constant Integer :=
Get_Index (Atts, H.XML_Instance_URI, H.Schema_Location);
NFA : constant schema_nfa_access := Get_NFA (H.Grammar);
procedure Compute_Type_From_Attribute
(Result_Index : out type_index;
Result : out type_descr_access);
-- If xsi:type was specified, verify that the given type is a valid
-- substitution for the original type in the NFA, and replace the
-- current nested automaton with the one for the type. The replacement
-- does not affect the NFA itself, but the NFA_Matcher, so is only
-- temporary and does not affect over running matchers.
--
-- Return the first state in the nested NFA to represent that type
procedure Replace_State
(Check_Substitution : Boolean;
Nested_Start : state;
Simple : type_index);
-- Replace the current most nested NFA with [Nested_Start], to override
-- the type. This might mean replacing a nested NFA or a state data,
-- depending on whether we have a simpleType or complexType
function Simple_Type_Data
(Iter : active_state_iterator) return state_data;
-- return the simpleType data for the current state. This is either
-- queries from the current state itself, or from its superstate if
-- we are currently on the first state of the nested NFA.
----------------------
-- Simple_Type_Data --
----------------------
function Simple_Type_Data
(Iter : active_state_iterator) return state_data
is
S : constant state := Current (H.Matcher, Iter);
begin
if Has_Parent (Iter)
and then
Get_Start_State
(NFA.Get_Nested (Current (H.Matcher, Parent (Iter)))) =
S
then
return Current_Data (H.Matcher, Parent (Iter));
else
return Current_Data (H.Matcher, Iter);
end if;
end Simple_Type_Data;
-------------------
-- Replace_State --
-------------------
procedure Replace_State
(Check_Substitution : Boolean;
Nested_Start : state;
Simple : type_index)
is
S : state := No_State;
Data : state_data;
Iter : active_state_iterator :=
For_Each_Active_State
(H.Matcher,
Ignore_If_Default => True,
Ignore_If_Nested => True);
Internal_New_Nested : state := Nested_Start;
begin
loop
S := Current (H.Matcher, Iter);
exit when S = No_State;
Data := Current_Data (H.Matcher, Iter);
if Check_Substitution then
Check_Substitution_Group_OK
(H,
Simple,
Data.Simple,
Loc => H.Current_Location,
Element_Block => Simple_Type_Data (Iter).Block);
end if;
if Nested_Start = No_State then
-- Need to modify the nested NFA too: if we replaced a
-- complexType ("anyType" for instance) with a simple type,
-- we should no longer accept any element.
-- However, if we simply disable all states in the nested
-- NFA, that doesn't work either, since we will not accept
-- the "close element" for the simpleType. But we cannot
-- modify the NFA either, which should remain static.
if Debug then
Debug_Output
("Override state data" &
Current (H.Matcher, Iter)'img &
" to type" &
Simple'img);
end if;
Override_Data
(H.Matcher,
Iter,
state_data'
(Simple => Simple,
Nillable => Data.Nillable,
Fixed => Data.Fixed,
Default => Data.Default,
Block => Data.Block));
Internal_New_Nested := NFA.Simple_Nested;
if Debug then
Debug_Output
("Will replace nested complexType, to accept ");
end if;
end if;
if Internal_New_Nested /= No_State then
-- If we are on the first state of the parent, that means
-- we just entered the parent (which is the element having
-- the xsi:type). So we substitute the nested NFA *for the
-- parent*.
if Has_Parent (Iter) then
if Get_Start_State
(NFA.Get_Nested (Current (H.Matcher, Parent (Iter)))) =
S
then
if Debug then
Debug_Output ("Replacing nested NFA");
end if;
Replace_State (H.Matcher, Iter, Internal_New_Nested);
end if;
end if;
end if;
Next (H.Matcher, Iter);
end loop;
if Debug then
Print (H.Matcher, dump_compact, "After substitution:");
end if;
end Replace_State;
---------------------------------
-- Compute_Type_From_Attribute --
---------------------------------
procedure Compute_Type_From_Attribute
(Result_Index : out type_index;
Result : out type_descr_access)
is
Xsi_Type_Index : constant Integer :=
Get_Index (Atts, H.XML_Instance_URI, H.Typ);
TRef : global_reference;
begin
if Xsi_Type_Index = -1 then
Result_Index := No_Type_Index;
Result := null;
else
declare
Qname : constant byte_sequence :=
Ada.Strings.Fixed.Trim
(Get (Get_Value (Atts, Xsi_Type_Index)).all,
Ada.Strings.Both);
Separator : constant Integer := Split_Qname (Qname);
Prefix : symbol;
NS : xml_ns;
Typ : qualified_name;
begin
Prefix :=
Find_Symbol (H.all, Qname (Qname'first .. Separator - 1));
Get_Namespace_From_Prefix (H.all, Prefix, NS);
Typ :=
(NS => Get_URI (NS),
Local =>
Find_Symbol (H.all, Qname (Separator + 1 .. Qname'last)));
if Debug then
Debug_Output
("Getting element definition from type attribute: " &
To_QName (Typ));
end if;
TRef :=
Reference_HTables.Get
(Get_References (H.Grammar).all,
(Typ, ref_type));
if TRef = No_Global_Reference then
Validation_Error (H, "Unknown type " & To_QName (Typ));
end if;
Result_Index := TRef.Typ;
Result := type_descr_access (Get_Type_Descr (NFA, TRef.Typ));
Replace_State
(Check_Substitution => True,
Nested_Start => Result.Complex_Content,
Simple => TRef.Typ);
end;
end if;
end Compute_Type_From_Attribute;
Success : Boolean;
Nil_Index : Integer := -1;
Nillable : Boolean := False;
S : state;
Through_Any : Boolean;
Through_Process : process_contents_type;
TRef : global_reference;
Xsi_Descr : type_descr_access;
Xsi_Index : type_index;
Had_Matcher : constant Boolean := Is_Initialized (H.Matcher);
Element_QName : constant qualified_name :=
(NS => Get_URI (Get_NS (Elem)), Local => Get_Local_Name (Elem));
begin
if Debug then
Output_Seen
("Start_Element: " &
To_QName (Element_QName) &
" " &
To_String (H.Current_Location));
end if;
-- We should get the location of the enclosing element
Validate_Current_Characters (H, Loc => Start_Tag_Location (Elem));
-- Get the name of the grammar to use from the element's attributes
if No_Index /= -1 then
Parse_Grammar
(H,
URI => Empty_String,
Xsd_File => Get_Value (Atts, No_Index),
Do_Create_NFA => True);
end if;
if Location_Index /= -1 then
Parse_Grammars
(H,
Get_Value (Atts, Location_Index),
Do_Create_NFA => True);
end if;
-- If we have an inline schema, we must check that the target NS
-- is not used yet
if Element_QName = (NS => H.XML_Schema_URI, Local => H.S_Schema)
and then Had_Matcher
then
-- ??? Would need to include the contents into the NFA
-- ??? And check that no element from the same namespace was seen
Validation_Error
(H,
"Inline schema not supported",
Except => XML_Not_Implemented'identity);
end if;
if H.Grammar = No_Grammar then
return; -- Always valid, since we have no grammar anyway
end if;
-- Create the NFA matcher now if not done yet. This has to be done after
-- we have seen the toplevel element, which might result in parsing
-- additional grammars, and finding the target NS
if not Had_Matcher then
if Debug then
Debug_Output ("Creating NFA matcher");
end if;
H.Matcher.Start_Match
(On => Get_NFA (H.Grammar), Start_At => Start_State);
end if;
Do_Match
(Matcher => H.Matcher,
Sym => (Closing => False, Name => Element_QName),
Success => Success,
Through_Any => Through_Any,
Through_Process => Through_Process);
if Debug then
Print (H.Matcher, dump_compact, "After: ");
end if;
if not Had_Matcher and not Success then
-- Seeing the toplevel is never incorrect. We just need to find
-- out what its type would be, and use this for the matcher
declare
Descr : type_descr_access;
Index : type_index;
begin
Compute_Type_From_Attribute (Index, Descr);
if Descr = null then
Validation_Error
(H,
"No type found for " & To_QName (Element_QName));
elsif Descr.Complex_Content /= No_State then
H.Matcher.Start_Match
(On => Get_NFA (H.Grammar), Start_At => Descr.Complex_Content);
else
-- Just expect a "close". The current active state, however,
-- ends up with no state data, and we need to set it to the
-- appropriate simpleType. Can't use Replace_State for this.
H.Matcher.Start_Match
(Get_NFA (H.Grammar), Start_At => NFA.Simple_Nested);
declare
Iter : constant active_state_iterator :=
For_Each_Active_State
(H.Matcher,
Ignore_If_Default => False,
Ignore_If_Nested => True);
Data : state_data;
begin
Data := Current_Data (H.Matcher, Iter);
Override_Data
(H.Matcher,
Iter,
state_data'
(Simple => Index,
Nillable => Data.Nillable,
Fixed => Data.Fixed,
Default => Data.Default,
Block => Data.Block));
end;
end if;
end;
elsif not Success then
Validation_Error
(H,
"Unexpected element """ &
To_QName (Element_QName) &
""": expecting """ &
Expected (H.Matcher) &
'"');
end if;
-- If we have a xsi:type attribute, modify the NFA to use that type
Compute_Type_From_Attribute (Xsi_Index, Xsi_Descr);
-- If the element matched a , we might have to look it up to get
-- its type. However, if a type was given through xsi:type, this is
-- not needed since we already have a type.
if Through_Any and then Xsi_Descr = null then
case Through_Process is
when process_skip =>
-- Need to lookup the element to see whether it is nillable.
-- Apparently, this aspect must be checked.
-- Apart from that, this case is already handled in the NFA,
-- and the state is setup as ur-Type
TRef :=
Reference_HTables.Get
(Get_References (H.Grammar).all,
(Element_QName, ref_element));
if TRef /= No_Global_Reference then
Nillable := NFA.Get_Data (TRef.Element).Nillable;
if Debug then
Debug_Output
("Getting nillable status from schema" &
" even though we are in a ");
end if;
end if;
when process_lax =>
TRef :=
Reference_HTables.Get
(Get_References (H.Grammar).all,
(Element_QName, ref_element));
when process_strict =>
-- Find the definition for this element, if possible
TRef :=
Reference_HTables.Get
(Get_References (H.Grammar).all,
(Element_QName, ref_element));
if TRef = No_Global_Reference then
Validation_Error
(H,
"No definition found for " & To_QName (Element_QName));
end if;
end case;
if Through_Process /= process_skip
and then TRef /= No_Global_Reference
then
-- Replace the current most nested state in the machine with the
-- new type
if Debug then
Debug_Output
("Found valid declaration for " & To_QName (Element_QName));
end if;
Replace_State
(Check_Substitution => False,
Nested_Start => Get_Start_State (NFA.Get_Nested (TRef.Element)),
Simple => NFA.Get_Data (TRef.Element).Simple);
end if;
else
Through_Process := process_strict;
end if;
-- Validate the attributes
declare
Iter : active_state_iterator :=
For_Each_Active_State
(H.Matcher,
Ignore_If_Nested => True,
Ignore_If_Default => True);
Data : state_data;
Fixed : symbol := No_Symbol;
begin
loop
S := Current (H.Matcher, Iter);
exit when S = No_State;
-- The list of valid attributes is attached to the type, that is
-- to the nested NFA.
Data := Simple_Type_Data (Iter);
if Fixed = No_Symbol then
Fixed := Data.Fixed;
end if;
if Debug then
Debug_Output
("Checking attributes for state" &
S'img &
" type_index=" &
Data.Simple'img);
end if;
Nillable := Nillable or Data.Nillable;
-- otherwise with have a type
if Data.Simple /= No_Type_Index then
-- Check whether the actual type is abstract. This cannot be
-- checked when the grammar is created because of
-- substitutionGroup and xsi:type
declare
Descr : constant access type_descr :=
NFA.Get_Type_Descr (Data.Simple);
begin
if Descr.Is_Abstract then
if Descr.Name /= No_Qualified_Name then
Validation_Error
(H,
"Type " & To_QName (Descr.Name) & " is abstract");
else
Validation_Error (H, "Type is abstract");
end if;
end if;
Validate_Attributes
(Get_NFA (H.Grammar),
Descr,
H,
Atts,
Is_Nil => Nil_Index);
end;
else
if Debug then
Debug_Output ("A , all attributes are valid");
end if;
Nil_Index := Get_Index (Atts, H.XML_Instance_URI, H.Nil);
end if;
Next (H.Matcher, Iter);
end loop;
if Through_Process = process_skip then
-- In this case, we do not want to check the contents. Even if
-- xsi:nil="true" was specified, we still need to accept when
-- contents was provided.
H.Is_Nil := False;
else
if Nil_Index /= -1 then
if not Nillable then
Validation_Error (H, "Element cannot be nil");
end if;
H.Is_Nil := Get_Value_As_Boolean (Atts, Nil_Index);
else
H.Is_Nil := False;
end if;
if H.Is_Nil then
if Fixed /= No_Symbol then
Validation_Error
(H,
"Element cannot be nilled because" &
" a fixed value is defined for it");
end if;
if Debug then
Debug_Output
("Element is nil, should we replace nested NFA");
end if;
Replace_State
(Check_Substitution => False,
Nested_Start => NFA.Simple_Nested,
Simple => Data.Simple);
end if;
end if;
end;
end Hook_Start_Element;
----------------------
-- Hook_End_Element --
----------------------
procedure Hook_End_Element
(Handler : access sax_reader'class;
Elem : element_access)
is
H : constant validating_reader_access :=
validating_reader_access (Handler);
Success : Boolean;
Through_Any : Boolean;
Through_Process : process_contents_type;
begin
if Debug then
Output_Seen
("End_Element: " &
To_QName (Elem) &
" " &
To_String (H.Current_Location));
end if;
Validate_Current_Characters (H, Loc => Start_Tag_End_Location (Elem));
Do_Match
(H.Matcher,
Sym =>
(Closing => True,
Name =>
(NS => Get_URI (Get_NS (Elem)), Local => Get_Local_Name (Elem))),
Success => Success,
Through_Any => Through_Any,
Through_Process => Through_Process);
if Debug then
Print (H.Matcher, dump_compact, "After end element: ");
end if;
if not Success then
Validation_Error
(H,
"Unexpected end of sequence, expecting """ &
Expected (H.Matcher) &
'"');
end if;
-- We know the parent wasn't nil, since the child was accepted
H.Is_Nil := False;
end Hook_End_Element;
-------------------------
-- Internal_Characters --
-------------------------
procedure Internal_Characters
(Handler : access validating_reader'class;
Ch : Unicode.CES.byte_sequence)
is
Tmp : byte_sequence_access;
Max : constant Natural := Handler.Characters_Count + Ch'length;
begin
-- Preserve the characters, but avoid allocating every time. We
-- therefore reuse the buffer as much as possible, and only extend it
-- when needed.
if Handler.Characters = null then
Handler.Characters_Count := Ch'length;
Handler.Characters := new String (1 .. Ch'length);
Handler.Characters.all := Ch;
elsif Max <= Handler.Characters'last then
Handler.Characters (Handler.Characters_Count + 1 .. Max) := Ch;
Handler.Characters_Count := Max;
else
Tmp := new String (1 .. Max);
Tmp (1 .. Handler.Characters_Count) :=
Handler.Characters (1 .. Handler.Characters_Count);
Tmp (Handler.Characters_Count + 1 .. Max) := Ch;
Handler.Characters_Count := Max;
Free (Handler.Characters);
Handler.Characters := Tmp;
end if;
end Internal_Characters;
---------------------
-- Hook_Characters --
---------------------
procedure Hook_Characters
(Handler : access sax_reader'class;
Ch : Unicode.CES.byte_sequence)
is
begin
Internal_Characters (validating_reader_access (Handler), Ch);
end Hook_Characters;
-------------------------------
-- Hook_Ignorable_Whitespace --
-------------------------------
procedure Hook_Ignorable_Whitespace
(Handler : access sax_reader'class;
Ch : Unicode.CES.byte_sequence)
is
H : constant validating_reader_access :=
validating_reader_access (Handler);
NFA : constant schema_nfa_access := Get_NFA (H.Grammar);
S : state;
Descr : access type_descr;
Iter : active_state_iterator :=
For_Each_Active_State
(H.Matcher,
Ignore_If_Nested => True,
Ignore_If_Default => True);
begin
loop
S := Current (H.Matcher, Iter);
exit when S = No_State;
Descr := Get_Type_Descr (NFA, Current_Data (H.Matcher, Iter).Simple);
if Descr.Simple_Content /= No_Simple_Type_Index
or else Descr.Mixed
then
Internal_Characters (H, Ch);
return;
end if;
Next (H.Matcher, Iter);
end loop;
end Hook_Ignorable_Whitespace;
-----------
-- Reset --
-----------
procedure Reset (Parser : in out validating_reader) is
begin
-- Save current location, for retrieval by Get_Error_Message
Free (Parser.Id_Table);
Free (Parser.Matcher);
Free (Parser.Characters);
Parser.Characters_Count := 0;
end Reset;
-----------
-- Parse --
-----------
overriding procedure Parse
(Parser : in out validating_reader;
Input : in out Input_Sources.input_source'class)
is
begin
if Debug then
Output_Action
("Parsing XML file " & Input_Sources.Get_System_Id (Input));
end if;
Initialize_Symbols (Parser);
Initialize_Grammar (Parser);
if Get_Feature (Parser, Schema_Validation_Feature) then
Set_Hooks
(Parser,
Start_Element => Hook_Start_Element'access,
End_Element => Hook_End_Element'access,
Characters => Hook_Characters'access,
Whitespace => Hook_Ignorable_Whitespace'access,
Notation_Decl => Hook_Notation_Decl'access);
Free (Parser.Matcher);
else
Set_Hooks
(Parser,
Start_Element => null,
End_Element => null,
Characters => null,
Whitespace => null,
Doc_Locator => null);
end if;
-- Not a dispatching call
Parse (Schema.Validators.abstract_validation_reader (Parser), Input);
if not In_Final (Parser.Matcher) then
Validation_Error
(Parser'access,
"Unexpected end of file: expecting " & Expected (Parser.Matcher));
end if;
Reset (Parser);
exception
when others =>
Reset (Parser);
raise;
end Parse;
-------------------------------
-- Get_Namespace_From_Prefix --
-------------------------------
procedure Get_Namespace_From_Prefix
(Handler : in out validating_reader;
Prefix : symbol;
NS : out Sax.Utils.xml_ns)
is
begin
Find_NS (Parser => Handler, Prefix => Prefix, NS => NS);
if Get_URI (NS) = Empty_String then
NS := No_XML_NS;
end if;
end Get_Namespace_From_Prefix;
----------
-- Free --
----------
procedure Free (Reader : in out validating_reader_access) is
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(validating_reader'class,
validating_reader_access);
begin
if Reader /= null then
Free (Reader.all);
Unchecked_Free (Reader);
end if;
end Free;
----------
-- Free --
----------
overriding procedure Free (Reader : in out validating_reader) is
begin
Free (Schema.Validators.abstract_validation_reader (Reader));
end Free;
end Schema.Readers;