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
17
xmlada/schema/schema-validators.ads
Emmanuel Briot a56a0902a9 Fix memory leaks while validating invalid XML schemas 
L328-026

Change-Id: Ic49c17e2d275861131178506fd55d07bd2d8f412
2016-02-17 18:02:08 +01:00

919 lines
42 KiB
Ada
Raw Permalink Blame History

------------------------------------------------------------------------------
-- XML/Ada - An XML suite for Ada95 --
-- --
-- Copyright (C) 2004-2016, 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/>. --
-- --
------------------------------------------------------------------------------
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.
-- Do not load, in a single XML_Grammar, multiple xsd files for the same
-- namespace (in particular grammars with no targetNamespace). They would
-- be merged together, and validating files from this grammar would result
-- in unexpected results.
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 <group> 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 <anyAttribute>:
-- - 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 <all> construct without
-- creating a set of states for all possible permuations of child elements
-- (since otherwise the number of states explodes). Instead, an <all> 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 <all>) and
-- cannot be visited again. The <all> 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 <all> have been
-- visited once or have minOccurs=0.
-- This also requires temporary data associated with all active instances
-- of the <all> 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 <all> 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
-- <all> 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 <all> nodes: the index of this transition in the mask
-- (Visited_All_Children) for <all>. 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 <anyAttribute> even if it never
-- accepts anything. For an extension or restriction, it is merged with the
-- base's <anyAttribute>
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 <all> 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 <any>
function Ur_Type
(NFA : access Schema_NFA'Class;
Process_Contents : Process_Contents_Type)
return Schema_State_Machines.Nested_NFA;
-- Return the nested NFA for <ur-Type>
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.
-- If no Loc is provided, it defaults to the current location in Reader.
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 : access 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 <anyAttribute>. Since there
-- can be only one in the list, this is merged with any existing
-- <anyAttribute>. [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 <close> 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;
Reference in New Issue View Git Blame Copy Permalink