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

395 lines
17 KiB
Ada
Raw Permalink Blame History

------------------------------------------------------------------------------
-- XML/Ada - An XML suite for Ada95 --
-- --
-- Copyright (C) 2004-2017, AdaCore --
-- --
-- This library is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
-- Software Foundation; either version 3, or (at your option) any later --
-- version. This library is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
------------------------------------------------------------------------------
-- This package provides a SAX Reader that parses an XML Schema file, and
-- creates the appropriate data structure
pragma Ada_05;
with Input_Sources;
with Sax.Locators;
with Sax.Readers; use Sax.Readers;
with Sax.Symbols;
with Sax.Utils;
with Schema.Readers;
with Schema.Simple_Types;
with Schema.Validators;
with Unicode.CES;
with GNAT.Dynamic_Tables;
with GNAT.Dynamic_HTables;
package Schema.Schema_Readers is
type Schema_Reader is new Schema.Readers.Validating_Reader with private;
type Schema_Reader_Access is access all Schema_Reader'Class;
-- An XML reader that parses an XML schema, and store the information in
-- a grammar
overriding procedure Set_Feature
(Parser : in out Schema_Reader; Name : String; Value : Boolean);
overriding function Get_Feature
(Parser : Schema_Reader; Name : String) return Boolean;
-- Add support for new features
Feature_Ignore_Unsupported_XSD_Elements : constant String :=
"http://www.adacore.com/schema/features/ignoreUnsupportedXSDElements";
-- If this feature is true, then elements from an XSD file that are known
-- to be unsupported by XML/Ada (for instance <key>, <keyref>,...) will
-- result in a warning, rather than a fatal error.
-- As a user, you are free to ignore these. XML/Ada will simply not provide
-- validation for those elements.
procedure Parse_Grammar_If_Needed
(Handler : not null access Schema.Readers.Validating_Reader'Class;
URI : Sax.Symbols.Symbol;
Xsd_File : Sax.Symbols.Symbol;
Do_Create_NFA : Boolean);
-- See Schema.Readers.Parse_Grammar.
-- This procedure provides the default implementation, which will always
-- check whether the Xsd_File was already loaded in Handler.Get_Grammar,
-- and if not will parse it.
-- Do not call this procedure directly. Instead, call Parse_Grammar.
private
use Schema.Validators;
type Internal_Type_Index is new Integer;
No_Internal_Type_Index : constant Internal_Type_Index := -1;
type Type_Kind is (Type_Empty, Type_Sequence, Type_Choice, Type_Element,
Type_Any, Type_Group, Type_Extension, Type_Restriction,
Type_All);
type Type_Details;
type Type_Details_Access is access all Type_Details;
type Element_Descr is record
Name : Qualified_Name := No_Qualified_Name;
Typ : Qualified_Name := No_Qualified_Name;
Local_Type : Internal_Type_Index := No_Internal_Type_Index;
Ref : Qualified_Name := No_Qualified_Name;
Form : Form_Type := Unqualified;
Default : Sax.Symbols.Symbol := Sax.Symbols.No_Symbol;
Fixed : Sax.Symbols.Symbol := Sax.Symbols.No_Symbol;
Substitution_Group : Qualified_Name := No_Qualified_Name;
Final : Final_Status := (others => False);
Block : Block_Status := (others => False);
Is_Abstract : Boolean := False;
Nillable : Boolean := False;
Has_Block : Boolean := False;
Loc : Sax.Locators.Location := Sax.Locators.No_Location;
S : Schema_State_Machines.State :=
Schema_State_Machines.No_State;
end record;
No_Element_Descr : constant Element_Descr := (others => <>);
type Group_Descr is record
Name : Qualified_Name := No_Qualified_Name;
Ref : Qualified_Name := No_Qualified_Name;
Details : Type_Details_Access;
Loc : Sax.Locators.Location;
end record;
No_Group_Descr : constant Group_Descr := (others => <>);
type Internal_Attribute_Descr is record
Descr : Attribute_Descr := No_Attribute_Descr;
Typ : Qualified_Name := No_Qualified_Name;
Local_Type : Internal_Type_Index := No_Internal_Type_Index;
Ref : Qualified_Name := No_Qualified_Name;
Any : Internal_Any_Descr := No_Internal_Any_Descr;
-- For the handling of <anyAttribute>
end record;
No_Internal_Attribute : constant Internal_Attribute_Descr := (others => <>);
type Attr_Descr_Kind is (Kind_Group, Kind_Attribute, Kind_Unset);
type Attr_Descr (Kind : Attr_Descr_Kind := Kind_Unset) is record
Loc : Sax.Locators.Location := Sax.Locators.No_Location;
case Kind is
when Kind_Unset => null;
when Kind_Group => Group_Ref : Qualified_Name;
when Kind_Attribute => Attr : Internal_Attribute_Descr;
end case;
end record;
type Attr_Array is array (Natural range <>) of Attr_Descr;
type Attr_Array_Access is access all Attr_Array;
type AttrGroup_Descr is record
Name : Qualified_Name := No_Qualified_Name;
Ref : Qualified_Name := No_Qualified_Name;
Attributes : Attr_Array_Access;
end record;
No_AttrGroup_Descr : constant AttrGroup_Descr := (others => <>);
type Extension_Descr is record
Base : Qualified_Name := No_Qualified_Name;
Details : Type_Details_Access;
Loc : Sax.Locators.Location;
end record;
-- Attributes are set in the corresponding Internal_Type_Descr
type Restriction_Descr is record
Base : Qualified_Name := No_Qualified_Name;
Details : Type_Details_Access;
Loc : Sax.Locators.Location;
end record;
-- Attributes are set in the corresponding Internal_Type_Descr
type Type_Details (Kind : Type_Kind := Type_Empty) is record
In_Process : Boolean := False;
-- Set to true while we are creating the NFA for this details. This is
-- used to prevent infinite recursion, for instance when an extension
-- indirectly uses itself as a base.
Loc : Sax.Locators.Location;
Min_Occurs, Max_Occurs : Occurrences;
Next : Type_Details_Access;
case Kind is
when Type_Empty => null;
when Type_Sequence => First_In_Seq : Type_Details_Access;
when Type_Choice => First_In_Choice : Type_Details_Access;
when Type_Element => Element : Element_Descr;
when Type_Any => Any : Internal_Any_Descr;
when Type_Group => Group : Group_Descr;
when Type_Extension =>
Extension : Extension_Descr;
Simple_Content : Boolean;
when Type_Restriction =>
Restriction : Restriction_Descr;
Simple_Content_Restriction : Boolean;
when Type_All => First_In_All : Type_Details_Access;
end case;
end record;
type Type_Member is record
Name : Qualified_Name := No_Qualified_Name;
Local : Internal_Type_Index := No_Internal_Type_Index;
end record;
No_Type_Member : constant Type_Member :=
(No_Qualified_Name, No_Internal_Type_Index);
-- Only one of the two fields is set. These are the possible members of a
-- union or list.
type Type_Member_Array is array (Natural range <>) of Type_Member;
type Simple_Type_Kind is (Simple_Type_None,
Simple_Type,
Simple_Type_Restriction,
Simple_Type_Extension,
Simple_Type_Union,
Simple_Type_List);
type Internal_Simple_Type_Descr (Kind : Simple_Type_Kind := Simple_Type)
is record
In_Process : Boolean := False;
-- Used to prevent infinite recursion when for instance a union's member
-- is derived from this union.
Loc : Sax.Locators.Location := Sax.Locators.No_Location;
case Kind is
when Simple_Type_None => null;
when Simple_Type => null;
when Simple_Type_Union =>
Union_Items : Type_Member_Array
(1 .. Schema.Simple_Types.Max_Types_In_Union) :=
(others => No_Type_Member);
when Simple_Type_List =>
List_Items : Type_Member_Array
(1 .. 1) := (others => No_Type_Member);
when Simple_Type_Restriction | Simple_Type_Extension =>
Base : Type_Member;
Facets : Schema.Simple_Types.All_Facets :=
Schema.Simple_Types.No_Facets;
end case;
end record;
No_Internal_Simple_Type_Descr : constant Internal_Simple_Type_Descr :=
(Kind => Simple_Type_None, others => <>);
subtype Union_Type_Descr is Internal_Simple_Type_Descr (Simple_Type_Union);
subtype List_Type_Descr is Internal_Simple_Type_Descr (Simple_Type_List);
type Internal_Type_Descr (Is_Simple : Boolean := False) is record
Properties : Type_Descr; -- Properties of the type, read in XSD
In_NFA : Type_Index; -- As created in the NFA
Loc : Sax.Locators.Location := Sax.Locators.No_Location;
Simple : Internal_Simple_Type_Descr :=
No_Internal_Simple_Type_Descr;
-- Either the type itself if we are defining a simpleType, or its
-- simpleContent if we are definiting a complexType (in which case its
-- kind might be [Simple_Type_None] to indicate it is a complex content
case Is_Simple is
when False =>
Attributes : Attr_Array_Access;
-- Stores attributes from <complexType> or the internal
-- <extension>
Details : Type_Details_Access;
when True =>
null;
end case;
end record;
-- Temporary structure while parsing a XSD file. Only [Descr] will be
-- stored in the NFA for reuse while validating (or while parsing other
-- XSD).
type Schema_Descr is record
Target_NS : Sax.Symbols.Symbol := Sax.Symbols.No_Symbol;
Block : Block_Status := No_Block;
Element_Form_Default : Form_Type := Unqualified;
Attribute_Form_Default : Form_Type := Unqualified;
end record;
type Context_Type is (Context_Type_Def,
Context_Element,
Context_Sequence,
Context_Choice,
Context_Schema,
Context_Restriction,
Context_Simple_Restriction, -- simpleType
Context_Simple_Extension, -- simpleType
Context_Extension,
Context_All,
Context_List,
Context_Union,
Context_Redefine,
Context_Group,
Context_Attribute_Group,
Context_Attribute);
type Context (Typ : Context_Type := Context_Schema) is record
case Typ is
when Context_Type_Def => Type_Info : Internal_Type_Index;
when Context_Element =>
Element : Element_Descr;
Elem_Details : Type_Details_Access;
when Context_Sequence => Seq : Type_Details_Access;
when Context_Choice => Choice : Type_Details_Access;
when Context_All => All_Detail : Type_Details_Access;
when Context_Attribute_Group => Attr_Group : AttrGroup_Descr;
when Context_Schema => null;
when Context_Redefine => null;
when Context_Group => Group : Group_Descr;
when Context_Extension => Extension : Type_Details_Access;
when Context_List => List : List_Type_Descr;
when Context_Restriction => Restriction : Type_Details_Access;
when Context_Simple_Restriction | Context_Simple_Extension =>
Simple : Internal_Simple_Type_Descr;
when Context_Union => Union : Union_Type_Descr;
when Context_Attribute => Attribute : Attr_Descr;
end case;
end record;
type Context_Access is access all Context;
type Context_Array is array (Natural range <>) of aliased Context;
type Context_Array_Access is access all Context_Array;
package Type_Tables is new GNAT.Dynamic_Tables
(Table_Component_Type => Internal_Type_Descr,
Table_Index_Type => Internal_Type_Index,
Table_Low_Bound => 1,
Table_Initial => 200,
Table_Increment => 100);
package Element_HTables is new GNAT.Dynamic_HTables.Simple_HTable
(Header_Num => Header_Num,
Element => Element_Descr,
No_Element => No_Element_Descr,
Key => Qualified_Name,
Hash => Hash,
Equal => "=");
package Group_HTables is new GNAT.Dynamic_HTables.Simple_HTable
(Header_Num => Header_Num,
Element => Group_Descr,
No_Element => No_Group_Descr,
Key => Qualified_Name,
Hash => Hash,
Equal => "=");
package AttrGroup_HTables is new GNAT.Dynamic_HTables.Simple_HTable
(Header_Num => Header_Num,
Element => AttrGroup_Descr,
No_Element => No_AttrGroup_Descr,
Key => Qualified_Name,
Hash => Hash,
Equal => "=");
package Attribute_HTables is new GNAT.Dynamic_HTables.Simple_HTable
(Header_Num => Header_Num,
Element => Internal_Attribute_Descr,
No_Element => No_Internal_Attribute,
Key => Qualified_Name,
Hash => Hash,
Equal => "=");
type XSD_Data is record
Types : Type_Tables.Instance;
Global_Elements : Element_HTables.Instance;
Global_Groups : Group_HTables.Instance;
Global_AttrGroups : AttrGroup_HTables.Instance;
Global_Attributes : Attribute_HTables.Instance;
end record;
type XSD_Data_Access is access all XSD_Data;
-- Data modified while loading XSD, and needed while loading nested (input
-- or redefine) XSD, until we can create the NFA
type Schema_Reader is new Schema.Readers.Validating_Reader with record
Attribute_Form_Default : Schema.Validators.Form_Type :=
Schema.Validators.Unqualified;
Element_Form_Default : Schema.Validators.Form_Type :=
Schema.Validators.Unqualified;
-- The value of elementFormDefault for the current file
Feature_Ignore_Unsupported_XSD_Elements : Boolean := False;
Target_NS : Sax.Symbols.Symbol;
Target_Block_Default : Block_Status := No_Block;
-- The namespace for which we are currently parsing. This might be
-- different from Get_Target_NS (Created_Grammar) when processing
-- <import> for instance.
In_Annotation : Boolean := False;
-- Whether we are processing an <annotation> node, in which case we
-- need to ignore all children
Contexts : Context_Array_Access;
Contexts_Last : Natural := 0;
Shared : XSD_Data_Access;
end record;
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);
overriding procedure End_Element
(Handler : in out Schema_Reader;
NS : Sax.Utils.XML_NS;
Local_Name : Sax.Symbols.Symbol);
overriding procedure Characters
(Handler : in out Schema_Reader; Ch : Unicode.CES.Byte_Sequence);
overriding procedure Parse
(Parser : in out Schema_Reader;
Input : in out Input_Sources.Input_Source'Class);
-- See inherited documentation
end Schema.Schema_Readers;
Reference in New Issue View Git Blame Copy Permalink