------------------------------------------------------------------------------
-- 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 --
-- . --
-- --
------------------------------------------------------------------------------
-- 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
procedure Parse_Grammar
(Handler : access Schema.Readers.validating_reader'class;
URI : Sax.Symbols.symbol;
Xsd_File : Sax.Symbols.symbol;
Do_Create_NFA : Boolean);
-- Parse (if not done already) the specified [Xsd_File], and associate it
-- with the given namespace [URI].
-- [Handler] is used to convert [Xsd_File] to an absolute URI, and find
-- the 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 , ,...) 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.
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
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 or the internal
--
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
-- for instance.
In_Annotation : Boolean := False;
-- Whether we are processing an 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;