------------------------------------------------------------------------------
-- XML/Ada - An XML suite for Ada95 --
-- --
-- Copyright (C) 2004-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 Ada.Exceptions; use Ada.Exceptions;
with GNAT.Task_Lock; use GNAT.Task_Lock;
with Unicode; use Unicode;
with Unicode.CES; use Unicode.CES;
with Sax.Encodings; use Sax.Encodings;
with Sax.Exceptions; use Sax.Exceptions;
with Sax.Locators; use Sax.Locators;
with Sax.Symbols; use Sax.Symbols;
with Sax.Utils; use Sax.Utils;
with Schema.Simple_Types; use Schema.Simple_Types;
with Schema.Readers; use Schema.Readers;
with Ada.Unchecked_Deallocation;
with Ada.IO_Exceptions;
with Input_Sources.File; use Input_Sources.File;
package body Schema.Schema_Readers is
use Schema_State_Machines, Schema_State_Machines_PP;
use Type_Tables, Element_HTables, Group_HTables;
use AttrGroup_HTables, Reference_HTables, Attribute_HTables;
default_contexts : constant := 30;
-- Default number of nested levels in a schema.
-- If the actual schema uses more, we will simply reallocate some memory.
max_max_occurs : constant := 300;
-- Maximum value for maxOccurs.
-- Higher values result in an explosion in the number of states in the NFA,
-- so should not be used for now.
procedure Push_Context
(Handler : access schema_reader'class;
Ctx : context);
-- Add a new context to the list
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(attr_array,
attr_array_access);
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(context_array,
context_array_access);
procedure Free (Shared : in out xsd_data_access);
-- Free [Shared] and its htables
procedure Free (Self : in out type_details_access);
-- Free [Self], [Self.Next] and so on
procedure Create_NFA (Parser : access schema_reader);
-- Create the state machine from the registered elements and types
-- Return the start state for the current grammar (we do not use the
-- NFA's default start state, since each grammar has its own list of valid
-- toplevel elements.
function To_String (Final : final_status) return String;
function In_Redefine_Context (Handler : schema_reader'class) return Boolean;
-- Whether we are currently processing a tag
function Resolve_QName
(Handler : access schema_reader'class;
QName : Sax.Symbols.symbol;
NS_If_Empty : Sax.Symbols.symbol := Empty_String;
Loc : location) return qualified_name;
-- Resolve namespaces for QName.
-- [NS_If_Empty] is used if no namespace was found for the element. This
-- will often be the target namespace of the schema.
procedure Internal_Parse
(Parser : in out schema_reader;
Input : in out Input_Sources.input_source'class;
Default_Namespace : symbol;
Do_Create_NFA : Boolean;
Do_Initialize_Shared : Boolean);
-- Internal version of [Parse], which allows reuse of the shared data.
-- This is useful while parsing a XSD
procedure Insert_In_Type
(Handler : access schema_reader'class;
Element : in out type_details_access);
-- Insert Element in the type definition in [Handler.Contexts].
-- If there is an error inserting the element, an exception is raised and
-- [Element] is freed.
procedure Prepare_Type
(Handler : access schema_reader'class;
Atts : sax_attribute_list;
Is_Simple : Boolean);
-- Prepare a type context (simpleType or complexType)
procedure Add_Type_Member
(Handler : access schema_reader'class;
List : in out type_member_array;
Member : type_member;
Loc : location);
-- Add a new item in [List], and raise an exception if [List] is full.
procedure Compute_Blocks
(Atts : sax_attribute_list;
Handler : access schema_reader'class;
Blocks : out block_status;
Is_Set : out Boolean;
Index : Integer);
-- Compute the list of blocked elements from the attribute "block".
function Compute_Final
(Atts : sax_attribute_list;
Handler : access schema_reader'class;
Index : Integer) return final_status;
-- Compute the list of final attributes from value. Value is a list similar
-- to what is used for the "final" attribute of elements in a schema
function Compute_Form
(Atts : sax_attribute_list;
Handler : access schema_reader'class;
Index : Integer) return form_type;
-- Parse the given attribute
procedure Append (List : in out attr_array_access; Attr : attr_descr);
-- Add an attribute to the list
procedure Insert_Attribute
(Handler : access schema_reader'class;
In_Context : Natural;
Attribute : attr_descr);
-- Insert attribute at the right location in In_Context.
function Process_Contents_From_Atts
(Handler : access schema_reader'class;
Atts : sax_attribute_list;
Index : Integer) return process_contents_type;
-- Get the value of processContents from the attributes
procedure Create_Element
(Handler : access schema_reader'class;
Atts : sax_attribute_list);
procedure Create_Notation
(Handler : access schema_reader'class;
Atts : sax_attribute_list);
procedure Create_Complex_Type
(Handler : access schema_reader'class;
Atts : sax_attribute_list);
procedure Create_Simple_Type
(Handler : access schema_reader'class;
Atts : sax_attribute_list);
procedure Create_Restriction
(Handler : access schema_reader'class;
Atts : sax_attribute_list);
procedure Create_All
(Handler : access schema_reader'class;
Atts : sax_attribute_list);
procedure Create_Sequence
(Handler : access schema_reader'class;
Atts : sax_attribute_list);
procedure Create_Attribute
(Handler : access schema_reader'class;
Atts : sax_attribute_list);
procedure Create_Schema
(Handler : access schema_reader'class;
Atts : sax_attribute_list);
procedure Create_Extension
(Handler : access schema_reader'class;
Atts : sax_attribute_list);
procedure Create_List
(Handler : access schema_reader'class;
Atts : sax_attribute_list);
procedure Create_Union
(Handler : access schema_reader'class;
Atts : sax_attribute_list);
procedure Create_Choice
(Handler : access schema_reader'class;
Atts : sax_attribute_list);
procedure Create_Redefine
(Handler : access schema_reader'class;
Atts : sax_attribute_list);
procedure Create_Include
(Handler : access schema_reader'class;
Atts : sax_attribute_list);
procedure Create_Group
(Handler : access schema_reader'class;
Atts : sax_attribute_list);
procedure Create_Attribute_Group
(Handler : access schema_reader'class;
Atts : sax_attribute_list);
procedure Create_Any
(Handler : access schema_reader'class;
Atts : sax_attribute_list);
procedure Create_Import
(Handler : access schema_reader'class;
Atts : sax_attribute_list);
procedure Create_Any_Attribute
(Handler : access schema_reader'class;
Atts : sax_attribute_list);
-- Create a new context for a specific tag:
-- resp. , , , , ,
-- , , , , , ,
-- , , , , ,
procedure Finish_Element (Handler : access schema_reader'class);
procedure Finish_Complex_Type (Handler : access schema_reader'class);
procedure Finish_Simple_Type (Handler : access schema_reader'class);
procedure Finish_Restriction (Handler : access schema_reader'class);
procedure Finish_Extension (Handler : access schema_reader'class);
procedure Finish_Attribute (Handler : access schema_reader'class);
procedure Finish_Union (Handler : access schema_reader'class);
procedure Finish_List (Handler : access schema_reader'class);
procedure Finish_Group (Handler : access schema_reader'class);
procedure Finish_Attribute_Group (Handler : access schema_reader'class);
-- Finish the handling of various tags:
-- resp. , , , , ,
-- , , , ,
procedure Get_Occurs
(Handler : access schema_reader'class;
Atts : sax_attribute_list;
Min_Occurs, Max_Occurs : out occurrences);
-- Get the "minOccurs" and "maxOccurs" attributes
---------------
-- To_String --
---------------
function To_String (Final : final_status) return String is
begin
return "restr=" &
Final (final_restriction)'img &
" ext=" &
Final (final_extension)'img &
" union=" &
Final (final_union)'img &
" list=" &
Final (final_list)'img;
end To_String;
-------------------------
-- In_Redefine_Context --
-------------------------
function In_Redefine_Context
(Handler : schema_reader'class) return Boolean
is
begin
for J in 1 .. Handler.Contexts_Last loop
if Handler.Contexts (J).Typ = context_redefine then
return True;
end if;
end loop;
return False;
end In_Redefine_Context;
----------------
-- Create_NFA --
----------------
procedure Create_NFA (Parser : access schema_reader) is
NFA : constant schema_nfa_access := Get_NFA (Get_Grammar (Parser.all));
Ref : constant reference_htable :=
Get_References (Get_Grammar (Parser.all));
Any_Simple_Type_Index : constant type_index :=
Get
(Ref.all,
((Local => Parser.Any_Simple_Type, NS => Parser.XML_Schema_URI),
ref_type))
.Typ;
Shared : xsd_data_access renames Parser.Shared;
package Type_HTables is new GNAT.Dynamic_HTables.Simple_HTable
(Header_Num => header_num,
Element => internal_type_index,
No_Element => No_Internal_Type_Index,
Key => qualified_name,
Hash => Hash,
Equal => "=");
use Type_HTables;
Types : Type_HTables.instance;
procedure Process_Global_Element
(Info : in out element_descr;
Start_At : state);
procedure Process_Type (Info : in out internal_type_descr);
procedure Process_Details
(In_Type : access type_descr;
Details : type_details_access;
Start, From : state;
Nested_End : out state;
Mask : out visited_all_children);
-- [Start] is the start of the current nested.
-- [Mask] is the mask to apply to a closing transition out of a
-- node. It is only set if Details.Kind = Type_All.
procedure Create_Element_State
(Info : in out element_descr;
Start, From : state;
Global : Boolean;
S1, S2 : out state;
Trans_Kind : transition_kind;
All_Child_Index : Integer := 0);
-- Create (and decorate) the nodes [S1]..[S2] corresponding to an
-- . A link is created [From]->[S1].
-- [Start] is the first element of the current nested machine.
-- Trans_Kind is the kind of the first transition, from From to the
-- first created state. This transition is associated with the name of
-- the element.
-- All_Child_Index indicates the index of the created transition in all
-- the children of an node. This is used to memory efficiently
-- which transitions have already been visited for this .
type type_descr_access is access all type_descr;
procedure Create_Simple_Type
(J : internal_type_index;
Descr : out type_descr_access;
Index : out type_index);
-- Create the new simple type info at index [J]
procedure Get_Type_Descr
(Name : qualified_name;
Loc : location;
NFA_Type : out type_index;
Internal_Type : out internal_type_index);
-- Lookup the type information in the grammar. This type information
-- could be in several places:
-- - Either defined in the current XSD and its : in that case,
-- [Internal_Type] will be set.
-- - Or in a previously loaded XSD. In that case, it is set to
-- [No_Internal_Type_Index]
procedure Lookup_Simple_Type
(Name : qualified_name;
Loc : location;
Descr : out type_descr_access;
Index : out type_index);
-- Search for the simpleType [Name]
procedure Add_Attributes
(List : in out attributes_list;
Attrs : attr_array_access;
Processed_Groups : in out AttrGroup_HTables.instance;
As_Restriction : Boolean;
Had_Any : in out Boolean);
-- Create List from the list of attributes or attribute groups in
-- [Attrs]. [Had_Any] is set to true if a was
-- encountered. The caller should first set it to False.
procedure Check_Unique_Particle_Attribution
(Details : type_details_access);
-- Check that all elements in the content model are unique (we must not
-- have two elements that compete with each other).
procedure Create_Global_Attributes (Attr : internal_attribute_descr);
-- Register a global attribute.
procedure Resolve_Attribute_Type
(Attr : in out internal_attribute_descr;
Loc : Sax.Locators.location);
-- Set [Attr.Descr.Simple_Type] to the appropriate value, after looking
-- up the type
--------------------------
-- Create_Element_State --
--------------------------
procedure Create_Element_State
(Info : in out element_descr;
Start, From : state;
Global : Boolean;
S1, S2 : out state;
Trans_Kind : transition_kind;
All_Child_Index : Integer := 0)
is
pragma unreferenced (Start);
Real : element_descr;
Trans : transition_descr;
TRef : global_reference := No_Global_Reference;
S : state := No_State;
function Build_Trans
(N : qualified_name;
F : form_type) return transition_descr;
function Build_Trans
(N : qualified_name;
F : form_type) return transition_descr
is
begin
case Trans_Kind is
when transition_symbol =>
return (transition_symbol, N, F, All_Child_Index => 0);
when transition_symbol_from_all =>
return
(transition_symbol_from_all,
N,
F,
All_Child_Index => All_Child_Index);
when others =>
raise Program_Error with "Invalid transition type";
end case;
end Build_Trans;
begin
if Info.Is_Abstract then
-- ??? Should use the substitutionGroup elements, instead
S1 := No_State;
S2 := No_State;
Validation_Error
(Parser,
"Abstract elements not handled yet",
Except => XML_Not_Implemented'identity);
return;
end if;
S1 := NFA.Add_State;
Info.S := S1;
if Debug then
Debug_Output
("Create_Element_State S1 for element " &
To_QName (Info.Name) &
To_QName (Info.Ref) &
S1'img);
end if;
-- Resolve element references
if Info.Name = No_Qualified_Name then
Real := Get (Shared.Global_Elements, Info.Ref);
if Real = No_Element_Descr then
TRef := Get (Ref.all, (Info.Ref, ref_element));
if TRef = No_Global_Reference then
Validation_Error
(Parser,
"Unknown refed element " & To_QName (Info.Ref),
Info.Loc);
end if;
S := TRef.Element;
Trans := Build_Trans (Info.Ref, Info.Form);
else
Trans := Build_Trans (Real.Name, Info.Form);
S := Real.S;
end if;
if S /= No_State then
if Debug then
Debug_Output ("copying data from" & S'img & " to" & S1'img);
end if;
NFA.Get_Data (S1).all := NFA.Get_Data (S).all;
NFA.Set_Nested (S1, NFA.Get_Nested (S));
end if;
else
declare
NFA_Type : type_index;
Internal_Type : internal_type_index;
Data : access state_data;
begin
Real := Info;
Trans := Build_Trans (Real.Name, Info.Form);
-- Create nested NFA for the type, if needed
if Real.Typ /= No_Qualified_Name then
Get_Type_Descr (Real.Typ, Info.Loc, NFA_Type, Internal_Type);
elsif Real.Local_Type /= No_Internal_Type_Index then
Internal_Type := Real.Local_Type;
NFA_Type := Shared.Types.Table (Internal_Type).In_NFA;
else
-- "" (3.3.2.1 {type definition})
NFA_Type := No_Type_Index;
end if;
if Info.Substitution_Group /= No_Qualified_Name then
-- ??? Handling of substitutionGroup: the type of the
-- element is the same as the head unless overridden.
Validation_Error
(Parser,
"substitutionGroup not supported",
Except => XML_Not_Implemented'identity);
end if;
Data := NFA.Get_Data (S1);
if NFA_Type /= No_Type_Index then
Data.all :=
state_data'
(Simple => NFA_Type,
Fixed => No_Symbol, -- See below
Default => Info.Default,
Nillable => Info.Nillable,
Block => Info.Block);
NFA.Set_Nested
(S1, NFA.Create_Nested
(Get_Type_Descr (NFA, NFA_Type).Complex_Content));
else
NFA.Set_Nested (S1, NFA.Ur_Type (process_lax));
Data.Default := Info.Default;
Data.Block := Info.Block;
Data.Nillable := Info.Nillable;
end if;
-- Check that the fixed value is valid
if Info.Fixed /= No_Symbol
and then NFA.Get_Data (S1).Simple /= No_Type_Index
then
Normalize_And_Validate
(Parser => Parser,
Simple =>
Get_Type_Descr (NFA, NFA.Get_Data (S1).Simple)
.Simple_Content,
Fixed => Info.Fixed,
Loc => Info.Loc);
end if;
Data.Fixed := Info.Fixed;
end;
end if;
-- Link with previous element
NFA.Add_Transition (From, S1, Trans);
S2 := NFA.Add_State;
if NFA.Get_Nested (S1) /= No_Nested then
NFA.On_Empty_Nested_Exit (S1, S2); -- a complexType
else
NFA.Add_Transition (S1, S2, (Kind => transition_close));
end if;
-- Save this element for later reuse in other namespaces
if Global then
if Debug then
Debug_Output ("Global elem: " & To_QName (Real.Name));
end if;
Set
(Ref.all,
(Kind => ref_element, Name => Real.Name, Element => S1));
end if;
end Create_Element_State;
----------------------------
-- Process_Global_Element --
----------------------------
procedure Process_Global_Element
(Info : in out element_descr;
Start_At : state)
is
S1, S2 : state;
begin
Create_Element_State
(Info,
Start_At,
Start_At,
True,
S1,
S2,
transition_symbol);
if S2 /= No_State then
NFA.Add_Empty_Transition (S2, Final_State);
end if;
end Process_Global_Element;
--------------------
-- Get_Type_Descr --
--------------------
procedure Get_Type_Descr
(Name : qualified_name;
Loc : location;
NFA_Type : out type_index;
Internal_Type : out internal_type_index)
is
TRef : global_reference;
begin
Internal_Type := Get (Types, Name);
if Internal_Type = No_Internal_Type_Index then
TRef := Get (Ref.all, (Name, ref_type));
if TRef = No_Global_Reference then
Validation_Error
(Parser,
"Unknown type " & To_QName (Name),
Loc);
end if;
NFA_Type := TRef.Typ;
else
NFA_Type := Shared.Types.Table (Internal_Type).In_NFA;
end if;
if Name = (NS => Parser.XML_Schema_URI, Local => Parser.IDREF)
or else Name = (NS => Parser.XML_Schema_URI, Local => Parser.IDREFS)
then
Validation_Error
(Parser,
"Unsupported type IDREF and IDREFS",
Loc => Loc,
Except => XML_Not_Implemented'identity);
end if;
end Get_Type_Descr;
------------------------
-- Lookup_Simple_Type --
------------------------
procedure Lookup_Simple_Type
(Name : qualified_name;
Loc : location;
Descr : out type_descr_access;
Index : out type_index)
is
TRef : global_reference;
Internal : internal_type_index;
begin
TRef := Get (Ref.all, (Name, ref_type));
if TRef = No_Global_Reference then
Validation_Error (Parser, "Unknown type " & To_QName (Name), Loc);
end if;
Index := TRef.Typ;
Descr := type_descr_access (Get_Type_Descr (NFA, Index));
if Descr.Simple_Content = No_Simple_Type_Index then
if Debug then
Debug_Output
("Lookup_Simple_Type: generate " &
To_QName (Name) &
" early");
end if;
Internal := Get (Types, Name);
if Internal = No_Internal_Type_Index then
Validation_Error
(Parser,
"Type is not a simple type: " & To_QName (Name),
Loc);
end if;
Create_Simple_Type (Internal, Descr, Index);
end if;
end Lookup_Simple_Type;
---------------------------------------
-- Check_Unique_Particle_Attribution --
---------------------------------------
procedure Check_Unique_Particle_Attribution
(Details : type_details_access)
is
Duplicates : Element_HTables.instance;
-- Used to check for duplicate elements within a sequence or choice.
-- ??? Could use a htable of locations, so that we can point to the
-- two duplicate declarations.
T : type_details_access;
Elem : element_descr;
begin
case Details.Kind is
when type_sequence =>
T := Details.First_In_Seq;
when type_choice =>
T := Details.First_In_Choice;
when type_all =>
T := Details.First_In_All;
when others =>
raise Program_Error with "Internal error";
end case;
while T /= null loop
case T.Kind is
when type_element =>
if T.Element.Name /= No_Qualified_Name then
Elem := Element_HTables.Get (Duplicates, T.Element.Name);
if Elem /= No_Element_Descr then
-- It is always invalid to have an element with the
-- same name but with different types in the same
-- model, even if there is no ambiguity (for instance
-- in a sequence).
if Elem.Typ /= No_Qualified_Name
and then Elem.Typ /= T.Element.Typ
then
Validation_Error
(Parser,
"Multiple elements with name '" &
To_QName (T.Element.Name) &
"', with different types, appear in the model" &
" group",
Details.Loc);
end if;
-- In a or , we cannot have the same
-- element multiple times, since that would be
-- ambiguous.
if Details.Kind = type_choice
or else Details.Kind = type_all
then
Validation_Error
(Parser,
"'" &
To_QName (T.Element.Name) &
"' and '" &
To_QName (Elem.Name) &
"' violate the Unique" &
" Particle Attribution rule, creating an" &
" ambiguity for the validation",
Details.Loc);
end if;
else
Element_HTables.Set
(Duplicates,
T.Element.Name,
T.Element);
end if;
end if;
when type_group =>
null;
when others =>
-- ??? Should check, in particular for groups or nested
-- sequences (we can have a Sequence that contains choices)
null;
end case;
T := T.Next;
end loop;
Reset (Duplicates);
exception
when others =>
Reset (Duplicates);
raise;
end Check_Unique_Particle_Attribution;
---------------------
-- Process_Details --
---------------------
procedure Process_Details
(In_Type : access type_descr;
Details : type_details_access;
Start, From : state;
Nested_End : out state;
Mask : out visited_all_children)
is
S, S1 : state;
T : type_details_access;
Gr : group_descr;
begin
Nested_End := From;
Mask := 0;
if Details = null then
return;
end if;
Details.In_Process := True;
case Details.Kind is
when type_empty =>
null;
when type_sequence =>
Check_Unique_Particle_Attribution (Details);
S := From;
T := Details.First_In_Seq;
while T /= null loop
Process_Details (In_Type, T, Start, S, Nested_End, Mask);
S := Nested_End;
T := T.Next;
end loop;
when type_choice =>
Check_Unique_Particle_Attribution (Details);
T := Details.First_In_Choice;
Nested_End := NFA.Add_State;
while T /= null loop
Process_Details (In_Type, T, Start, From, S, Mask);
NFA.Add_Empty_Transition (S, Nested_End);
T := T.Next;
end loop;
when type_all =>
Check_Unique_Particle_Attribution (Details);
if Details.First_In_All /= null then
declare
Count : Natural := 0;
begin
Mask := 0;
T := Details.First_In_All;
while T /= null loop
pragma assert
(T.Kind = type_element,
"Children of must be simple elements");
-- If the element has maxOccurs=0, there is no need to
-- put it in the state machine.
if T.Max_Occurs.Value /= 0 then
Create_Element_State
(T.Element,
Start,
From,
False,
S1 => S1,
S2 => S,
Trans_Kind => transition_symbol_from_all,
All_Child_Index => Count);
if T.Min_Occurs.Value = 1 then
-- The child is mandatory
Mask := Mask or (2**Count);
end if;
Count := Count + 1;
-- All elements, after being processed, come back
-- to itself. The latter is in charge of
-- deciding, through the subprogram Match, which
-- transitions are valid in the current state.
NFA.Add_Empty_Transition (S, Start);
end if;
T := T.Next;
end loop;
-- The actual end of is through a conditional empty
-- transition controlled by Match.
Nested_End := NFA.Add_State;
NFA.Add_Empty_Transition (From, Nested_End);
end;
end if;
when type_element =>
Create_Element_State
(Details.Element,
Start,
From,
False,
S1,
Nested_End,
transition_symbol);
when type_group =>
Gr := Get (Parser.Shared.Global_Groups, Details.Group.Ref);
if Gr = No_Group_Descr then
Validation_Error
(Parser,
"No group """ & To_QName (Details.Group.Ref) & '"',
Details.Group.Loc);
elsif Gr.Details.In_Process then
Validation_Error
(Parser,
"Circular group reference for " &
To_QName (Details.Group.Ref),
Details.Group.Loc);
end if;
Process_Details
(In_Type,
Gr.Details,
Start,
From,
Nested_End,
Mask);
when type_extension =>
declare
NFA_Type : type_index; -- Attributes of the base type
Internal_Type : internal_type_index;
Base_Descr : access type_descr;
begin
Get_Type_Descr
(Name => Details.Extension.Base,
Loc => Details.Extension.Loc,
NFA_Type => NFA_Type,
Internal_Type => Internal_Type);
Base_Descr := Get_Type_Descr (NFA, NFA_Type);
if Base_Descr.Final (final_extension) then
Validation_Error
(Parser,
To_QName (Base_Descr.Name) &
" is final for extensions",
Details.Extension.Loc);
end if;
if Base_Descr.Simple_Content = No_Simple_Type_Index then
if Internal_Type /= No_Internal_Type_Index then
-- We have all the details, and just have to copy them
-- Details might be null, for instance for an
-- that just adds attributes
if Shared.Types.Table (Internal_Type).Details /= null
and then Shared.Types.Table (Internal_Type).Details
.In_Process
then
Validation_Error
(Parser,
"Circular inheritance of type " &
To_QName (Details.Extension.Base),
Details.Extension.Loc);
end if;
Process_Details
(In_Type,
Shared.Types.Table (Internal_Type).Details,
Start,
From,
S,
Mask);
else
-- ??? Should copy the nested NFA for TyS
Validation_Error
(Parser,
"Extension's base in a different file " &
To_QName (Details.Extension.Base),
Details.Extension.Loc,
XML_Not_Implemented'identity);
end if;
Process_Details
(In_Type,
Details.Extension.Details,
Start,
S,
Nested_End,
Mask);
else
-- ??? Should handle simple types
Nested_End := Start;
-- The test is correct. However, it makes
-- msData/particles/particlesZ031.xsd fails, because the
-- test is incorrect. The test pretends that the XSD is
-- valid, but later checkins in the testsuite have proven
-- it incorrect. The following Ada test would make the
-- test pass, but then
-- MS-Additional2006-07-15/addB036
-- fails
--
-- and then
-- (Internal_Type = No_Internal_Type_Index
-- or else Shared.Types.Table (Internal_Type).Is_Simple)
if not Details.Simple_Content then
Validation_Error
(Parser,
"base type specified in complexContent definition" &
" must be a complex type",
Details.Extension.Loc);
end if;
end if;
In_Type.Extension_Of := NFA_Type;
In_Type.Restriction_Of := No_Type_Index;
end;
when type_restriction =>
declare
Internal : internal_type_index;
NFA_Type : type_index; -- Attributes of the base type
Base_Descr : access type_descr;
begin
Get_Type_Descr
(Name => Details.Restriction.Base,
Loc => No_Location,
NFA_Type => NFA_Type,
Internal_Type => Internal);
Base_Descr := Get_Type_Descr (NFA, NFA_Type);
if Base_Descr.Final (final_restriction) then
Validation_Error
(Parser,
To_QName (Base_Descr.Name) &
" is final for restrictions",
Details.Restriction.Loc);
end if;
if Base_Descr.Simple_Content = No_Simple_Type_Index then
if Internal /= No_Internal_Type_Index
and then Shared.Types.Table (Internal).Details /= null
and then Shared.Types.Table (Internal).Details
.In_Process
then
Validation_Error
(Parser,
"Circular inheritance of type " &
To_QName (Details.Restriction.Base),
Details.Restriction.Loc);
end if;
Process_Details
(In_Type,
Details.Restriction.Details,
Start,
From,
Nested_End,
Mask);
else
-- ??? Should handle simple types
Nested_End := Start;
if not Details.Simple_Content_Restriction then
Validation_Error
(Parser,
"base type specified in complexContent definition" &
" must be a complex type",
Details.Restriction.Loc);
end if;
end if;
In_Type.Restriction_Of := NFA_Type;
In_Type.Extension_Of := No_Type_Index;
end;
when type_any =>
S := NFA.Add_State; -- ((Simple => 1, others => <>));
NFA.Set_Nested (S, Ur_Type (NFA, Details.Any.Process_Contents));
NFA.Add_Transition
(From, S,
(transition_any,
Combine
(Parser.Grammar,
No_Any_Descr,
Local_Process => Details.Any.Process_Contents,
Local => Details.Any.Namespaces,
As_Restriction => False,
Target_NS => Details.Any.Target_NS)));
Nested_End := NFA.Add_State;
NFA.On_Empty_Nested_Exit (S, Nested_End);
end case;
-- For elements, we can only have maxOccurs=1 and minOccurs=0
-- or 1. In the case of minOccurs=0, and since we use conditional
-- links there, we cannot create a direct empty transition from the
-- start state to the final state (since the
-- transition_close_from_all is on exit of that final state, and
-- thus would be *after* the new empty transition). So this case
-- is handled specially in Process_Type.
if Details.Kind /= type_all then
if Details.Max_Occurs.Unbounded then
Nested_End :=
NFA.Repeat
(From, Nested_End, Details.Min_Occurs.Value, Natural'last);
else
Nested_End :=
NFA.Repeat
(From, Nested_End, Details.Min_Occurs
.Value, Details.Max_Occurs
.Value);
end if;
end if;
Details.In_Process := False;
end Process_Details;
----------------------------
-- Resolve_Attribute_Type --
----------------------------
procedure Resolve_Attribute_Type
(Attr : in out internal_attribute_descr;
Loc : Sax.Locators.location)
is
TRef : global_reference;
NFA_Type : type_index; -- In NFA
begin
if Attr.Local_Type /= No_Internal_Type_Index then
NFA_Type := Shared.Types.Table (Attr.Local_Type).In_NFA;
Attr.Descr.Simple_Type :=
Get_Type_Descr (NFA, NFA_Type).Simple_Content;
elsif Attr.Typ = No_Qualified_Name then
-- ??? Type should be ur-type (3.2.2)
null;
else
TRef := Get (Ref.all, (Attr.Typ, ref_type));
if TRef = No_Global_Reference then
Validation_Error
(Parser,
"Unknown type: " & To_QName (Attr.Typ),
Loc);
else
Attr.Descr.Simple_Type :=
Get_Type_Descr (NFA, TRef.Typ).Simple_Content;
end if;
end if;
end Resolve_Attribute_Type;
--------------------
-- Add_Attributes --
--------------------
procedure Add_Attributes
(List : in out attributes_list;
Attrs : attr_array_access;
Processed_Groups : in out AttrGroup_HTables.instance;
As_Restriction : Boolean;
Had_Any : in out Boolean)
is
Gr : attrgroup_descr;
TRef : global_reference;
begin
if Attrs /= null then
for A in Attrs'range loop
case Attrs (A).Kind is
when kind_unset =>
null;
when kind_group =>
Gr := Get (Shared.Global_AttrGroups, Attrs (A).Group_Ref);
if Gr = No_AttrGroup_Descr then
Validation_Error
(Parser,
"Reference to undefined attributeGroup: " &
To_QName (Attrs (A).Group_Ref),
Attrs (A).Loc);
elsif Get (Processed_Groups, Gr.Name) /=
No_AttrGroup_Descr
then
Validation_Error
(Parser,
"attributeGroup """ &
To_QName (Attrs (A).Group_Ref) &
""" has circular reference",
Attrs (A).Loc);
else
Set (Processed_Groups, Gr.Name, Gr);
Add_Attributes
(List,
Gr.Attributes,
Processed_Groups,
As_Restriction,
Had_Any);
end if;
when kind_attribute =>
if Attrs (A).Attr.Ref /= No_Qualified_Name then
TRef :=
Get (Ref.all, (Attrs (A).Attr.Ref, ref_attribute));
if TRef = No_Global_Reference then
Validation_Error
(Parser,
"Unknown referenced attribute: " &
To_QName (Attrs (A).Attr.Ref),
Attrs (A).Loc);
end if;
Add_Attribute
(Parser,
List,
Attribute => Attrs (A).Attr.Descr,
Ref => TRef.Attributes.Named,
Loc => Attrs (A).Loc);
else
Resolve_Attribute_Type (Attrs (A).Attr, Attrs (A).Loc);
if Attrs (A).Attr.Any /= No_Internal_Any_Descr then
Had_Any := True;
Add_Any_Attribute
(Parser.Grammar,
List,
Attrs (A).Attr.Any,
As_Restriction);
else
Add_Attribute
(Parser,
List,
Attrs (A).Attr.Descr,
Loc => Attrs (A).Loc);
end if;
end if;
end case;
end loop;
end if;
end Add_Attributes;
------------------------
-- Create_Simple_Type --
------------------------
procedure Create_Simple_Type
(J : internal_type_index;
Descr : out type_descr_access;
Index : out type_index)
is
Info : internal_type_descr renames Shared.Types.Table (J);
Simple : simple_type_descr;
Index_In_Simple : Natural;
Internal : internal_simple_type_descr;
Result : simple_type_index;
begin
Index := Info.In_NFA;
Descr := type_descr_access (NFA.Get_Type_Descr (Index));
Result := Descr.Simple_Content;
if Result /= No_Simple_Type_Index then
if Debug then
Debug_Output
("Create_Simple_Type: already done " &
To_QName (Info.Properties.Name));
end if;
return;
end if;
Internal := Info.Simple;
if Internal.Kind = simple_type_none then
-- Not a simple type, nothing to do
Descr := null;
return;
end if;
if Internal.In_Process then
Validation_Error
(Parser,
"Circular inheritance of type " &
To_QName (Info.Properties.Name),
Info.Loc);
end if;
if Debug then
Debug_Output
("Create_Simple_Type " &
To_QName (Info.Properties.Name) &
" " &
Internal.Kind'img);
end if;
Info.Simple.In_Process := True;
case Internal.Kind is
when simple_type_none =>
Descr := null;
return;
when simple_type =>
-- ??? Shouldn't we set Simple_Content as well ?
Descr.Restriction_Of := Any_Simple_Type_Index;
when simple_type_union =>
Simple :=
(Kind => primitive_union,
Union => (others => No_Simple_Type_Index),
others => <>);
Index_In_Simple := Simple.Union'first;
for U in Internal.Union_Items'range loop
declare
Member : constant type_member := Internal.Union_Items (U);
Item : type_descr_access;
Index : type_index;
begin
exit when Member = No_Type_Member;
if Member.Name /= No_Qualified_Name then
Lookup_Simple_Type
(Member.Name,
Internal.Loc,
Item,
Index);
if Item.Final (final_union) then
Validation_Error
(Parser,
To_QName (Member.Name) & " is final for union",
Internal.Loc);
end if;
else
Create_Simple_Type (Member.Local, Item, Index);
end if;
Simple.Union (Index_In_Simple) := Item.Simple_Content;
Index_In_Simple := Index_In_Simple + 1;
end;
end loop;
Result := Create_Simple_Type (NFA, Simple);
Descr.Simple_Content := Result;
Descr.Restriction_Of := Any_Simple_Type_Index;
when simple_type_list =>
Simple :=
(Kind => primitive_list,
List_Item => No_Simple_Type_Index,
others => <>);
for U in Internal.List_Items'range loop
declare
Member : constant type_member := Internal.List_Items (U);
Item : type_descr_access;
Index : type_index;
begin
exit when Member = No_Type_Member;
if Member.Name /= No_Qualified_Name then
Lookup_Simple_Type
(Member.Name,
Internal.Loc,
Item,
Index);
if Item.Final (final_list) then
Validation_Error
(Parser,
To_QName (Member.Name) & " is final for list",
Internal.Loc);
end if;
else
Create_Simple_Type (Member.Local, Item, Index);
end if;
Simple.List_Item := Item.Simple_Content;
end;
end loop;
Result := Create_Simple_Type (NFA, Simple);
Descr.Simple_Content := Result;
Descr.Restriction_Of := Any_Simple_Type_Index;
when simple_type_restriction | simple_type_extension =>
declare
Base : simple_type_descr;
Error : symbol;
Loc : location;
NFA_Simple : type_descr_access;
NFA_Type : type_index;
begin
if Internal.Base.Name /= No_Qualified_Name then
Lookup_Simple_Type
(Internal.Base.Name,
Internal.Loc,
NFA_Simple,
NFA_Type);
else
Create_Simple_Type
(Internal.Base.Local,
NFA_Simple,
NFA_Type);
end if;
if Internal.Base = No_Type_Member then
Base := Any_Simple_Type;
NFA_Type := Any_Simple_Type_Index;
elsif NFA_Simple = null
or else NFA_Simple.Simple_Content = No_Simple_Type_Index
then
Validation_Error
(Parser,
"base type specified in simpleContent definition must" &
" be a simple type",
Loc);
else
Base :=
Copy (Get_Simple_Type (NFA, NFA_Simple.Simple_Content));
Override
(Simple => Base,
Facets => Internal.Facets,
Symbols => Get_Symbol_Table (Parser.all),
As_Restriction =>
Internal.Kind = simple_type_restriction,
Error => Error,
Error_Loc => Loc);
if Error /= No_Symbol then
Validation_Error (Parser, Get (Error).all, Loc);
end if;
end if;
case Internal.Kind is
when simple_type_restriction =>
Descr.Restriction_Of := NFA_Type;
when simple_type_extension =>
Descr.Extension_Of := NFA_Type;
when others =>
null;
end case;
Result := Create_Simple_Type (NFA, Base);
Descr.Simple_Content := Result;
end;
end case;
Info.Simple.In_Process := False;
end Create_Simple_Type;
------------------------------
-- Create_Global_Attributes --
------------------------------
procedure Create_Global_Attributes (Attr : internal_attribute_descr) is
Attr2 : internal_attribute_descr;
begin
pragma assert
(Attr.Ref = No_Qualified_Name,
"A global attribute cannot define ref");
pragma assert
(Attr.Descr.Name /= No_Qualified_Name,
"A global attribute must have a name");
pragma assert
(Attr.Any = No_Internal_Any_Descr,
"A global attribute is not ");
pragma assert
(Attr.Descr.Next = Empty_Named_Attribute_List,
"Global attributes cannot be in a list");
pragma assert
(Attr.Descr.Simple_Type = No_Simple_Type_Index,
"Type of global attributes should be undefined here");
Attr2 := Attr;
Resolve_Attribute_Type (Attr2, No_Location);
Create_Global_Attribute (Parser, Attr2.Descr, No_Location);
end Create_Global_Attributes;
------------------
-- Process_Type --
------------------
procedure Process_Type (Info : in out internal_type_descr) is
S1 : state;
List : attributes_list := No_Attributes;
Processed_Groups : AttrGroup_HTables.instance;
-- ??? If this table is here, we can't have an with the
-- same attributeGroup as its base type. Maybe this should be local
-- to Recursive_Add_Attributes instead
procedure Recursive_Add_Attributes (Info : internal_type_descr);
procedure Recursive_Add_Attributes (Info : internal_type_descr) is
Ty : global_reference;
Index : internal_type_index;
Had_Any : Boolean := False;
Base : qualified_name;
As_Restriction : Boolean;
begin
if Info.Is_Simple then
-- A simpleType has no attribute
return;
elsif Info.Details = null then
Add_Attributes
(List,
Info.Attributes,
Processed_Groups,
As_Restriction => True,
Had_Any => Had_Any);
Reset (Processed_Groups);
return;
end if;
if Info.Details.Kind = type_extension then
Base := Info.Details.Extension.Base;
As_Restriction := False;
elsif Info.Details.Kind = type_restriction then
Base := Info.Details.Restriction.Base;
As_Restriction := True;
else
Base := No_Qualified_Name;
end if;
if Base = No_Qualified_Name then
-- No character data is allowed, but we might have attributes
Add_Attributes
(List,
Info.Attributes,
Processed_Groups,
As_Restriction => True,
Had_Any => Had_Any);
elsif not As_Restriction then
Ty := Get (Ref.all, (Base, ref_type));
if Ty = No_Global_Reference then
Validation_Error
(Parser,
"No type """ & To_QName (Base) & """",
Info.Loc);
end if;
-- If the base type is in the current package, we might not
-- have computed all its attributes. Otherwise, get the list of
-- attributes already computed in the grammar, since it is
-- complete.
Index := Get (Types, Base);
if Index /= No_Internal_Type_Index then
Recursive_Add_Attributes (Shared.Types.Table (Index));
else
Add_Attributes
(Parser,
List,
Get_Type_Descr (NFA, Ty.Typ).Attributes,
As_Restriction => False,
Loc => Info.Loc);
end if;
Add_Attributes
(List,
Info.Attributes,
Processed_Groups,
As_Restriction => False,
Had_Any => Had_Any);
else
Ty := Get (Ref.all, (Base, ref_type));
if Ty = No_Global_Reference then
Validation_Error
(Parser,
"No type """ & To_QName (Base) & """",
Info.Loc);
end if;
Index := Get (Types, Base);
if Index /= No_Internal_Type_Index then
Recursive_Add_Attributes (Shared.Types.Table (Index));
else
Add_Attributes
(Parser,
List,
Get_Type_Descr (NFA, Ty.Typ).Attributes,
As_Restriction => True,
Loc => Info.Loc);
end if;
Had_Any := False;
Add_Attributes
(List,
Info.Attributes,
Processed_Groups,
As_Restriction => True,
Had_Any => Had_Any);
-- Always add , even if none was given in the
-- restriction (in which case none should exist for the type
-- either);
if not Had_Any then
List.Any := No_Any_Descr; -- Nothing matches
end if;
end if;
end Recursive_Add_Attributes;
begin
if Info.Is_Simple then
null; -- Already done in Process_Type
else
if Debug then
Debug_Output
("Process complexType " & To_QName (Info.Properties.Name));
end if;
declare
Descr : constant access type_descr :=
Get_Type_Descr (NFA, Info.In_NFA);
Mask : visited_all_children;
Start : state := Descr.Complex_Content;
Is_All : constant Boolean :=
Info.Details /= null and then Info.Details.Kind = type_all;
begin
pragma assert (Descr.Complex_Content /= No_State);
if Is_All and then Info.Details.Min_Occurs.Value = 0 then
-- See comment in Process_Details as to why this is
-- handled here.
-- We should not make the transition directly from the
-- start node (Descr.Complex_Content), because it would
-- mean a user can start a and stop
-- in the middle with no error
Start := NFA.Add_State;
NFA.Add_Empty_Transition (Descr.Complex_Content, Start);
end if;
Process_Details
(In_Type => Descr,
Details => Info.Details,
Start => Start, -- Descr.Complex_Content,
From => Start,
Nested_End => S1,
Mask => Mask);
-- Add the attributes only after we did the details, so that we
-- know there is no infinite recursion between the base types
-- of extensions and restrictions
if Debug then
Debug_Output
("Process attributes for complexType " &
To_QName (Info.Properties.Name) &
" State=" &
Descr.Complex_Content'img &
" type_index=" &
Info.In_NFA'img);
end if;
Recursive_Add_Attributes (Info);
Descr.Attributes := List;
if Is_All then
NFA.Add_Transition
(S1, Final_State,
(Kind => transition_close_from_all,
Mask => Mask));
if Info.Details.Min_Occurs.Value = 0 then
NFA.Add_Transition
(Descr
.Complex_Content, Final_State,
(Kind => transition_close));
end if;
else
NFA.Add_Transition
(S1, Final_State, (Kind => transition_close));
end if;
end;
end if;
Reset (Processed_Groups);
exception
when others =>
Reset (Processed_Groups);
raise;
end Process_Type;
Element_Info : element_descr;
Attr : internal_attribute_descr;
S : state;
Ignored : type_descr_access;
Ignored_Index : type_index;
pragma unreferenced (Ignored, Ignored_Index);
begin
if Debug then
Debug_Output ("Create_NFA");
end if;
-- Prepare the entries for the types. These are empty to start with, but
-- they are needed to be able to create the more complex types, and the
-- global element.
for J in Type_Tables.First .. Last (Shared.Types) loop
-- Create the empty nested NFA if needed
S := No_State;
if not Shared.Types.Table (J).Is_Simple then
S := NFA.Add_State;
Shared.Types.Table (J).Properties.Complex_Content := S;
if Debug then
Debug_Output
("Created state for complexContent " &
To_QName (Shared.Types.Table (J).Properties.Name) &
" type=" &
J'img &
" state=" &
S'img);
end if;
end if;
Shared.Types.Table (J).In_NFA :=
Create_Type (NFA, Shared.Types.Table (J).Properties);
if S /= No_State then
-- At least .Complex_Content has changed, so we need to reset data
NFA.Set_Data
(S, state_data'
(Simple => Shared.Types.Table (J).In_NFA,
Block => No_Block,
Nillable => False,
Default => No_Symbol,
Fixed => No_Symbol));
end if;
if Shared.Types.Table (J).Properties.Name /= No_Qualified_Name then
Set (Types, Shared.Types.Table (J).Properties.Name, J);
end if;
end loop;
-- Process the simple types (must be in a separate loop, since a
-- restriction or a union needs to know about its base type)
for J in Type_Tables.First .. Last (Shared.Types) loop
Create_Simple_Type (J, Ignored, Ignored_Index);
end loop;
-- Prepare the entries for the global attributes
Attr := Get_First (Shared.Global_Attributes);
while Attr /= No_Internal_Attribute loop
Create_Global_Attributes (Attr);
Attr := Get_Next (Shared.Global_Attributes);
end loop;
-- Prepare schema for global elements
if Debug then
Debug_Output ("Create_NFA: adding global elements");
end if;
Element_Info := Get_First (Shared.Global_Elements);
while Element_Info /= No_Element_Descr loop
Process_Global_Element (Element_Info, Start_State);
-- Save the state
Set (Shared.Global_Elements, Element_Info.Name, Element_Info);
Element_Info := Get_Next (Shared.Global_Elements);
end loop;
if Debug then
Debug_Output ("Create_NFA: complete type definition");
end if;
-- Finally, complete the definition of complexTypes
for J in Type_Tables.First .. Last (Shared.Types) loop
Process_Type (Shared.Types.Table (J));
end loop;
if Debug then
Output_Action ("NFA: " & Dump_Dot_NFA (Get_Grammar (Parser.all)));
end if;
Reset (Types);
exception
when others =>
Reset (Types);
raise;
end Create_NFA;
----------
-- Free --
----------
procedure Free (Shared : in out xsd_data_access) is
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(xsd_data,
xsd_data_access);
Attr : attrgroup_descr;
Gr : group_descr;
begin
if Shared /= null then
-- Free all data structures, no longer needed
Reset (Shared.Global_Elements);
Gr := Get_First (Shared.Global_Groups);
while Gr /= No_Group_Descr loop
Free (Gr.Details);
Gr := Get_Next (Shared.Global_Groups);
end loop;
Reset (Shared.Global_Groups);
Attr := Get_First (Shared.Global_AttrGroups);
while Attr /= No_AttrGroup_Descr loop
Unchecked_Free (Attr.Attributes);
Attr := Get_Next (Shared.Global_AttrGroups);
end loop;
Reset (Shared.Global_AttrGroups);
for T in Type_Tables.First .. Last (Shared.Types) loop
if Shared.Types.Table (T).Is_Simple then
null;
else
Unchecked_Free (Shared.Types.Table (T).Attributes);
Free (Shared.Types.Table (T).Details);
end if;
end loop;
Free (Shared.Types);
Reset (Shared.Global_Attributes);
Unchecked_Free (Shared);
end if;
end Free;
-------------------
-- Parse_Grammar --
-------------------
procedure Parse_Grammar
(Handler : access validating_reader'class;
URI : symbol;
Xsd_File : symbol;
Do_Create_NFA : Boolean)
is
File : file_input;
Schema : schema_reader;
S_File_Full : constant symbol := To_Absolute_URI (Handler.all, Xsd_File);
Need_To_Initialize : Boolean := True;
begin
GNAT.Task_Lock.Lock;
Set_XML_Version (Schema, Get_XML_Version (Handler.all));
if URI_Was_Parsed (Get_Grammar (Handler.all), S_File_Full) then
if Debug then
Debug_Output
("Parse_Grammar " & Get (S_File_Full).all & " already parsed");
end if;
GNAT.Task_Lock.Unlock;
return;
end if;
if Debug then
Debug_Output
("Parse_Grammar NS={" &
Get (URI).all &
"} XSD={" &
Get (Xsd_File).all &
"} " &
Get (S_File_Full).all);
end if;
if Get_XSD_Version (Handler.Grammar) = xsd_1_0 then
-- Must check that no element of the same namespace was seen
-- already (as per 4.3.2 (4) in the XSD 1.0 norm, which was
-- changed in XSD 1.1).
declare
NS : xml_ns;
begin
Find_NS_From_URI (Handler.all, URI => URI, NS => NS);
if NS /= No_XML_NS
and then Element_Count (NS) > 0
and then S_File_Full /= Get_System_Id (NS)
and then Get_Feature
(Handler.all,
Sax.Readers.Schema_Validation_Feature)
then
Validation_Error
(Handler,
"schemaLocation for """ &
Get (URI).all &
""" cannot occur after the first" &
" element of that namespace in XSD 1.0");
end if;
end;
end if;
if Debug then
Output_Seen ("Parsing grammar: " & Get (S_File_Full).all);
end if;
Open (Get (S_File_Full).all, File);
Set_Public_Id (File, Get (S_File_Full).all);
Set_System_Id (File, Get (S_File_Full).all);
-- Add_To will likely already contain the grammar for the
-- schema-for-schema, and we won't have to recreate it in most cases.
Set_Symbol_Table (Schema, Get_Symbol_Table (Handler.all));
Set_Grammar (Schema, Handler.Grammar);
Use_Basename_In_Error_Messages
(Schema,
Use_Basename_In_Error_Messages (Handler.all));
Set_Feature
(Schema,
Sax.Readers.Schema_Validation_Feature,
Get_Feature (Handler.all, Sax.Readers.Schema_Validation_Feature));
if Handler.all in schema_reader'class then
Schema.Shared := schema_reader (Handler.all).Shared;
Need_To_Initialize := False;
end if;
begin
Internal_Parse
(Schema,
File,
Default_Namespace => URI,
Do_Initialize_Shared => Need_To_Initialize,
Do_Create_NFA => Need_To_Initialize and Do_Create_NFA);
exception
when XML_Not_Implemented | XML_Validation_Error =>
-- Copy the error message and location from Schema to Handler
Close (File);
Handler.Error_Msg := Schema.Error_Msg;
Handler.Error_Location := Schema.Error_Location;
raise;
end;
Free (Schema);
Close (File);
if Debug then
Output_Seen ("Done parsing new grammar: " & Get (Xsd_File).all);
end if;
GNAT.Task_Lock.Unlock;
exception
when Ada.IO_Exceptions.Name_Error =>
Free (Schema);
Close (File);
GNAT.Task_Lock.Unlock;
if Debug then
Debug_Output
(ASCII.LF &
"!!!! Could not open file " &
Get (S_File_Full).all &
ASCII.LF);
end if;
-- According to XML Schema Primer 0, section 5.6, this is not an
-- error when we do not find the schema, since this attribute is only
-- a hint.
Warning
(Handler.all,
Create
(Message => "Could not open file " & Get (S_File_Full).all,
Loc => Handler.Current_Location));
when others =>
GNAT.Task_Lock.Unlock;
Close (File);
raise;
end Parse_Grammar;
--------------------
-- Internal_Parse --
--------------------
procedure Internal_Parse
(Parser : in out schema_reader;
Input : in out Input_Sources.input_source'class;
Default_Namespace : symbol;
Do_Create_NFA : Boolean;
Do_Initialize_Shared : Boolean)
is
Grammar : constant xml_grammar := Get_Grammar (Parser);
URI : symbol;
begin
if Debug then
Output_Action
("Parsing schema " & Input_Sources.Get_System_Id (Input));
end if;
Initialize_Symbols (Parser);
URI := Find_Symbol (Parser, Input_Sources.Get_System_Id (Input));
if not URI_Was_Parsed (Grammar, URI) then
if Do_Initialize_Shared then
Parser.Shared := new xsd_data;
Init (Parser.Shared.Types);
end if;
Initialize_Grammar (Parser);
Parser.Target_NS := Default_Namespace;
Set_Grammar (Parser, Grammar); -- In case it was not initialized yet
Set_Parsed_URI (Parser, URI);
Schema.Readers.Parse (validating_reader (Parser), Input);
if Do_Create_NFA then
Create_NFA (Parser'access);
end if;
if Do_Initialize_Shared then
Free (Parser.Shared);
end if;
Unchecked_Free (Parser.Contexts);
end if;
exception
when others =>
Unchecked_Free (Parser.Contexts);
if Do_Initialize_Shared then
Free (Parser.Shared);
end if;
raise;
end Internal_Parse;
-----------
-- Parse --
-----------
procedure Parse
(Parser : in out schema_reader;
Input : in out Input_Sources.input_source'class)
is
begin
Internal_Parse
(Parser,
Input,
Default_Namespace => Empty_String,
Do_Create_NFA => True,
Do_Initialize_Shared => True);
end Parse;
-------------------
-- Resolve_QName --
-------------------
function Resolve_QName
(Handler : access schema_reader'class;
QName : Sax.Symbols.symbol;
NS_If_Empty : Sax.Symbols.symbol := Empty_String;
Loc : location) return qualified_name
is
Val : cst_byte_sequence_access;
Separator : Integer;
NS : xml_ns;
Prefix : symbol;
begin
if QName = No_Symbol then
return No_Qualified_Name;
else
Val := Get (QName);
Separator := Split_Qname (Val.all);
Prefix := Find_Symbol (Handler.all, Val (Val'first .. Separator - 1));
Get_Namespace_From_Prefix
(Handler => Handler.all,
Prefix => Prefix,
NS => NS);
if NS = No_XML_NS then
if Prefix /= Empty_String then
Validation_Error
(Handler,
"Cannot resolve namespace prefix " &
Val (Val'first .. Separator - 1),
Loc);
return No_Qualified_Name;
else
return
(NS => NS_If_Empty,
Local =>
Find_Symbol
(Handler.all,
Val (Separator + 1 .. Val'last)));
end if;
else
return
(NS => Get_URI (NS),
Local =>
Find_Symbol (Handler.all, Val (Separator + 1 .. Val'last)));
end if;
end if;
end Resolve_QName;
----------------
-- Get_Occurs --
----------------
procedure Get_Occurs
(Handler : access schema_reader'class;
Atts : sax_attribute_list;
Min_Occurs, Max_Occurs : out occurrences)
is
Min_Occurs_Index : constant Integer :=
Get_Index (Atts, URI => Empty_String, Local_Name => Handler.MinOccurs);
Max_Occurs_Index : constant Integer :=
Get_Index (Atts, URI => Empty_String, Local_Name => Handler.MaxOccurs);
function Occurs_From_Value (Index : Integer) return occurrences;
-- Return the value of maxOccurs from the attributes'value. This
-- properly takes into account the "unbounded" case
function Occurs_From_Value (Index : Integer) return occurrences is
Value : constant symbol := Get_Value (Atts, Index);
begin
if Value = Handler.Unbounded then
return (Unbounded => True);
else
declare
Val : constant cst_byte_sequence_access := Get (Value);
Pos : Integer;
C : unicode_char;
begin
return (Unbounded => False, Value => Natural'value (Val.all));
exception
when Constraint_Error =>
-- Either we have an integer too big to fit in Integer, or
-- we do not have an integer at all
Pos := Val'first;
while Pos <= Val'last loop
Encoding.Read (Val.all, Pos, C);
if not Is_Digit (C) then
Validation_Error
(Handler,
"Value for ""maxOccurs"" must" &
" be an integer or ""unbounded""");
end if;
end loop;
return (Unbounded => False, Value => Natural'last);
end;
end if;
end Occurs_From_Value;
begin
Min_Occurs := (False, 1);
Max_Occurs := (False, 1);
if Min_Occurs_Index /= -1 then
Min_Occurs := Occurs_From_Value (Min_Occurs_Index);
if Min_Occurs.Unbounded then
Validation_Error (Handler, "minOccurs cannot be ""unbounded""");
end if;
end if;
if Max_Occurs_Index /= -1 then
Max_Occurs := Occurs_From_Value (Max_Occurs_Index);
end if;
if not Max_Occurs.Unbounded
and then Max_Occurs.Value > max_max_occurs
then
Validation_Error
(Handler,
"maxOccurs is too big, consider using ""unbounded""",
Except => XML_Not_Implemented'identity);
end if;
end Get_Occurs;
------------------
-- Push_Context --
------------------
procedure Push_Context
(Handler : access schema_reader'class;
Ctx : context)
is
Tmp : context_array_access;
begin
if Handler.Contexts_Last = 0 then
Handler.Contexts := new context_array (1 .. default_contexts);
elsif Handler.Contexts_Last = Handler.Contexts'last then
Tmp := new context_array (1 .. Handler.Contexts'last + 30);
Tmp (Handler.Contexts'range) := Handler.Contexts.all;
Unchecked_Free (Handler.Contexts);
Handler.Contexts := Tmp;
end if;
Handler.Contexts_Last := Handler.Contexts_Last + 1;
Handler.Contexts (Handler.Contexts_Last) := Ctx;
end Push_Context;
------------------
-- Create_Group --
------------------
procedure Create_Group
(Handler : access schema_reader'class;
Atts : sax_attribute_list)
is
Min_Occurs, Max_Occurs : occurrences := (False, 1);
Group : group_descr;
Name : qualified_name;
Details : type_details_access;
begin
Group.Loc := Handler.Current_Location;
for J in 1 .. Get_Length (Atts) loop
Name := Get_Name (Atts, J);
if Name.NS = Empty_String then
if Name.Local = Handler.Name then
Group.Name :=
(NS => Handler.Target_NS, Local => Get_Value (Atts, J));
elsif Name.Local = Handler.Ref then
Group.Ref :=
Resolve_QName
(Handler,
Get_Value (Atts, J),
Loc => Get_Location (Atts, J));
end if;
end if;
end loop;
case Handler.Contexts (Handler.Contexts_Last).Typ is
when context_schema | context_redefine =>
null;
when context_sequence |
context_choice |
context_extension |
context_restriction =>
Get_Occurs (Handler, Atts, Min_Occurs, Max_Occurs);
Details :=
new type_details'
(Kind => type_group,
Min_Occurs => Min_Occurs,
Max_Occurs => Max_Occurs,
Loc => Handler.Current_Location,
In_Process => False,
Next => null,
Group => Group);
Insert_In_Type (Handler, Details);
when others =>
Validation_Error
(Handler,
"Unsupported ""group"" in this context",
Except => XML_Not_Implemented'identity);
end case;
Push_Context (Handler, (Typ => context_group, Group => Group));
end Create_Group;
------------------
-- Finish_Group --
------------------
procedure Finish_Group (Handler : access schema_reader'class) is
Ctx : constant context_access :=
Handler.Contexts (Handler.Contexts_Last)'access;
Next : constant context_access :=
Handler.Contexts (Handler.Contexts_Last - 1)'access;
begin
case Next.Typ is
when context_schema | context_redefine =>
Set (Handler.Shared.Global_Groups, Ctx.Group.Name, Ctx.Group);
when others =>
null;
end case;
end Finish_Group;
----------------------------
-- Create_Attribute_Group --
----------------------------
procedure Create_Attribute_Group
(Handler : access schema_reader'class;
Atts : sax_attribute_list)
is
Group : attrgroup_descr;
Name : qualified_name;
begin
for J in 1 .. Get_Length (Atts) loop
Name := Get_Name (Atts, J);
if Name.NS = Empty_String then
if Name.Local = Handler.Name then
Group.Name :=
(NS => Handler.Target_NS, Local => Get_Value (Atts, J));
elsif Name.Local = Handler.Ref then
Group.Ref :=
Resolve_QName
(Handler,
Get_Value (Atts, J),
Loc => Get_Location (Atts, J));
end if;
end if;
end loop;
Push_Context
(Handler,
(Typ => context_attribute_group, Attr_Group => Group));
end Create_Attribute_Group;
----------------------------
-- Finish_Attribute_Group --
----------------------------
procedure Finish_Attribute_Group (Handler : access schema_reader'class) is
Ctx : constant context_access :=
Handler.Contexts (Handler.Contexts_Last)'access;
Next : constant context_access :=
Handler.Contexts (Handler.Contexts_Last - 1)'access;
Ctx2 : context_access;
Index : Natural;
begin
case Next.Typ is
when context_schema | context_redefine =>
Set
(Handler.Shared.Global_AttrGroups,
Ctx.Attr_Group.Name,
Ctx.Attr_Group);
when context_type_def =>
pragma assert (Ctx.Attr_Group.Attributes = null);
Append
(Handler.Shared.Types.Table (Next.Type_Info).Attributes,
(Kind => kind_group,
Loc => Handler.Current_Location,
Group_Ref => Ctx.Attr_Group.Ref));
when context_extension =>
pragma assert (Ctx.Attr_Group.Attributes = null);
Index := Handler.Contexts_Last - 1;
while Index >= Handler.Contexts'first loop
Ctx2 := Handler.Contexts (Index)'access;
if Ctx2.Typ = context_type_def then
Append
(Handler.Shared.Types.Table (Ctx2.Type_Info).Attributes,
(Kind => kind_group,
Loc => Handler.Current_Location,
Group_Ref => Ctx.Attr_Group.Ref));
exit;
end if;
Index := Index - 1;
end loop;
when context_attribute_group =>
pragma assert (Ctx.Attr_Group.Attributes = null);
Append
(Next.Attr_Group.Attributes,
(Kind => kind_group,
Loc => Handler.Current_Location,
Group_Ref => Ctx.Attr_Group.Ref));
when others =>
Unchecked_Free (Ctx.Attr_Group.Attributes);
Validation_Error
(Handler,
"Invalid context for attributeGroup: " & Next.Typ'img,
Except => XML_Not_Implemented'identity);
end case;
end Finish_Attribute_Group;
------------
-- Append --
------------
procedure Append (List : in out attr_array_access; Attr : attr_descr) is
Tmp : attr_array_access;
begin
if List = null then
List :=
new attr_array'
(1 => Attr, 2 .. 10 => (Kind => kind_unset, Loc => No_Location));
elsif List (List'last).Kind /= kind_unset then
Tmp := new attr_array (1 .. List'last + 10);
Tmp (List'range) := List.all;
Tmp (List'last + 1) := Attr;
Tmp (List'last + 2 .. Tmp'last) :=
(others => attr_descr'(Kind => kind_unset, Loc => No_Location));
Unchecked_Free (List);
List := Tmp;
else
for L in List'range loop
if List (L).Kind = kind_unset then
List (L) := Attr;
return;
end if;
end loop;
end if;
end Append;
--------------------
-- Create_Include --
--------------------
procedure Create_Include
(Handler : access schema_reader'class;
Atts : sax_attribute_list)
is
Schema_Location_Index : constant Integer :=
Get_Index (Atts, Empty_String, Handler.Schema_Location);
begin
Parse_Grammar
(Handler,
URI => Handler.Target_NS,
Xsd_File => Get_Value (Atts, Schema_Location_Index),
Do_Create_NFA => False); -- Will be performed later
end Create_Include;
---------------------
-- Create_Redefine --
---------------------
procedure Create_Redefine
(Handler : access schema_reader'class;
Atts : sax_attribute_list)
is
Location_Index : constant Integer :=
Get_Index (Atts, Empty_String, Handler.Schema_Location);
begin
-- Disable for now.
-- On the test./testschema -xsd boeingData/ipo4/ipo.xsd
-- -xsd boeingData/ipo4/address.xsd
-- -xsd boeingData/ipo4/itematt.xsd
-- boeingData/ipo4/ipo_1.xml
-- we redefine an extension whose base type comes from the redefined
-- grammar, and whose name is the same. As a result, the extension and
-- its base type end up being the same XML_Type, and thus we get
-- infinite loops. We should really merge the models when the grammar is
-- parsed.
Validation_Error
(Handler,
" not supported",
Except => XML_Not_Implemented'identity);
Parse_Grammar
(Handler,
URI => Handler.Target_NS,
Do_Create_NFA => True,
Xsd_File => Get_Value (Atts, Location_Index));
Push_Context (Handler, (Typ => context_redefine));
end Create_Redefine;
-------------------
-- Create_Import --
-------------------
procedure Create_Import
(Handler : access schema_reader'class;
Atts : sax_attribute_list)
is
Location_Index : constant Integer :=
Get_Index (Atts, Empty_String, Handler.Schema_Location);
Namespace_Index : constant Integer :=
Get_Index (Atts, Empty_String, Handler.Namespace);
begin
if Location_Index = -1 then
if Namespace_Index = -1 then
-- See 4.2.6.1: If that attribute is absent, then the import
-- allows unqualified reference to components with no target
-- namespace
null;
end if;
Validation_Error
(Handler,
"Import with no schemaLocation is unsupported",
Except => XML_Not_Implemented'identity);
else
declare
Location : constant symbol := Get_Value (Atts, Location_Index);
begin
if Debug then
Debug_Output ("Import: " & Get (Location).all);
Debug_Output ("Adding new grammar to Handler.Created_Grammar");
end if;
-- The namespace attribute indicates that the XSD may contain
-- qualified references to schema components in that namespace.
-- (4.2.6.1). It does not give the default targetNamespace
Parse_Grammar
(Handler,
URI => Empty_String,
Do_Create_NFA => True,
Xsd_File => Location);
end;
end if;
end Create_Import;
--------------------------
-- Create_Any_Attribute --
--------------------------
procedure Create_Any_Attribute
(Handler : access schema_reader'class;
Atts : sax_attribute_list)
is
Name : qualified_name;
Att : attr_descr (Kind => kind_attribute);
begin
Att.Loc := Handler.Current_Location;
Att.Attr.Any :=
(Namespaces => Handler.Any_Namespace,
Target_NS => Handler.Target_NS,
Process_Contents => process_strict);
for J in 1 .. Get_Length (Atts) loop
Name := Get_Name (Atts, J);
if Name.NS = Empty_String then
if Name.Local = Handler.Namespace then
Att.Attr.Any.Namespaces := Get_Value (Atts, J);
elsif Name.Local = Handler.Process_Contents then
Att.Attr.Any.Process_Contents :=
Process_Contents_From_Atts (Handler, Atts, J);
end if;
end if;
end loop;
Insert_Attribute (Handler, Handler.Contexts_Last, Att);
end Create_Any_Attribute;
---------------------
-- Create_Notation --
---------------------
procedure Create_Notation
(Handler : access schema_reader'class;
Atts : sax_attribute_list)
is
type notation_descr is record
Name : symbol;
System_Id : symbol := Empty_String;
Public_Id : symbol := Empty_String;
end record;
Name : qualified_name;
Notation : notation_descr;
begin
for J in 1 .. Get_Length (Atts) loop
Name := Get_Name (Atts, J);
if Name.NS = Empty_String then
if Name.Local = Handler.Name then
Notation.Name := Get_Value (Atts, J);
elsif Name.Local = Handler.Public then
Notation.Public_Id := Get_Value (Atts, J);
elsif Name.Local = Handler.System then
Notation.System_Id := Get_Value (Atts, J);
end if;
end if;
end loop;
Add_Notation (Get_NFA (Handler.Grammar), Notation.Name);
Notation_Decl
(sax_reader'class (Handler.all),
Name => Get (Notation.Name).all,
System_Id => Get (Notation.System_Id).all,
Public_Id => Get (Notation.Public_Id).all);
end Create_Notation;
--------------------
-- Create_Element --
--------------------
procedure Create_Element
(Handler : access schema_reader'class;
Atts : sax_attribute_list)
is
Min_Occurs, Max_Occurs : occurrences := (False, 1);
Info : element_descr;
Name : qualified_name;
Details : type_details_access;
begin
Info.Loc := Handler.Current_Location;
Info.Form := Handler.Element_Form_Default;
Info.Block := Handler.Target_Block_Default;
for J in 1 .. Get_Length (Atts) loop
Name := Get_Name (Atts, J);
if Name.NS = Empty_String then
if Name.Local = Handler.Typ then
Info.Typ :=
Resolve_QName
(Handler,
Get_Value (Atts, J),
NS_If_Empty => Handler.Target_NS,
Loc => Get_Location (Atts, J));
elsif Name.Local = Handler.Name then
Info.Name :=
(NS => Handler.Target_NS, Local => Get_Value (Atts, J));
elsif Name.Local = Handler.Ref then
Info.Ref :=
Resolve_QName
(Handler,
Get_Value (Atts, J),
Loc => Get_Location (Atts, J));
elsif Name.Local = Handler.Substitution_Group then
Info.Substitution_Group :=
Resolve_QName
(Handler,
Get_Value (Atts, J),
Loc => Get_Location (Atts, J));
elsif Name.Local = Handler.Default then
Info.Default := Get_Value (Atts, J);
elsif Name.Local = Handler.Fixed then
Info.Fixed := Get_Value (Atts, J);
elsif Name.Local = Handler.S_Abstract then
Info.Is_Abstract := Get_Value_As_Boolean (Atts, J, False);
elsif Name.Local = Handler.Nillable then
Info.Nillable := Get_Value_As_Boolean (Atts, J, False);
elsif Name.Local = Handler.Form then
Info.Form := Compute_Form (Atts, Handler, J);
elsif Name.Local = Handler.Final then
Info.Final := Compute_Final (Atts, Handler, J);
elsif Name.Local = Handler.Block then
Compute_Blocks (Atts, Handler, Info.Block, Info.Has_Block, J);
end if;
end if;
end loop;
if Info.Name /= No_Qualified_Name then
if Info.Ref /= No_Qualified_Name
and then Info.Ref.NS = No_Symbol
and then Info.Name = Info.Ref
and then not In_Redefine_Context (Handler.all)
then
Validation_Error
(Handler,
"""ref"" attribute cannot be self-referencing");
elsif Info.Ref /= No_Qualified_Name then
Validation_Error
(Handler,
"Name and Ref cannot be both specified");
end if;
elsif Info.Ref = No_Qualified_Name then
Validation_Error
(Handler,
"Either ""name"" or ""ref"" attribute must be present");
else
-- Section 3.3.2, validity constraints 3.3.3
if Info.Typ /= No_Qualified_Name then
Validation_Error
(Handler,
"""type"" attribute cannot be specified along with ""ref""");
end if;
end if;
if Info.Default /= No_Symbol and then Info.Fixed /= No_Symbol then
Validation_Error
(Handler,
"Default and Fixed cannot be both specified");
end if;
if Info.Ref /= No_Qualified_Name then
Info.Form := qualified;
end if;
if Handler.Contexts (Handler.Contexts_Last).Typ /= context_schema then
Get_Occurs (Handler, Atts, Min_Occurs, Max_Occurs);
Details :=
new type_details'
(Kind => type_element,
Min_Occurs => Min_Occurs,
Max_Occurs => Max_Occurs,
Loc => Handler.Current_Location,
In_Process => False,
Next => null,
Element => Info);
Insert_In_Type (Handler, Details);
end if;
Push_Context
(Handler,
(Typ => context_element, Elem_Details => Details, Element => Info));
end Create_Element;
--------------------
-- Finish_Element --
--------------------
procedure Finish_Element (Handler : access schema_reader'class) is
Ctx : constant context_access :=
Handler.Contexts (Handler.Contexts_Last)'access;
Next : constant context_access :=
Handler.Contexts (Handler.Contexts_Last - 1)'access;
Info : constant element_descr := Ctx.Element;
begin
case Next.Typ is
when context_schema | context_redefine =>
Set (Handler.Shared.Global_Elements, Info.Name, Info);
when others =>
-- We might have added the type definition
Ctx.Elem_Details.Element := Ctx.Element;
end case;
end Finish_Element;
------------------------
-- Create_Simple_Type --
------------------------
procedure Create_Simple_Type
(Handler : access schema_reader'class;
Atts : sax_attribute_list)
is
Ctx : constant context_access :=
Handler.Contexts (Handler.Contexts_Last)'access;
begin
Prepare_Type (Handler, Atts, Is_Simple => True);
if Ctx.Typ = context_simple_restriction then
Ctx.Simple.Base :=
(Name => No_Qualified_Name,
Local => Handler.Contexts (Handler.Contexts_Last).Type_Info);
end if;
end Create_Simple_Type;
---------------------
-- Add_Type_Member --
---------------------
procedure Add_Type_Member
(Handler : access schema_reader'class;
List : in out type_member_array;
Member : type_member;
Loc : location)
is
begin
for A in List'range loop
if List (A) = No_Type_Member then
List (A) := Member;
return;
end if;
end loop;
Validation_Error
(Handler,
"Too many types in the union",
Loc,
XML_Not_Implemented'identity);
end Add_Type_Member;
------------------------
-- Finish_Simple_Type --
------------------------
procedure Finish_Simple_Type (Handler : access schema_reader'class) is
Ctx : constant context_access :=
Handler.Contexts (Handler.Contexts_Last)'access;
Next : constant context_access :=
Handler.Contexts (Handler.Contexts_Last - 1)'access;
begin
case Next.Typ is
when context_schema | context_redefine =>
null;
when context_element =>
Next.Element.Local_Type := Ctx.Type_Info;
when context_attribute =>
Next.Attribute.Attr.Local_Type := Ctx.Type_Info;
when context_list =>
Add_Type_Member
(Handler,
Next.List.List_Items,
(Name => No_Qualified_Name, Local => Ctx.Type_Info),
No_Location);
when context_union =>
Add_Type_Member
(Handler,
Next.Union.Union_Items,
(Name => No_Qualified_Name, Local => Ctx.Type_Info),
No_Location);
when context_restriction =>
Next.Restriction.Restriction.Details :=
Handler.Shared.Types.Table (Ctx.Type_Info).Details;
when context_simple_restriction =>
-- The simpleType is in fact the base type of the restriction. The
-- following was already done in Create_Simple_Type:
-- Next.Simple.Base.Local := Ctx.Type_Info;
null;
when others =>
Validation_Error
(Handler,
"Unsupported: ""simpleType"" in this context",
Except => XML_Not_Implemented'identity);
end case;
end Finish_Simple_Type;
--------------------
-- Compute_Blocks --
--------------------
procedure Compute_Blocks
(Atts : sax_attribute_list;
Handler : access schema_reader'class;
Blocks : out block_status;
Is_Set : out Boolean;
Index : Integer)
is
procedure On_Item (Str : byte_sequence);
procedure On_Item (Str : byte_sequence) is
begin
if Str = "restriction" then
Blocks (block_restriction) := True;
elsif Str = "extension" then
Blocks (block_extension) := True;
elsif Str = "substitution" then
Blocks (block_substitution) := True;
elsif Str = "#all" then
Blocks := (others => True);
else
Validation_Error
(Handler,
"Invalid value for block: """ & Str & """");
end if;
end On_Item;
procedure For_Each is new For_Each_Item (On_Item);
begin
Is_Set := Index /= -1;
Blocks := No_Block;
if Index /= -1 then
For_Each (Get (Get_Value (Atts, Index)).all);
if Debug then
Output_Action ("Set_Block (" & To_String (Blocks) & ")");
end if;
end if;
end Compute_Blocks;
------------------
-- Compute_Form --
------------------
function Compute_Form
(Atts : sax_attribute_list;
Handler : access schema_reader'class;
Index : Integer) return form_type
is
begin
if Get_Value (Atts, Index) = Handler.Qualified then
return qualified;
else
return unqualified;
end if;
end Compute_Form;
-------------------
-- Compute_Final --
-------------------
function Compute_Final
(Atts : sax_attribute_list;
Handler : access schema_reader'class;
Index : Integer) return final_status
is
Final : final_status;
procedure On_Item (Str : byte_sequence);
procedure On_Item (Str : byte_sequence) is
begin
if Str = "restriction" then
Final (final_restriction) := True;
elsif Str = "extension" then
Final (final_extension) := True;
elsif Str = "#all" then
Final := (others => True);
elsif Str = "union" then
Final (final_union) := True;
elsif Str = "list" then
Final (final_list) := True;
else
Validation_Error
(Handler,
"Invalid value for final: """ & Str & """");
end if;
end On_Item;
procedure For_Each is new For_Each_Item (On_Item);
begin
Final := (others => False);
if Index /= -1 then
For_Each (Get (Get_Value (Atts, Index)).all);
if Debug then
Output_Action ("Set_Final (" & To_String (Final) & ")");
end if;
end if;
return Final;
end Compute_Final;
------------------
-- Prepare_Type --
------------------
procedure Prepare_Type
(Handler : access schema_reader'class;
Atts : sax_attribute_list;
Is_Simple : Boolean)
is
Info : internal_type_descr (Is_Simple => Is_Simple);
Is_Set : Boolean;
Name : qualified_name;
Props : type_descr;
begin
Info.Loc := Handler.Current_Location;
Props.Block := Handler.Target_Block_Default;
for J in 1 .. Get_Length (Atts) loop
Name := Get_Name (Atts, J);
if Name.NS = Empty_String then
if Name.Local = Handler.Mixed then
Props.Mixed := Get_Value_As_Boolean (Atts, J, False);
elsif Name.Local = Handler.Name then
Props.Name :=
(NS => Handler.Target_NS, Local => Get_Value (Atts, J));
elsif Name.Local = Handler.Block then
Compute_Blocks (Atts, Handler, Props.Block, Is_Set, J);
elsif Name.Local = Handler.Final then
Props.Final := Compute_Final (Atts, Handler, J);
elsif Name.Local = Handler.S_Abstract then
Props.Is_Abstract := Get_Value_As_Boolean (Atts, J, False);
end if;
end if;
end loop;
-- block="substitution" does not apply to types, only to elements
Props.Block (block_substitution) := False;
Info.Properties := Props;
Append (Handler.Shared.Types, Info);
Push_Context
(Handler,
(Typ => context_type_def, Type_Info => Last (Handler.Shared.Types)));
end Prepare_Type;
-------------------------
-- Create_Complex_Type --
-------------------------
procedure Create_Complex_Type
(Handler : access schema_reader'class;
Atts : sax_attribute_list)
is
begin
Prepare_Type (Handler, Atts, Is_Simple => False);
end Create_Complex_Type;
-------------------------
-- Finish_Complex_Type --
-------------------------
procedure Finish_Complex_Type (Handler : access schema_reader'class) is
Ctx : constant context_access :=
Handler.Contexts (Handler.Contexts_Last)'access;
Next : constant context_access :=
Handler.Contexts (Handler.Contexts_Last - 1)'access;
begin
case Next.Typ is
when context_element =>
Next.Element.Local_Type := Ctx.Type_Info;
when others =>
null;
end case;
end Finish_Complex_Type;
------------------------
-- Create_Restriction --
------------------------
procedure Create_Restriction
(Handler : access schema_reader'class;
Atts : sax_attribute_list)
is
Ctx : constant context_access :=
Handler.Contexts (Handler.Contexts_Last)'access;
Restr : restriction_descr;
Details : type_details_access;
Name : qualified_name;
In_Type : constant internal_type_index := Ctx.Type_Info;
begin
Restr.Loc := Handler.Current_Location;
Restr.Base :=
(NS => Handler.XML_Schema_URI, Local => Handler.Any_Simple_Type);
for J in 1 .. Get_Length (Atts) loop
Name := Get_Name (Atts, J);
if Name.NS = Empty_String then
if Name.Local = Handler.Base then
Restr.Base :=
Resolve_QName
(Handler,
Get_Value (Atts, J),
Handler.Target_NS,
Get_Location (Atts, J));
end if;
end if;
end loop;
if Handler.Shared.Types.Table (In_Type).Is_Simple
or else
Handler.Shared.Types.Table (In_Type).Simple.Kind /=
simple_type_none
then
if Restr.Base = (NS => Handler.XML_Schema_URI, Local => Handler.IDREF)
or else
Restr.Base =
(NS => Handler.XML_Schema_URI, Local => Handler.IDREFS)
then
Validation_Error
(Handler,
"Unsupported type IDREF and IDREFS",
Except => XML_Not_Implemented'identity);
end if;
if not Handler.Shared.Types.Table (In_Type).Is_Simple then
Details :=
new type_details'
(Kind => type_restriction,
Min_Occurs => (False, 1),
Max_Occurs => (False, 1),
Loc => Handler.Current_Location,
In_Process => False,
Next => null,
Simple_Content_Restriction => True,
Restriction => Restr);
Insert_In_Type (Handler, Details);
end if;
Push_Context
(Handler,
(Typ => context_simple_restriction,
Simple =>
(Kind => simple_type_restriction,
In_Process => False,
Facets => No_Facets,
Base => (Name => Restr.Base, Local => No_Internal_Type_Index),
Loc => Handler.Current_Location)));
else
Details :=
new type_details'
(Kind => type_restriction,
Min_Occurs => (False, 1),
Max_Occurs => (False, 1),
Loc => Handler.Current_Location,
In_Process => False,
Next => null,
Simple_Content_Restriction => False,
Restriction => Restr);
Insert_In_Type (Handler, Details);
Push_Context
(Handler,
(Typ => context_restriction, Restriction => Details));
end if;
end Create_Restriction;
------------------------
-- Finish_Restriction --
------------------------
procedure Finish_Restriction (Handler : access schema_reader'class) is
Ctx : constant context_access :=
Handler.Contexts (Handler.Contexts_Last)'access;
Next : constant context_access :=
Handler.Contexts (Handler.Contexts_Last - 1)'access;
begin
if Ctx.Typ = context_simple_restriction then
pragma assert (Next.Typ = context_type_def);
Handler.Shared.Types.Table (Next.Type_Info).Simple := Ctx.Simple;
end if;
end Finish_Restriction;
------------------
-- Create_Union --
------------------
procedure Create_Union
(Handler : access schema_reader'class;
Atts : sax_attribute_list)
is
Name : qualified_name;
procedure Add_Union (Str : byte_sequence);
-- Add a unioned type to [Simple]
procedure Add_Union (Str : byte_sequence) is
Sym : constant symbol := Find_Symbol (Handler.all, Str);
Ctx : constant context_access :=
Handler.Contexts (Handler.Contexts_Last)'access;
Name : constant qualified_name :=
Resolve_QName
(Handler,
Sym,
Handler.Target_NS,
Loc => Ctx.Union.Loc);
begin
Add_Type_Member
(Handler,
Ctx.Union.Union_Items,
(Name => Name, Local => No_Internal_Type_Index),
Ctx.Union.Loc);
end Add_Union;
procedure For_Each_Union is new For_Each_Item (Add_Union);
begin
Push_Context
(Handler,
(Typ => context_union,
Union =>
(Kind => simple_type_union,
In_Process => False,
Loc => Handler.Current_Location,
Union_Items => (others => No_Type_Member))));
for J in 1 .. Get_Length (Atts) loop
Name := Get_Name (Atts, J);
if Name.NS = Empty_String then
if Name.Local = Handler.Member_Types then
For_Each_Union (Get (Get_Value (Atts, J)).all);
end if;
end if;
end loop;
end Create_Union;
------------------
-- Finish_Union --
------------------
procedure Finish_Union (Handler : access schema_reader'class) is
Ctx : constant context_access :=
Handler.Contexts (Handler.Contexts_Last)'access;
Next : constant context_access :=
Handler.Contexts (Handler.Contexts_Last - 1)'access;
begin
case Next.Typ is
when context_type_def =>
Handler.Shared.Types.Table (Next.Type_Info).Simple := Ctx.Union;
when others =>
Validation_Error
(Handler,
"Unsupported: ""union"" in this context",
Except => XML_Not_Implemented'identity);
end case;
end Finish_Union;
----------------------
-- Create_Extension --
----------------------
procedure Create_Extension
(Handler : access schema_reader'class;
Atts : sax_attribute_list)
is
Ctx : constant context_access :=
Handler.Contexts (Handler.Contexts_Last)'access;
Ext : extension_descr;
Name : qualified_name;
Details : type_details_access;
In_Type : constant internal_type_index := Ctx.Type_Info;
begin
Ext.Loc := Handler.Current_Location;
for J in 1 .. Get_Length (Atts) loop
Name := Get_Name (Atts, J);
if Name.NS = Empty_String then
if Name.Local = Handler.Base then
Ext.Base :=
Resolve_QName
(Handler,
Get_Value (Atts, J),
Handler.Target_NS,
Loc => Get_Location (Atts, J));
end if;
end if;
end loop;
if Ext.Base = No_Qualified_Name then
Validation_Error
(Handler,
"Attribute ""base"" required for ");
end if;
if Handler.Shared.Types.Table (In_Type).Is_Simple
or else
Handler.Shared.Types.Table (In_Type).Simple.Kind /=
simple_type_none
then
if Debug then
Debug_Output ("Create extension: in simpleContent or simpleType");
end if;
if not Handler.Shared.Types.Table (In_Type).Is_Simple then
Details :=
new type_details'
(Kind => type_extension,
Min_Occurs => (False, 1),
Max_Occurs => (False, 1),
Loc => Handler.Current_Location,
In_Process => False,
Next => null,
Simple_Content => True,
Extension => Ext);
Insert_In_Type (Handler, Details);
end if;
Push_Context
(Handler,
(Typ => context_simple_extension,
Simple =>
(Kind => simple_type_extension,
In_Process => False,
Base => (Name => Ext.Base, Local => No_Internal_Type_Index),
Facets => No_Facets,
Loc => Handler.Current_Location)));
else
Details :=
new type_details'
(Kind => type_extension,
Min_Occurs => (False, 1),
Max_Occurs => (False, 1),
Loc => Handler.Current_Location,
In_Process => False,
Next => null,
Simple_Content => False,
Extension => Ext);
Insert_In_Type (Handler, Details);
Push_Context
(Handler,
(Typ => context_extension, Extension => Details));
end if;
end Create_Extension;
----------------------
-- Finish_Extension --
----------------------
procedure Finish_Extension (Handler : access schema_reader'class) is
Ctx : constant context_access :=
Handler.Contexts (Handler.Contexts_Last)'access;
Next : constant context_access :=
Handler.Contexts (Handler.Contexts_Last - 1)'access;
begin
if Ctx.Typ = context_simple_extension then
pragma assert (Next.Typ = context_type_def); -- a simple type
Handler.Shared.Types.Table (Next.Type_Info).Simple := Ctx.Simple;
end if;
end Finish_Extension;
-----------------
-- Create_List --
-----------------
procedure Create_List
(Handler : access schema_reader'class;
Atts : sax_attribute_list)
is
Name : qualified_name;
begin
Push_Context
(Handler,
(Typ => context_list,
List =>
(Kind => simple_type_list,
In_Process => False,
Loc => Handler.Current_Location,
List_Items => (others => No_Type_Member))));
for J in 1 .. Get_Length (Atts) loop
Name := Get_Name (Atts, J);
if Name.NS = Empty_String then
if Name.Local = Handler.Item_Type then
Name :=
Resolve_QName
(Handler,
Get_Value (Atts, J),
Handler.Target_NS,
Loc => Get_Location (Atts, J));
Add_Type_Member
(Handler,
Handler.Contexts (Handler.Contexts_Last).List.List_Items,
(Name => Name, Local => No_Internal_Type_Index),
Handler.Current_Location);
end if;
end if;
end loop;
end Create_List;
-----------------
-- Finish_List --
-----------------
procedure Finish_List (Handler : access schema_reader'class) is
Ctx : constant context_access :=
Handler.Contexts (Handler.Contexts_Last)'access;
Next : constant context_access :=
Handler.Contexts (Handler.Contexts_Last - 1)'access;
Next_Next : constant context_access :=
Handler.Contexts (Handler.Contexts_Last - 2)'access;
begin
case Next.Typ is
when context_type_def =>
if Next.Type_Info = No_Internal_Type_Index then
-- within a
pragma assert (Next_Next.Typ = context_simple_restriction);
Next_Next.Simple := Ctx.List;
else
-- within a
pragma assert (Next.Type_Info /= No_Internal_Type_Index);
Handler.Shared.Types.Table (Next.Type_Info).Simple := Ctx.List;
end if;
when others =>
Validation_Error
(Handler,
"Unsupported: ""list"" in this context",
Except => XML_Not_Implemented'identity);
end case;
end Finish_List;
--------------------
-- Insert_In_Type --
--------------------
procedure Insert_In_Type
(Handler : access schema_reader'class;
Element : in out type_details_access)
is
procedure Append
(List : in out type_details_access;
Elem : type_details_access);
procedure Append
(List : in out type_details_access;
Elem : type_details_access)
is
Tmp : type_details_access;
begin
if List = null then
List := Elem;
else
Tmp := List;
while Tmp.Next /= null loop
Tmp := Tmp.Next;
end loop;
Tmp.Next := Elem;
end if;
end Append;
Ctx : constant context_access :=
Handler.Contexts (Handler.Contexts_Last)'access;
begin
case Ctx.Typ is
when context_type_def =>
if Handler.Shared.Types.Table (Ctx.Type_Info).Is_Simple then
Free (Element);
Validation_Error (Handler, "Invalid element in simple type");
end if;
if Debug
and then
Handler.Shared.Types.Table (Ctx.Type_Info).Details /=
null
then
Debug_Output
("Insert_In_Type, type already has details " &
" when inserting " &
Element.Kind'img);
end if;
pragma assert
(Handler.Shared.Types.Table (Ctx.Type_Info).Details = null);
Handler.Shared.Types.Table (Ctx.Type_Info).Details := Element;
when context_sequence =>
Append (Ctx.Seq.First_In_Seq, Element);
when context_choice =>
Append (Ctx.Choice.First_In_Choice, Element);
when context_all =>
Append (Ctx.All_Detail.First_In_All, Element);
when context_group =>
if Ctx.Group.Details /= null then
Free (Element);
Validation_Error (Handler, "Invalid element in non group");
end if;
Ctx.Group.Details := Element;
when context_extension =>
if Ctx.Extension.Extension.Details /= null then
Free (Element);
Validation_Error
(Handler,
"Invalid element in non-empty extension");
end if;
Ctx.Extension.Extension.Details := Element;
when context_restriction =>
if Ctx.Restriction.Restriction.Details /= null then
Free (Element);
Validation_Error
(Handler,
"Invalid element in non-empty restriction");
end if;
Ctx.Restriction.Restriction.Details := Element;
when context_simple_restriction | context_simple_extension =>
Free (Element);
when context_schema |
context_attribute |
context_element |
context_union |
context_list |
context_redefine |
context_attribute_group =>
Free (Element);
Validation_Error
(Handler,
"Unsupported: """ &
Element.Kind'img &
""" in context " &
Ctx.Typ'img,
Except => XML_Not_Implemented'identity);
end case;
end Insert_In_Type;
-------------------
-- Create_Choice --
-------------------
procedure Create_Choice
(Handler : access schema_reader'class;
Atts : sax_attribute_list)
is
Min_Occurs, Max_Occurs : occurrences := (False, 1);
Choice : type_details_access;
begin
Get_Occurs (Handler, Atts, Min_Occurs, Max_Occurs);
Choice :=
new type_details'
(Kind => type_choice,
Min_Occurs => Min_Occurs,
Max_Occurs => Max_Occurs,
Loc => Handler.Current_Location,
In_Process => False,
Next => null,
First_In_Choice => null);
Insert_In_Type (Handler, Choice);
Push_Context (Handler, (Typ => context_choice, Choice => Choice));
end Create_Choice;
---------------------
-- Create_Sequence --
---------------------
procedure Create_Sequence
(Handler : access schema_reader'class;
Atts : sax_attribute_list)
is
Min_Occurs, Max_Occurs : occurrences := (False, 1);
Seq : type_details_access;
begin
Get_Occurs (Handler, Atts, Min_Occurs, Max_Occurs);
Seq :=
new type_details'
(Kind => type_sequence,
Min_Occurs => Min_Occurs,
Max_Occurs => Max_Occurs,
Loc => Handler.Current_Location,
In_Process => False,
Next => null,
First_In_Seq => null);
Insert_In_Type (Handler, Seq);
Push_Context (Handler, (Typ => context_sequence, Seq => Seq));
end Create_Sequence;
----------------------
-- Create_Attribute --
----------------------
procedure Create_Attribute
(Handler : access schema_reader'class;
Atts : sax_attribute_list)
is
Name : qualified_name;
Att : attr_descr (Kind => kind_attribute);
Ctx : constant context_access :=
Handler.Contexts (Handler.Contexts_Last)'access;
Has_Form : Boolean := False;
begin
Att.Attr.Descr.Form := Handler.Attribute_Form_Default;
Att.Loc := Handler.Current_Location;
for J in 1 .. Get_Length (Atts) loop
Name := Get_Name (Atts, J);
if Name.NS = Empty_String then
if Name.Local = Handler.Name then
Att.Attr.Descr.Name :=
(NS => Handler.Target_NS, Local => Get_Value (Atts, J));
elsif Name.Local = Handler.Typ then
Att.Attr.Typ :=
Resolve_QName
(Handler,
Get_Value (Atts, J),
Loc => Get_Location (Atts, J));
if Att.Attr.Typ =
(NS => Handler.XML_Schema_URI, Local => Handler.IDREF)
or else
Att.Attr.Typ =
(NS => Handler.XML_Schema_URI, Local => Handler.IDREFS)
then
Validation_Error
(Handler,
"Unsupported type IDREF and IDREFS",
Get_Location (Atts, J),
Except => XML_Not_Implemented'identity);
end if;
elsif Name.Local = Handler.S_Use then
if Get_Value (Atts, J) = Handler.Required then
Att.Attr.Descr.Use_Type := required;
elsif Get_Value (Atts, J) = Handler.Prohibited then
Att.Attr.Descr.Use_Type := prohibited;
else
Att.Attr.Descr.Use_Type := optional;
end if;
elsif Name.Local = Handler.Fixed then
Att.Attr.Descr.Fixed := Get_Value (Atts, J);
elsif Name.Local = Handler.Ref then
Att.Attr.Ref :=
Resolve_QName
(Handler,
Get_Value (Atts, J),
Handler.Target_NS,
Loc => Get_Location (Atts, J));
elsif Name.Local = Handler.Form then
Att.Attr.Descr.Form :=
form_type'value (Get (Get_Value (Atts, J)).all);
Has_Form := True;
elsif Name.Local = Handler.Default then
Att.Attr.Descr.Default := Get_Value (Atts, J);
elsif Name.Local = Handler.Namespace_Target then
Att.Attr.Descr.Target_NS := Get_Value (Atts, J);
end if;
end if;
end loop;
-- See section 3.2.3 for valid attributes combination
if Att.Attr.Descr.Target_NS /= No_Symbol then
if Att.Attr.Descr.Name /= No_Qualified_Name then
Validation_Error
(Handler,
"name must be specified when targetNamespace is specified");
end if;
if Has_Form then
Validation_Error
(Handler,
"Cannot specify ""form"" when targetNamespace is given");
end if;
Validation_Error
(Handler,
"targetNamespace not supported in attribute declaration",
Except => XML_Not_Implemented'identity);
end if;
if Has_Form and then Att.Attr.Ref /= No_Qualified_Name then
Validation_Error
(Handler,
"Attributes ""form"" and ""ref"" cannot be both specified");
end if;
if Att.Attr.Typ /= No_Qualified_Name then
if Att.Attr.Ref /= No_Qualified_Name then
Validation_Error
(Handler,
"Attributes ""type"" and ""ref"" cannot be both specified");
end if;
end if;
if Att.Attr.Descr.Fixed /= No_Symbol
and then Att.Attr.Descr.Default /= No_Symbol
then
Validation_Error
(Handler,
"Attributes ""fixed"" and ""default"" cannot be both specified");
end if;
if Att.Attr.Descr.Default /= No_Symbol
and then Att.Attr.Descr.Use_Type /= optional
then
Validation_Error
(Handler,
"Use must be ""optional"" when a default value is specified");
end if;
if Get_XSD_Version (Handler.Grammar) = xsd_1_1
and then Att.Attr.Descr.Fixed /= No_Symbol
and then Att.Attr.Descr.Use_Type = prohibited
then
Validation_Error
(Handler,
"""prohibited"" is forbidden when" &
" a fixed value is specified");
end if;
if Att.Attr.Descr.Name /= No_Qualified_Name then
case Ctx.Typ is
when context_attribute_group | context_type_def =>
null;
when others =>
if Handler.Target_NS = Handler.XML_Instance_URI then
Validation_Error
(Handler,
"Invalid target namespace for attribute declaration: """ &
Get (Handler.Target_NS).all &
"""");
end if;
end case;
end if;
Att.Attr.Descr.Is_Local := Att.Attr.Ref = No_Qualified_Name;
Push_Context (Handler, (Typ => context_attribute, Attribute => Att));
end Create_Attribute;
----------------------
-- Insert_Attribute --
----------------------
procedure Insert_Attribute
(Handler : access schema_reader'class;
In_Context : Natural;
Attribute : attr_descr)
is
Ctx : context renames Handler.Contexts (In_Context);
Index : Natural;
Ctx2 : context_access;
begin
case Ctx.Typ is
when context_type_def =>
Append
(Handler.Shared.Types.Table (Ctx.Type_Info).Attributes,
Attribute);
when context_schema | context_redefine =>
Set
(Handler.Shared.Global_Attributes,
Attribute.Attr.Descr.Name,
Attribute.Attr);
when context_extension | context_restriction =>
Index := Handler.Contexts_Last;
while Index >= Handler.Contexts'first loop
Ctx2 := Handler.Contexts (Index)'access;
if Ctx2.Typ = context_type_def then
Append
(Handler.Shared.Types.Table (Ctx2.Type_Info).Attributes,
Attribute);
exit;
end if;
Index := Index - 1;
end loop;
when context_simple_extension | context_simple_restriction =>
pragma assert
(Handler.Contexts (In_Context - 1).Typ = context_type_def);
pragma assert -- a cannot have attributes
(not Handler.Shared.Types.Table
(Handler.Contexts (In_Context - 1).Type_Info)
.Is_Simple);
Append
(Handler.Shared.Types.Table
(Handler.Contexts (In_Context - 1).Type_Info)
.Attributes,
Attribute);
when context_attribute_group =>
Append (Ctx.Attr_Group.Attributes, Attribute);
when context_element |
context_sequence |
context_choice |
context_attribute |
context_all |
context_union |
context_list |
context_group =>
Validation_Error
(Handler,
"Unsupported: ""attribute"" in this context",
Except => XML_Not_Implemented'identity);
end case;
end Insert_Attribute;
----------------------
-- Finish_Attribute --
----------------------
procedure Finish_Attribute (Handler : access schema_reader'class) is
Ctx : constant context_access :=
Handler.Contexts (Handler.Contexts_Last)'access;
begin
Insert_Attribute (Handler, Handler.Contexts_Last - 1, Ctx.Attribute);
end Finish_Attribute;
-------------------
-- Create_Schema --
-------------------
procedure Create_Schema
(Handler : access schema_reader'class;
Atts : sax_attribute_list)
is
Info : schema_descr;
Is_Set : Boolean := False;
Name : qualified_name;
begin
Info.Element_Form_Default := unqualified;
Info.Attribute_Form_Default := unqualified;
for J in 1 .. Get_Length (Atts) loop
Name := Get_Name (Atts, J);
if Name.NS = Empty_String then
if Name.Local = Handler.S_Element_Form_Default then
Info.Element_Form_Default := Compute_Form (Atts, Handler, J);
elsif Name.Local = Handler.S_Attribute_Form_Default then
Info.Attribute_Form_Default := Compute_Form (Atts, Handler, J);
elsif Name.Local = Handler.Block_Default then
Compute_Blocks (Atts, Handler, Info.Block, Is_Set, J);
elsif Name.Local = Handler.Namespace_Target then
Info.Target_NS := Get_Value (Atts, J);
end if;
elsif Name.NS = Handler.XML_Instance_URI then
if Name.Local = Handler.No_Namespace_Schema_Location then
-- Already handled through Hook_Start_Element when validating
-- the grammar itself, but needed if we do not validate the
-- grammar
Parse_Grammar
(Handler,
URI => Empty_String,
Xsd_File => Get_Value (Atts, J),
Do_Create_NFA => False);
elsif Name.Local = Handler.Schema_Location then
-- Already handled through Hook_Start_Element when validating
-- the grammar itself
Parse_Grammars
(Handler,
Get_Value (Atts, J),
Do_Create_NFA => False);
end if;
end if;
end loop;
if Info.Target_NS /= No_Symbol then
if Debug then
Output_Action
("Get_NS (Handler.Created_Grammar, """ &
Get (Info.Target_NS).all &
""", Handler.Target_NS)");
end if;
Handler.Target_NS := Info.Target_NS;
end if;
Handler.Element_Form_Default := Info.Element_Form_Default;
Handler.Attribute_Form_Default := Info.Attribute_Form_Default;
if Is_Set then
Handler.Target_Block_Default := Info.Block;
end if;
Push_Context (Handler, (Typ => context_schema));
end Create_Schema;
--------------------------------
-- Process_Contents_From_Atts --
--------------------------------
function Process_Contents_From_Atts
(Handler : access schema_reader'class;
Atts : sax_attribute_list;
Index : Integer) return process_contents_type
is
begin
if Get_Value (Atts, Index) = Handler.Lax then
return process_lax;
elsif Get_Value (Atts, Index) = Handler.Strict then
return process_strict;
else
return process_skip;
end if;
end Process_Contents_From_Atts;
----------------
-- Create_Any --
----------------
procedure Create_Any
(Handler : access schema_reader'class;
Atts : sax_attribute_list)
is
Details : type_details_access;
Any : internal_any_descr;
Name : qualified_name;
Min_Occurs, Max_Occurs : occurrences := (False, 1);
begin
Any.Target_NS := Handler.Target_NS;
Any.Namespaces := Handler.Any_Namespace;
for J in 1 .. Get_Length (Atts) loop
Name := Get_Name (Atts, J);
if Name.NS = Empty_String then
if Name.Local = Handler.Namespace then
Any.Namespaces := Get_Value (Atts, J);
elsif Name.Local = Handler.Process_Contents then
Any.Process_Contents :=
Process_Contents_From_Atts (Handler, Atts, J);
end if;
end if;
end loop;
Get_Occurs (Handler, Atts, Min_Occurs, Max_Occurs);
Details :=
new type_details'
(Kind => type_any,
Min_Occurs => Min_Occurs,
Max_Occurs => Max_Occurs,
Loc => Handler.Current_Location,
In_Process => False,
Next => null,
Any => Any);
Insert_In_Type (Handler, Details);
end Create_Any;
----------------
-- Create_All --
----------------
procedure Create_All
(Handler : access schema_reader'class;
Atts : sax_attribute_list)
is
Min_Occurs, Max_Occurs : occurrences := (False, 1);
Details : type_details_access;
begin
Get_Occurs (Handler, Atts, Min_Occurs, Max_Occurs);
Details :=
new type_details'
(Kind => type_all,
Min_Occurs => Min_Occurs,
Max_Occurs => Max_Occurs,
Loc => Handler.Current_Location,
In_Process => False,
Next => null,
First_In_All => null);
Insert_In_Type (Handler, Details);
Push_Context (Handler, (Typ => context_all, All_Detail => Details));
end Create_All;
-------------------
-- Start_Element --
-------------------
overriding procedure Start_Element
(Handler : in out schema_reader;
NS : Sax.Utils.xml_ns;
Local_Name : Sax.Symbols.symbol;
Atts : Sax.Readers.sax_attribute_list)
is
H : constant schema_reader_access := Handler'unchecked_access;
Ctx : context_access;
begin
if Debug then
Output_Seen
("Start " &
Get (Local_Name).all &
" at " &
To_String (Handler.Current_Location));
end if;
-- Check the grammar
Start_Element (validating_reader (Handler), NS, Local_Name, Atts);
-- Process the element
if Handler.Contexts = null then
if Local_Name /= Handler.S_Schema then
Validation_Error (H, "Root element must be ");
end if;
Create_Schema (H, Atts);
elsif Local_Name = Handler.Annotation then
Handler.In_Annotation := True;
elsif Local_Name = Handler.Notation then
Create_Notation (H, Atts);
elsif Local_Name = Handler.Element then
Create_Element (H, Atts);
elsif Local_Name = Handler.Complex_Type then
Create_Complex_Type (H, Atts);
elsif Local_Name = Handler.Simple_Type then
Create_Simple_Type (H, Atts);
elsif Local_Name = Handler.Restriction then
Create_Restriction (H, Atts);
elsif Local_Name = Handler.Extension then
Create_Extension (H, Atts);
elsif Local_Name = Handler.Any_Attribute then
Create_Any_Attribute (H, Atts);
elsif Local_Name = Handler.Pattern then
Ctx := Handler.Contexts (Handler.Contexts_Last)'access;
pragma assert (Ctx.Typ = context_simple_restriction);
pragma assert (Ctx.Simple.Kind = simple_type_restriction);
-- Use the non-normalized value for
Add_Facet
(Grammar => Handler.Grammar,
Facets => Ctx.Simple.Facets,
Facet_Name => Local_Name,
Value =>
Get_Non_Normalized_Value
(Atts,
Get_Index (Atts, Empty_String, Handler.Value)),
Loc => Handler.Current_Location);
elsif Local_Name = Handler.Maxlength
or else Local_Name = Handler.Minlength
or else Local_Name = Handler.Length
or else Local_Name = Handler.Enumeration
or else Local_Name = Handler.Whitespace
or else Local_Name = Handler.Total_Digits
or else Local_Name = Handler.Fraction_Digits
or else Local_Name = Handler.MaxInclusive
or else Local_Name = Handler.MaxExclusive
or else Local_Name = Handler.MinInclusive
or else Local_Name = Handler.MinExclusive
then
Ctx := Handler.Contexts (Handler.Contexts_Last)'access;
pragma assert (Ctx.Typ = context_simple_restriction);
pragma assert (Ctx.Simple.Kind = simple_type_restriction);
Add_Facet
(Grammar => Handler.Grammar,
Facets => Ctx.Simple.Facets,
Facet_Name => Local_Name,
Value =>
Get_Value (Atts, Get_Index (Atts, Empty_String, Handler.Value)),
Loc => Handler.Current_Location);
elsif Local_Name = Handler.S_All then
Create_All (H, Atts);
elsif Local_Name = Handler.Sequence then
Create_Sequence (H, Atts);
elsif Local_Name = Handler.Choice then
Create_Choice (H, Atts);
elsif Local_Name = Handler.List then
Create_List (H, Atts);
elsif Local_Name = Handler.Union then
Create_Union (H, Atts);
elsif Local_Name = Handler.Attribute then
Create_Attribute (H, Atts);
elsif Local_Name = Handler.Group then
Create_Group (H, Atts);
elsif Local_Name = Handler.Simple_Content then
Ctx := Handler.Contexts (Handler.Contexts_Last)'access;
pragma assert (Ctx.Typ = context_type_def);
Handler.Shared.Types.Table (Ctx.Type_Info).Simple :=
(Kind => simple_type,
In_Process => False,
Loc => Handler.Current_Location);
Handler.Shared.Types.Table (Ctx.Type_Info).Properties.Mixed := True;
elsif Local_Name = Handler.Complex_Content then
Ctx := Handler.Contexts (Handler.Contexts_Last)'access;
pragma assert (Ctx.Typ = context_type_def);
-- Do not reset Properties.Mixed here, since it might have been set
-- to "true" on the parent node.
elsif Local_Name = Handler.Attribute_Group then
Create_Attribute_Group (H, Atts);
elsif Local_Name = Handler.Any then
Create_Any (H, Atts);
elsif Local_Name = Handler.Redefine then
Validation_Error
(Handler'access,
"Unsupported ",
Except => XML_Not_Implemented'identity);
Create_Redefine (H, Atts);
elsif Local_Name = Handler.Include then
Create_Include (H, Atts);
elsif Local_Name = Handler.Import then
Create_Import (H, Atts);
elsif Handler.In_Annotation then
null; -- ignore all tags
elsif Handler.Feature_Ignore_Unsupported_XSD_Elements
and then
(Local_Name = Handler.Keyref
or else Local_Name = Handler.Key
or else Local_Name = Handler.Selector
or else Local_Name = Handler.Unique
or else Local_Name = Handler.Field)
then
Warning
(Handler,
Create
(Message =>
"Unsupported element in the schema: " & Get (Local_Name).all,
Loc => Handler.Current_Location));
else
Validation_Error
(Handler'access,
"Unsupported element in the schema: " & Get (Local_Name).all,
Except => XML_Not_Implemented'identity);
end if;
end Start_Element;
-----------------
-- End_Element --
-----------------
overriding procedure End_Element
(Handler : in out schema_reader;
NS : Sax.Utils.xml_ns;
Local_Name : Sax.Symbols.symbol)
is
H : constant schema_reader_access := Handler'unchecked_access;
Handled : Boolean := True;
begin
-- Check the grammar
End_Element (validating_reader (Handler), NS, Local_Name);
-- Process the tag
if Local_Name = Handler.Element then
Finish_Element (H);
elsif Local_Name = Handler.S_Schema then
null;
elsif Local_Name = Handler.Complex_Type then
Finish_Complex_Type (H);
elsif Local_Name = Handler.Simple_Type then
Finish_Simple_Type (H);
elsif Local_Name = Handler.S_All then
null;
elsif Local_Name = Handler.Sequence then
null;
elsif Local_Name = Handler.Any_Attribute then
Handled := False;
elsif Local_Name = Handler.Choice then
null;
elsif Local_Name = Handler.Restriction then
Finish_Restriction (H);
elsif Local_Name = Handler.Extension then
Finish_Extension (H);
elsif Local_Name = Handler.Attribute then
Finish_Attribute (H);
elsif Local_Name = Handler.Union then
Finish_Union (H);
elsif Local_Name = Handler.List then
Finish_List (H);
elsif Local_Name = Handler.Maxlength
or else Local_Name = Handler.Pattern
or else Local_Name = Handler.Minlength
or else Local_Name = Handler.Enumeration
or else Local_Name = Handler.Whitespace
or else Local_Name = Handler.Total_Digits
or else Local_Name = Handler.Fraction_Digits
or else Local_Name = Handler.MaxInclusive
or else Local_Name = Handler.MaxExclusive
or else Local_Name = Handler.MinInclusive
or else Local_Name = Handler.MinExclusive
then
Handled := False;
elsif Local_Name = Handler.Attribute_Group then
Finish_Attribute_Group (H);
elsif Local_Name = Handler.Redefine then
null;
elsif Local_Name = Handler.Group then
Finish_Group (H);
elsif Local_Name = Handler.Any
or else Local_Name = Handler.Include
or else Local_Name = Handler.Import
or else Local_Name = Handler.Simple_Content
or else Local_Name = Handler.Complex_Content
then
Handled := False;
elsif Local_Name = Handler.Annotation then
Handler.In_Annotation := False;
Handled := False;
else
if Debug then
Output_Action
("Close tag not handled yet: " & Get (Local_Name).all);
end if;
Handled := False;
end if;
-- Release the context
if Handled then
Handler.Contexts_Last := Handler.Contexts_Last - 1;
end if;
end End_Element;
----------------
-- Characters --
----------------
procedure Characters
(Handler : in out schema_reader;
Ch : Unicode.CES.byte_sequence)
is
begin
Characters (validating_reader (Handler), Ch);
end Characters;
----------
-- Free --
----------
procedure Free (Self : in out type_details_access) is
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(type_details,
type_details_access);
Next : type_details_access;
begin
while Self /= null loop
Next := Self.Next;
case Self.Kind is
when type_empty | type_element | type_any =>
null;
when type_sequence =>
Free (Self.First_In_Seq);
when type_choice =>
Free (Self.First_In_Choice);
when type_all =>
Free (Self.First_In_All);
when type_group =>
Free (Self.Group.Details);
when type_extension =>
Free (Self.Extension.Details);
when type_restriction =>
Free (Self.Restriction.Details);
end case;
Unchecked_Free (Self);
Self := Next;
end loop;
end Free;
-----------------
-- Set_Feature --
-----------------
overriding procedure Set_Feature
(Parser : in out schema_reader;
Name : String;
Value : Boolean)
is
begin
if Name = Feature_Ignore_Unsupported_XSD_Elements then
Parser.Feature_Ignore_Unsupported_XSD_Elements := Value;
else
Set_Feature (validating_reader (Parser), Name, Value);
end if;
end Set_Feature;
-----------------
-- Get_Feature --
-----------------
overriding function Get_Feature
(Parser : schema_reader;
Name : String) return Boolean
is
begin
if Name = Feature_Ignore_Unsupported_XSD_Elements then
return Parser.Feature_Ignore_Unsupported_XSD_Elements;
else
return Get_Feature (validating_reader (Parser), Name);
end if;
end Get_Feature;
end Schema.Schema_Readers;