------------------------------------------------------------------------------ -- 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; with GNAT.Dynamic_Tables; with Interfaces; with Unicode.CES; with Sax.HTable; with Sax.Locators; with Sax.Pointers; with Sax.Readers; use Sax.Readers; with Sax.State_Machines; with Sax.Symbols; with Sax.Utils; with Schema.Simple_Types; package Schema.Validators is XML_Schema_URI : constant Unicode.CES.byte_sequence := "http://www.w3.org/2001/XMLSchema"; XML_URI : constant Unicode.CES.byte_sequence := "http://www.w3.org/XML/1998/namespace"; XML_Instance_URI : constant Unicode.CES.byte_sequence := "http://www.w3.org/2001/XMLSchema-instance"; XML_Validation_Error : exception; -- Raised in case of error in the validation process. The exception message -- contains the error, but not its location type xsd_versions is (xsd_1_0, xsd_1_1); -- The version of XSD the parser should support. -- The support for 1.1 is only partial at present. type xml_grammar is private; -- A grammar can contain the definition for multiple namespaces (generally -- the standard XML Schema namespace for predefined types, and the -- namespace we are defining). -- A grammar is a smart pointer, and will take care of freeing memory -- automatically when no longer needed. procedure Set_XSD_Version (Grammar : in out xml_grammar; XSD_Version : xsd_versions); function Get_XSD_Version (Grammar : xml_grammar) return xsd_versions; -- Set the version of XSD accepted by this grammar function Get_Symbol_Table (Grammar : xml_grammar) return Sax.Utils.symbol_table; procedure Set_Symbol_Table (Grammar : xml_grammar; Symbols : Sax.Utils.symbol_table); -- The symbol table used to create the grammar. -- Any parser using this grammmar must also use the same symbol table, -- otherwise no validation can succeed (this is ensured by special tests in -- Set_Grammar and Set_Symbol_Table). No_Grammar : constant xml_grammar; -- No Grammar has been defined type occurrences (Unbounded : Boolean := False) is record case Unbounded is when True => null; when False => Value : Natural; end case; end record; -- The number of occurrences type form_type is (qualified, unqualified); -- Whether locally declared elements need to be qualified or whether -- qualification is optional (the latter is the default). This does not -- apply to global elements, that always need to be qualified (or found in -- the default namespace). -- Note that elements defined in a are considered local only if -- they do not use the R.Ref attribute, otherwise they are considered -- global and therefore the "form" does not apply to them. type process_contents_type is (process_strict, process_lax, process_skip); -- When in an element that accepts any children (ur-type, or xsd:any), this -- type indicates that should be done to validate the children: -- Strict: the children must have a definition in the schema (as a -- global element) -- Lax: if the children have a definition, it is used, otherwise they -- are just accepted as is. -- Skip: even if the children have a definition, it is ignored, and -- the child is processed as a ur-type. -------------------- -- State machines -- -------------------- -- The validators are implemented as state machines type header_num is new Interfaces.Integer_32 range 0 .. 1023; function Hash (Name : qualified_name) return header_num; function Hash (Name : Sax.Symbols.symbol) return header_num; -- Suitable for instantiating hash tables type any_descr is record Process_Contents : process_contents_type := process_strict; No_Namespaces : Sax.Symbols.symbol := Sax.Symbols.No_Symbol; Namespaces : Sax.Symbols.symbol := Sax.Symbols.No_Symbol; -- The combined list of namespaces. This could include ##any and -- ##local, since there is no way to represent them otherwise, but will -- not include ##targetNamespace which must be resolved first. -- No_Namespaces is the list of namespaces we must not match, and -- replaces the use of ##other in the list of namespaces. (note that if -- a namespace matches [Namespaces], it will match even if it is in -- [No_Namespaces]. -- -- Combining : -- - when we have an extension, we must match any of the namespaces -- either from the base or from the extension. -- - when we have a restriction, we restrict the list of valid -- namespaces. end record; No_Any_Descr : constant any_descr := (others => <>); function Combine (Grammar : xml_grammar; Base_Any : any_descr; Local_Process : process_contents_type; Local : Sax.Symbols.symbol; -- includes ##other As_Restriction : Boolean; Target_NS : Sax.Symbols.symbol) return any_descr; -- Combines [Base_Any] and [Local_Any] into a single one. -- [Base_Any] can be No_Any_Descr if we simply want to resolve -- ##targetNamespace and ##other in [Local_Any] function Match_Any (Any : any_descr; Name : qualified_name) return Boolean; -- Whether [Name] matches the namespaces in [Any] type transition_event is record Name : qualified_name; Closing : Boolean := False; end record; -- The event to do a transition in the state machine. -- [Closing] is set to true if we are seeing the end tag for [Name] type transition_kind is (transition_symbol, transition_any, transition_close, transition_symbol_from_all, transition_close_from_all); -- Transition_*_From_All is used to support the construct without -- creating a set of states for all possible permuations of child elements -- (since otherwise the number of states explodes). Instead, an node -- has one output transition per possible child elements (these transitions -- are Transition_Symbol_From_All). These transitions are disabled once -- they have been visited (since maxOccurs=1 for children of ) and -- cannot be visited again. The state also has one output transition -- to the next state. This transition is also conditional: it will be on -- active on any symbol, provided that all children of have been -- visited once or have minOccurs=0. -- This also requires temporary data associated with all active instances -- of the state in the Matcher, to remember which children have been -- visited. type visited_all_children is mod 2**32; -- A mask for the children of an element that have been visited. -- Such children can be visited at most once. In the transition, we store -- the mask for all such children that must be visited (the optional ones -- have a 0 in the mask). In the Matcher, we also store this info in the -- node itself to make sure that children are not visited more than -- once. type transition_descr (Kind : transition_kind := transition_symbol) is record case Kind is when transition_symbol | transition_symbol_from_all => Name : qualified_name; Form : form_type := qualified; -- For nodes: the index of this transition in the mask -- (Visited_All_Children) for . This is used to memorize -- which children have already been visited. All_Child_Index : Integer; when transition_close_from_all => Mask : visited_all_children := 0; when transition_close => null; when transition_any => Any : any_descr; end case; end record; type named_attribute_list is new Natural; Empty_Named_Attribute_List : constant named_attribute_list := 0; type attributes_list is record Any : any_descr := No_Any_Descr; Named : named_attribute_list := Empty_Named_Attribute_List; end record; No_Attributes : constant attributes_list := (others => <>); -- All types are assumed to have a even if it never -- accepts anything. For an extension or restriction, it is merged with the -- base's type block_type is (block_restriction, block_extension, block_substitution); type block_status is array (block_type) of Boolean; pragma pack (block_status); No_Block : constant block_status := (others => False); function To_String (Blocks : block_status) return String; -- Return a displayable version of [Blocks], for debugging purposes. type final_type is (final_restriction, final_extension, final_union, final_list); type final_status is array (final_type) of Boolean; pragma pack (final_status); type type_index is new Natural; No_Type_Index : constant type_index := 0; -- Index into a global table that contains the [Type_Descr]. -- Going through a table instead of storing directly a [Type_Descr] (for -- instance in NFA states) reduces memory usage, but more importantly -- means that we can modify the type even once the NFA has been created, -- and still impact all states that reference that type. type attribute_use_type is (prohibited, optional, required, default); type attribute_descr is record Target_NS : Sax.Symbols.symbol := Sax.Symbols.No_Symbol; Name : qualified_name := No_Qualified_Name; Simple_Type : Schema.Simple_Types.simple_type_index := Schema.Simple_Types.No_Simple_Type_Index; Fixed : Sax.Symbols.symbol := Sax.Symbols.No_Symbol; Default : Sax.Symbols.symbol := Sax.Symbols.No_Symbol; Use_Type : attribute_use_type := optional; Form : form_type := qualified; Is_Local : Boolean := True; Next : named_attribute_list := Empty_Named_Attribute_List; end record; pragma pack (attribute_descr); No_Attribute_Descr : constant attribute_descr := (others => <>); function Image (Trans : transition_descr) return String; -- Needed for the instantiation of Sax.State_Machines type state_data is record Simple : type_index; Fixed : Sax.Symbols.symbol := Sax.Symbols.No_Symbol; Default : Sax.Symbols.symbol := Sax.Symbols.No_Symbol; Block : block_status := No_Block; Nillable : Boolean := False; end record; No_State_Data : constant state_data := (No_Type_Index, Sax.Symbols.No_Symbol, Sax.Symbols.No_Symbol, No_Block, False); -- User data associated with each state. This mostly point to the -- corresponding type in the schema, but also includes overridding data -- from the corresponding element itself. package Schema_State_Machines is new Sax.State_Machines (symbol => transition_event, transition_symbol => transition_descr, Image => Image, state_user_data => state_data, Default_Data => No_State_Data, Default_State_Count => 200, -- XSD metaschema takes 904 states Default_Transition_Count => 200); -- XSD metaschema takes 1096 use Schema_State_Machines; type type_descr is record Name : qualified_name := No_Qualified_Name; Attributes : attributes_list := No_Attributes; Block : block_status := No_Block; Final : final_status := (others => False); Restriction_Of : type_index := No_Type_Index; Extension_Of : type_index := No_Type_Index; Simple_Content : Schema.Simple_Types.simple_type_index := Schema.Simple_Types.No_Simple_Type_Index; -- set if we have a simpleType or simpleContent Mixed : Boolean := False; Is_Abstract : Boolean := False; Complex_Content : Schema_State_Machines.state := Schema_State_Machines.No_State; -- The start of the nested NFA for a complexType end record; type type_descr_access is access all type_descr; pragma pack (type_descr); No_Type_Descr : constant type_descr := (others => <>); function Image (Self : access nfa'class; S : Schema_State_Machines.state; Data : state_data) return String; -- Needed for the instantiation of Pretty_Printers type active_state_data is record Visited : visited_all_children := 0; end record; No_Active_Data : constant active_state_data := (Visited => 0); function Match (Self : access abstract_nfa_matcher'class; From_State, To_State : state; Parent_Data : access active_state_data; Trans : transition_descr; Sym : transition_event) return Boolean; -- Whether [Sym] matches [Trans]. -- Parent_Data is the execution data associated with the parent state in -- which From_State is nested. It is used to validate nodes (which -- needs to check that all children are either optional or were visited). function Expected (Self : abstract_nfa_matcher'class; From_State, To_State : state; Parent_Data : access active_state_data; Trans : transition_descr) return String; -- What to display in "expecting ..." for this transition. package Schema_State_Machines_PP is new Schema_State_Machines .Pretty_Printers (Image); package Schema_State_Machines_Matchers is new Schema_State_Machines.Matchers (active_state_data, No_Active_Data, Match, Expected); type schema_nfa is new Schema_State_Machines.nfa with private; type schema_nfa_access is access all schema_nfa'class; type schema_nfa_matcher is new Schema_State_Machines_Matchers.nfa_matcher with private; procedure Do_Match (Matcher : in out schema_nfa_matcher; Sym : transition_event; Success : out Boolean; Through_Any : out Boolean; Through_Process : out process_contents_type); -- Process the next event through NFA, and report whether it matched -- through a function Ur_Type (NFA : access schema_nfa'class; Process_Contents : process_contents_type) return Schema_State_Machines.nested_nfa; -- Return the nested NFA for type reference_kind is (ref_element, ref_type, ref_attribute, ref_group, ref_attrgroup); type global_reference (Kind : reference_kind := ref_element) is record Name : qualified_name; case Kind is when ref_element => Element : state; when ref_type => Typ : type_index; when ref_group => Gr_Start, Gr_End : state; when ref_attribute | ref_attrgroup => Attributes : attributes_list; end case; end record; No_Global_Reference : constant global_reference := (ref_type, Name => No_Qualified_Name, Typ => No_Type_Index); -- The global elements in a grammar that can be referenced from another -- grammar (or from an XML file). type reference_name is record Name : qualified_name; Kind : reference_kind; end record; function Hash (Name : reference_name) return Interfaces.Unsigned_32; function Get_Key (Ref : global_reference) return reference_name; package Reference_HTables is new Sax.HTable (element => global_reference, Empty_Element => No_Global_Reference, key => reference_name, Get_Key => Get_Key, Hash => Hash, Equal => "="); type reference_htable is access Reference_HTables.htable; reference_htable_size : constant := 1023; -- Size created for the references table function Get_NFA (Grammar : xml_grammar) return schema_nfa_access; function Get_References (Grammar : xml_grammar) return reference_htable; -- Returns the state machine and global references used to validate -- [Grammar] function Dump_Dot_NFA (Grammar : xml_grammar; Nested : nested_nfa := No_Nested) return String; -- Return a "dot" graph for the NFA, possibly restricted to a specific -- nested NFA. function Get_Simple_Type (NFA : access schema_nfa'class; Simple : Schema.Simple_Types.simple_type_index) return Schema.Simple_Types.simple_type_descr; pragma inline (Get_Simple_Type); -- Return the simple type corresponding to the index function Get_Type_Descr (NFA : access schema_nfa'class; Index : type_index) return access type_descr; pragma inline (Get_Type_Descr); -- Return the type description at that index ------------ -- Parser -- ------------ -- See packages Schema.Readers and Schema.Schema_Readers for non-abstract -- implementation of those. type abstract_validation_reader is abstract new Sax.Readers.sax_reader with record Error_Location : Sax.Locators.location; Error_Msg : Sax.Symbols.symbol := Sax.Symbols.No_Symbol; Id_Table : Schema.Simple_Types.symbol_htable_access; -- Mapping of IDs to elements Grammar : xml_grammar := No_Grammar; All_NNI : Sax.Symbols.symbol; -- "allNNI" Annotated : Sax.Symbols.symbol; -- "annotated" Annotation : Sax.Symbols.symbol; -- "annotation" Any : Sax.Symbols.symbol; -- "any" Any_Attribute : Sax.Symbols.symbol; -- "anyAttribute" Any_Namespace : Sax.Symbols.symbol; -- "##any" Any_Simple_Type : Sax.Symbols.symbol; -- "anySimpleType" Anytype : Sax.Symbols.symbol; -- "anyType" Appinfo : Sax.Symbols.symbol; -- "appinfo" Attr_Decls : Sax.Symbols.symbol; -- "attrDecls" Attribute : Sax.Symbols.symbol; -- "attribute" Attribute_Group : Sax.Symbols.symbol; -- "attributeGroup" Attribute_Group_Ref : Sax.Symbols.symbol; -- "attributeGroupRef" Base : Sax.Symbols.symbol; -- "base" Block : Sax.Symbols.symbol; -- "block" Block_Default : Sax.Symbols.symbol; -- "blockDefault" Block_Set : Sax.Symbols.symbol; -- "blockSet" Choice : Sax.Symbols.symbol; -- "choice" Complex_Content : Sax.Symbols.symbol; -- "complexContent" Complex_Extension_Type : Sax.Symbols.symbol; -- "complexExtensionType" Complex_Restriction_Type : Sax.Symbols.symbol; Complex_Type : Sax.Symbols.symbol; -- "complexType" Complex_Type_Model : Sax.Symbols.symbol; -- "complexTypeModel" Def_Ref : Sax.Symbols.symbol; -- "defRef" Default : Sax.Symbols.symbol; -- "default" Derivation_Control : Sax.Symbols.symbol; -- "derivationControl" Derivation_Set : Sax.Symbols.symbol; -- "derivationSet" Documentation : Sax.Symbols.symbol; -- "documentation" Element : Sax.Symbols.symbol; -- "element" Enumeration : Sax.Symbols.symbol; -- "enumeration" Explicit_Group : Sax.Symbols.symbol; -- "explicitGroup" Extension : Sax.Symbols.symbol; -- "extension" Extension_Type : Sax.Symbols.symbol; -- "extensionType" Facet : Sax.Symbols.symbol; -- "facet" Field : Sax.Symbols.symbol; -- "field" Final : Sax.Symbols.symbol; -- "final" Final_Default : Sax.Symbols.symbol; -- "finalDefault" Fixed : Sax.Symbols.symbol; -- "fixed" Form : Sax.Symbols.symbol; -- "form" Form_Choice : Sax.Symbols.symbol; -- "formChoice Fraction_Digits : Sax.Symbols.symbol; Group : Sax.Symbols.symbol; -- "group" Group_Def_Particle : Sax.Symbols.symbol; -- "groupDefParticle" Group_Ref : Sax.Symbols.symbol; -- "groupRef" Id : Sax.Symbols.symbol; -- "id" IDREF : Sax.Symbols.symbol; -- "IDREF" IDREFS : Sax.Symbols.symbol; -- "IDREFS" Identity_Constraint : Sax.Symbols.symbol; -- "identityConstraint" Import : Sax.Symbols.symbol; -- "import" Include : Sax.Symbols.symbol; -- "include" Item_Type : Sax.Symbols.symbol; -- "itemType" Key : Sax.Symbols.symbol; -- "key" Keybase : Sax.Symbols.symbol; -- "keybase" Keyref : Sax.Symbols.symbol; -- "keyref" Lang : Sax.Symbols.symbol; -- "lang" Lax : Sax.Symbols.symbol; -- "lax" Length : Sax.Symbols.symbol; List : Sax.Symbols.symbol; -- "list" Local : Sax.Symbols.symbol; Local_Complex_Type : Sax.Symbols.symbol; -- "localComplexType" Local_Element : Sax.Symbols.symbol; -- "localElement" Local_Simple_Type : Sax.Symbols.symbol; -- "localSimpleType" MaxExclusive : Sax.Symbols.symbol; MaxInclusive : Sax.Symbols.symbol; MaxOccurs : Sax.Symbols.symbol; Max_Bound : Sax.Symbols.symbol; -- "maxBound" Maxlength : Sax.Symbols.symbol; -- "maxLength" Member_Types : Sax.Symbols.symbol; -- "memberTypes" MinExclusive : Sax.Symbols.symbol; MinInclusive : Sax.Symbols.symbol; MinOccurs : Sax.Symbols.symbol; Min_Bound : Sax.Symbols.symbol; -- "minBound" Minlength : Sax.Symbols.symbol; -- "minLength" Mixed : Sax.Symbols.symbol; -- "mixed" NCName : Sax.Symbols.symbol; -- "NCName" NMTOKEN : Sax.Symbols.symbol; -- "NMTOKEN" Name : Sax.Symbols.symbol; Named_Attribute_Group : Sax.Symbols.symbol; -- "namedAttributeGroup" Named_Group : Sax.Symbols.symbol; -- "namedGroup" Namespace : Sax.Symbols.symbol; Namespace_List : Sax.Symbols.symbol; -- "namespaceList" Namespace_Target : Sax.Symbols.symbol; -- "targetNamespace" Nested_Particle : Sax.Symbols.symbol; -- "nestedParticle" Nil : Sax.Symbols.symbol; Nillable : Sax.Symbols.symbol; -- "nillable" No_Namespace_Schema_Location : Sax.Symbols.symbol; Non_Negative_Integer : Sax.Symbols.symbol; -- "nonNegativeInteger" Notation : Sax.Symbols.symbol; -- "notation" Num_Facet : Sax.Symbols.symbol; -- "numFacet" Occurs : Sax.Symbols.symbol; -- "occurs" Open_Attrs : Sax.Symbols.symbol; -- "openAttrs" Optional : Sax.Symbols.symbol; -- "optional" Other_Namespace : Sax.Symbols.symbol; Particle : Sax.Symbols.symbol; -- "particle" Pattern : Sax.Symbols.symbol; Positive_Integer : Sax.Symbols.symbol; Precision_Decimal : Sax.Symbols.symbol; Process_Contents : Sax.Symbols.symbol; -- "processContents" Prohibited : Sax.Symbols.symbol; -- "prohibited" Public : Sax.Symbols.symbol; -- "public" QName : Sax.Symbols.symbol; -- "QName" Qualified : Sax.Symbols.symbol; -- "qualified" Real_Group : Sax.Symbols.symbol; -- "realGroup" Redefinable : Sax.Symbols.symbol; -- "redefinable" Redefine : Sax.Symbols.symbol; -- "redefine" Reduced_Derivation_Control : Sax.Symbols.symbol; Ref : Sax.Symbols.symbol; Refer : Sax.Symbols.symbol; -- "refer" Required : Sax.Symbols.symbol; -- "required" Restriction : Sax.Symbols.symbol; -- "restriction" Restriction_Type : Sax.Symbols.symbol; -- "restrictionType" S_1 : Sax.Symbols.symbol; -- "1" S_Abstract : Sax.Symbols.symbol; -- "abstract" S_All : Sax.Symbols.symbol; -- "all" S_Attribute_Form_Default : Sax.Symbols.symbol; -- "attributeFormDefault" S_Boolean : Sax.Symbols.symbol; -- "boolean" S_Element_Form_Default : Sax.Symbols.symbol; -- "elementFormDefault" S_False : Sax.Symbols.symbol; -- "false" S_Schema : Sax.Symbols.symbol; -- "schema" S_String : Sax.Symbols.symbol; -- "string" S_Use : Sax.Symbols.symbol; -- "use" Schema_Location : Sax.Symbols.symbol; Schema_Top : Sax.Symbols.symbol; -- "schemaTop" Selector : Sax.Symbols.symbol; -- "selector" Sequence : Sax.Symbols.symbol; -- "sequence" Simple_Content : Sax.Symbols.symbol; -- "simpleContent" Simple_Derivation : Sax.Symbols.symbol; -- "simpleDerivation" Simple_Derivation_Set : Sax.Symbols.symbol; -- "simpleDerivationSet" Simple_Extension_Type : Sax.Symbols.symbol; -- "simpleExtensionType" Simple_Restriction_Model : Sax.Symbols.symbol; Simple_Restriction_Type : Sax.Symbols.symbol; Simple_Type : Sax.Symbols.symbol; -- "simpleType" Source : Sax.Symbols.symbol; -- "source" Strict : Sax.Symbols.symbol; -- "strict" Substitution_Group : Sax.Symbols.symbol; -- "substitutionGroup" System : Sax.Symbols.symbol; -- "system" Target_Namespace : Sax.Symbols.symbol; -- "##targetNamespace" Token : Sax.Symbols.symbol; -- "token" Top_Level_Attribute : Sax.Symbols.symbol; -- "topLevelAttribute" Top_Level_Complex_Type : Sax.Symbols.symbol; -- "topLevelComplexType" Top_Level_Element : Sax.Symbols.symbol; -- "topLevelElement" Top_Level_Simple_Type : Sax.Symbols.symbol; -- "topLevelSimpleType" Total_Digits : Sax.Symbols.symbol; Typ : Sax.Symbols.symbol; Type_Def_Particle : Sax.Symbols.symbol; -- "typeDefParticle" UC_ID : Sax.Symbols.symbol; -- "ID" URI_Reference : Sax.Symbols.symbol; -- "uriReference" Unbounded : Sax.Symbols.symbol; Union : Sax.Symbols.symbol; -- "union" Unique : Sax.Symbols.symbol; -- "unique" Unqualified : Sax.Symbols.symbol; -- "unqualified" Ur_Type : Sax.Symbols.symbol; -- "ur-Type" Value : Sax.Symbols.symbol; -- "value" Version : Sax.Symbols.symbol; -- "version" Whitespace : Sax.Symbols.symbol; Wildcard : Sax.Symbols.symbol; -- "wildcard" XML_Instance_URI : Sax.Symbols.symbol; XML_Schema_URI : Sax.Symbols.symbol; XML_URI : Sax.Symbols.symbol; -- XML_URI XPath : Sax.Symbols.symbol; -- "xpath" XPath_Expr_Approx : Sax.Symbols.symbol; -- "XPathExprApprox" XPath_Spec : Sax.Symbols.symbol; -- "XPathSpec" Xmlns : Sax.Symbols.symbol := Sax.Symbols.No_Symbol; end record; type abstract_validating_reader_access is access all abstract_validation_reader'class; procedure Free (Reader : in out abstract_validation_reader); -- Free the memory used by Reader overriding procedure Initialize_Symbols (Parser : in out abstract_validation_reader); -- See inherited documentation procedure Validation_Error (Reader : access abstract_validation_reader; Message : Unicode.CES.byte_sequence; Loc : Sax.Locators.location := Sax.Locators.No_Location; Except : Ada.Exceptions.Exception_Id := XML_Validation_Error'identity); -- Sets an error message, and raise XML_Validation_Error. -- If [Message] starts with "#", this indicates a non-implemented -- feature, and XML_Not_Implemented is raised instead. function Get_Error_Message (Reader : abstract_validation_reader) return Unicode.CES.byte_sequence; -- Return the current error message procedure Check_Substitution_Group_OK (Handler : access abstract_validation_reader'class; New_Type, Old_Type : type_index; Loc : Sax.Locators.location; Element_Block : block_status); -- Verifies that [New_Type] is a valid substitution for [Old_Type], -- according to 3.3.6.3. -- If not, raises a [Validation_Error] ------------------------- -- Attribute_Validator -- ------------------------- type namespace_kind is (namespace_other, namespace_any, namespace_list); -- "Any": any non-conflicting namespace -- "Other": any non-conflicting namespace other than targetNamespace -- Namespace_List can contain "##local", "##targetNamespace" or actual -- namespaces. --------------------- -- Type validators -- --------------------- -- Such validators are build to validate specific parts of an XML -- document (a whole element). procedure Validate_Simple_Type (Reader : access abstract_validation_reader'class; Simple_Type : Schema.Simple_Types.simple_type_index; Ch : Unicode.CES.byte_sequence; Loc : Sax.Locators.location; Insert_Id : Boolean := True); -- Validate [Ch] as a simpleType -- If [Insert_Id] is True, and the type is ID, it is inserted in a global -- htables. Thus calling this procedure twice with this parameter set to -- true will result in a "duplicate id" error. procedure Normalize_And_Validate (Parser : access abstract_validation_reader'class; Simple : Schema.Simple_Types.simple_type_index; Fixed : in out Sax.Symbols.symbol; Loc : Sax.Locators.location); -- Normalize whitespaces in [Fixed] according to the simple type. function Equal (Reader : access abstract_validation_reader'class; Simple_Type : Schema.Simple_Types.simple_type_index; Ch1 : Sax.Symbols.symbol; Ch2 : Unicode.CES.byte_sequence) return Boolean; -- Checks whether [Ch1]=[Ch2] according to the type (possibly involving -- whitespace normalization) procedure Validate_Attributes (NFA : access schema_nfa'class; Typ : access type_descr; Reader : access abstract_validation_reader'class; Atts : in out Sax.Readers.sax_attribute_list; Is_Nil : in out Integer); -- Check whether this list of attributes is valid for elements associated -- with this validator. By default, this simply check whether the list of -- attributes registered through Add_Attribute matches Atts. -- -- Id_Table is used to ensure that two same Ids are not in the document. It -- is passed as an access type, so that in case of exception it is still -- properly set on exit. -- -- [Is_Nil] is set to the index in [Atts] for the xsi:nil attribute, or -- -1 if not found. -- -- Sets the type of the attributes (through Sax.Attributes.Set_Type) to Id -- if the corresponding attribute is an id. type internal_any_descr is record Target_NS : Sax.Symbols.symbol := Sax.Symbols.No_Symbol; Process_Contents : process_contents_type := process_strict; Namespaces : Sax.Symbols.symbol := Sax.Symbols.No_Symbol; end record; No_Internal_Any_Descr : constant internal_any_descr := (others => <>); -- We need to temporarily store the target_NS, in case we are parsing -- multiple grammars before we generate the NFA procedure Add_Any_Attribute (Grammar : xml_grammar; List : in out attributes_list; Any : internal_any_descr; As_Restriction : Boolean); procedure Add_Attribute (Parser : access abstract_validation_reader'class; List : in out attributes_list; Attribute : attribute_descr; Ref : named_attribute_list := Empty_Named_Attribute_List; Loc : Sax.Locators.location); procedure Add_Attributes (Parser : access abstract_validation_reader'class; List : in out attributes_list; Attributes : attributes_list; As_Restriction : Boolean; Loc : Sax.Locators.location); -- Add a valid attribute to Validator. -- Is_Local should be true if the attribute is local, or False if this is -- a reference to a global attribute. -- The second version copies elements from [Attributes] into [List]. -- [As_Restriction] is used when including a . Since there -- can be only one in the list, this is merged with any existing -- . [Target_NS] is also used in this context. -- [Ref], if specified, is the "refed" attribute. Its type is used, but -- the use type of [Attribute] is used, instead. -------------- -- Grammars -- -------------- procedure Initialize_Grammar (Reader : in out abstract_validation_reader'class); -- Initialize the internal structure of the grammar. -- This adds the definition for all predefined types procedure Reset (Grammar : in out xml_grammar); -- Partial reset of the grammar: all the namespace-specific grammars are -- deleted, except for the grammar used to validate the XSD files -- themselves. This is mostly convenient if you want to reuse a grammar -- to handle _lots_ of unrelated XSD files (if your application only uses -- a few of these, you can easily store them all in the same grammar, but -- if you have hundreds of them, it might be more memory-efficient to -- discard the namespaces you no longer use). -- Keeping the grammar for the XSD files provides a minor optimization, -- avoiding the need to recreate it the next time you parse a XSD file. -- -- TASKING: you should not call this procedure while some parsers are still -- using the grammar. procedure Create_Global_Attribute (Parser : access abstract_validation_reader'class; Attr : attribute_descr; Loc : Sax.Locators.location); function Create_Simple_Type (NFA : access schema_nfa'class; Descr : Schema.Simple_Types.simple_type_descr) return Schema.Simple_Types.simple_type_index; function Create_Type (NFA : access schema_nfa'class; Descr : type_descr) return type_index; -- Register a global attribute or type. -- [Name] or [Descr.Name] can be [No_Qualified_Name], in which case a local -- type is created (ie not registered in the list of global elements). procedure Add_Facet (Grammar : xml_grammar; Facets : in out Schema.Simple_Types.all_facets; Facet_Name : Sax.Symbols.symbol; Value : Sax.Symbols.symbol; Loc : Sax.Locators.location); pragma inline (Add_Facet); -- See doc in schema-simple_types, this is a proxy function URI_Was_Parsed (Grammar : xml_grammar; URI : Sax.Symbols.symbol) return Boolean; -- Return True if the schema at URI was already parsed and included in -- Grammar. URI must be an absolute URI. procedure Set_Parsed_URI (Reader : in out abstract_validation_reader'class; URI : Sax.Symbols.symbol); -- Indicate that the schema found at URI was fully parsed and integrated -- into Grammar. It can then be tested through URI_Was_Parsed. procedure Debug_Dump (Grammar : xml_grammar); -- Dump the grammar to stdout. This is for debug only function To_QName (Name : qualified_name) return Unicode.CES.byte_sequence; -- Return the name as it should be displayed in error messages function Simple_Nested (NFA : access schema_nfa'class) return Schema_State_Machines.state; procedure Add_Notation (NFA : access schema_nfa'class; Name : Sax.Symbols.symbol); -- Register a new NOTATION private ------------------------- -- Attribute_Validator -- ------------------------- package Attributes_Tables is new GNAT.Dynamic_Tables (Table_Component_Type => attribute_descr, Table_Index_Type => named_attribute_list, Table_Low_Bound => Empty_Named_Attribute_List + 1, Table_Initial => 200, Table_Increment => 200); package Types_Tables is new GNAT.Dynamic_Tables (Table_Component_Type => type_descr, Table_Index_Type => type_index, Table_Low_Bound => No_Type_Index + 1, Table_Initial => 300, Table_Increment => 100); -------------- -- Grammars -- -------------- type string_list_record; type string_list is access string_list_record; type string_list_record is record Str : Sax.Symbols.symbol; Next : string_list; end record; -- We will use Ada2005 containers when the compiler is more widely -- available procedure Free (List : in out string_list); -- Free the list and its contents type schema_nfa is new Schema_State_Machines.nfa with record Simple_Types : Schema.Simple_Types.simple_type_table; References : reference_htable; Attributes : Attributes_Tables.instance; Enumerations : Schema.Simple_Types.Enumeration_Tables.instance; Types : Types_Tables.instance; Notations : Schema.Simple_Types.Symbol_Htable.htable (101); -- List of all notations defined in the current XSD Ur_Type : Schema_State_Machines.state; Ur_Type_Skip : Schema_State_Machines.state; Simple_Nested : Schema_State_Machines.state; -- A dummy nested NFA: this is used when xsi:type replaces a complex -- type with a simple type, so that we accept no children, but still -- accept the tag. We will temporarily override the state -- data to match the simple type. Metaschema_NFA_Last : nfa_snapshot := No_NFA_Snapshot; Metaschema_Simple_Types_Last : Schema.Simple_Types.simple_type_index; Metaschema_Attributes_Last : named_attribute_list; Metaschema_Enumerations_Last : Schema.Simple_Types.enumeration_index; Metaschema_Types_Last : type_index; -- Last state for the metaschema XSD (for Reset) end record; type schema_nfa_matcher is new Schema_State_Machines_Matchers .nfa_matcher with record Matched_Through_Any : Boolean := False; Matched_Process_Content : process_contents_type; end record; type xml_grammar_record is new Sax.Pointers.root_encapsulated with record Symbols : Sax.Utils.symbol_table; Parsed_Locations : string_list; -- List of schema locations that have already been parsed. This is used -- in particular to handle cases where a schema imports two others -- schemas, that in turn import a common one. XSD_Version : xsd_versions := xsd_1_0; NFA : schema_nfa_access; -- The state machine representing the grammar -- This includes the states for all namespaces end record; procedure Free (Grammar : in out xml_grammar_record); -- Free the memory occupied by the grammar package XML_Grammars is new Sax.Pointers.Smart_Pointers (xml_grammar_record); type xml_grammar is new XML_Grammars.pointer; No_Grammar : constant xml_grammar := xml_grammar (XML_Grammars.Null_Pointer); end Schema.Validators;