------------------------------------------------------------------------------ -- 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;