with Unicode.CES; with Sax.Attributes; with Sax.HTable; with Sax.Utils; 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 XML_Validator_Record is tagged private; type XML_Validator is access all XML_Validator_Record'Class; -- A new validator is typically created every time a new element starts, -- and is in charge of checking the contents and attributes of that -- element. -- The default implementation always validates. type XML_Grammar is private; type XML_Grammar_NS_Record is private; type XML_Grammar_NS is access all XML_Grammar_NS_Record; -- The part of a grammar specialized for a given namespace. -- A grammar can contain the definition for multiple namespaces (generally -- the standard XML Schema namespace for predefined types, and the -- namespace we are defining). Each of these is accessed by a separate -- XML_Grammar_NS object No_Grammar : constant XML_Grammar; -- No Grammar has been defined type XML_Element is private; No_Element : constant XML_Element; -- An element of an XML stream (associated with a start-tag) Unbounded : constant Integer := -1; -- To indicate that a Max_Occurs is set to unbounded type Form_Type is (Qualified, Unqualified); type Process_Contents_Type is (Process_Strict, Process_Lax, Process_Skip); -------------------- -- Validator_Data -- -------------------- -- Most validators, when they are performing validation, need to keep some -- data while their node is active. Such data might be used to store -- counters, current items,... type Validator_Data_Record is abstract tagged private; type Validator_Data is access all Validator_Data_Record'Class; procedure Free (Data : in out Validator_Data_Record); -- Free the memory associated with the data. -- By default, this does nothing procedure Free (Data : in out Validator_Data); -- Free Data and the pointed data ------------ -- Facets -- ------------ type Facets_Description_Record is abstract tagged null record; type Facets_Description is access all Facets_Description_Record'Class; procedure Add_Facet (Facets : in out Facets_Description_Record; Facet_Name : Unicode.CES.Byte_Sequence; Facet_Value : Unicode.CES.Byte_Sequence; Applied : out Boolean) is abstract; -- Set the value of a facet. -- Applied is set to True if the facet was valid for Facets procedure Check_Facet (Facets : in out Facets_Description_Record; Value : Unicode.CES.Byte_Sequence) is abstract; -- Check whether Value matches Facets. Raises XML_Validator_Error otherwise procedure Free (Facets : in out Facets_Description_Record) is abstract; procedure Free (Facets : in out Facets_Description); -- Free the facets; ----------- -- Types -- ----------- type XML_Type is private; No_Type : constant XML_Type; -- A type, which can either be named (ie it has been explicitely declared -- with a name and stored in the grammar), or anonymous. function Create_Local_Type (Validator : access XML_Validator_Record'Class) return XML_Type; -- Create a new local type. -- This type cannot be looked up in the grammar later on. See the function -- Register below if you need this capability function Get_Validator (Typ : XML_Type) return XML_Validator; -- Return the validator used for that type function List_Of (Typ : XML_Type) return XML_Type; -- Return a new type validator that checks for a list of values valid for -- Validator. function Extension_Of (Base : XML_Type; Extension : XML_Validator := null) return XML_Validator; -- Create an extension of Base. -- Base doesn't need to be a Clone of some other type, since it isn't -- altered. See also Is_Extension_Of below function Restriction_Of (Base : XML_Type; Restriction : XML_Validator := null) return XML_Validator; -- Create a restriction of Base -- Base doesn't need to be a Clone of some other type, since it isn't -- altered. See also Is_Restriction_Of below function Get_Local_Name (Typ : XML_Type) return Unicode.CES.Byte_Sequence; -- Return the local name of the type procedure Check_Content_Type (Typ : XML_Type; Should_Be_Simple : Boolean); -- Check whether Typ is a simpleType or a complexType. See the description -- of the homonym for validators. -- When in doubt, use this one instead of the one for validators, since -- this one properly handles No_Type and types whose definition has not yet -- been parsed in the Schema. function Is_Simple_Type (Typ : XML_Type) return Boolean; -- Whether Typ is a simple type procedure Set_Block (Typ : XML_Type; On_Restriction : Boolean; On_Extension : Boolean); function Get_Block_On_Restriction (Typ : XML_Type) return Boolean; function Get_Block_On_Extension (Typ : XML_Type) return Boolean; -- Set the "block" status of the type. -- This can also be done at the element's level ------------------------- -- Attribute_Validator -- ------------------------- type Attribute_Validator_Record is abstract tagged private; type Attribute_Validator is access all Attribute_Validator_Record'Class; type Attribute_Use_Type is (Prohibited, Optional, Required, Default, Fixed); function Create_Local_Attribute (Local_Name : Unicode.CES.Byte_Sequence; NS : XML_Grammar_NS; Attribute_Type : XML_Type := No_Type; Attribute_Form : Form_Type := Qualified; Attribute_Use : Attribute_Use_Type := Optional; Value : Unicode.CES.Byte_Sequence := ""; Is_ID : Boolean := False) return Attribute_Validator; -- Create a new local attribute validator. See also Create_Global_Attribute type Namespace_Kind is (Namespace_Other, Namespace_Any, Namespace_List, Namespace_Local); function Create_Any_Attribute (Process_Contents : Process_Contents_Type := Process_Strict; Kind : Namespace_Kind; NS : XML_Grammar_NS) return Attribute_Validator; -- Equivalent of in an XML schema. -- Validates to true if the attribute's namespace is: -- Namespace_Other: not equal to NS -- Namespace_Any: any Namespace (the second parameter is irrelevant) -- Namespace_List: equal to NS procedure Validate_Attribute (Validator : Attribute_Validator_Record; Atts : Sax.Attributes.Attributes'Class; Index : Natural; Grammar : in out XML_Grammar) is abstract; -- Return True if Value is valid for this attribute. -- Raise XML_Validation_Error in case of error procedure Free (Validator : in out Attribute_Validator_Record) is abstract; procedure Free (Validator : in out Attribute_Validator); -- Free the memory occupied by the validator function Is_Equal (Attribute : Attribute_Validator_Record; Attr2 : Attribute_Validator_Record'Class) return Boolean is abstract; -- Whether the two are the same procedure Set_Type (Attr : access Attribute_Validator_Record; Attr_Type : XML_Type); function Get_Type (Attr : access Attribute_Validator_Record) return XML_Type; -- Set the type of the attribute --------------- -- ID_Htable -- --------------- type Id_Htable_Access is private; ---------------------- -- Attribute groups -- ---------------------- type XML_Attribute_Group is private; Empty_Attribute_Group : constant XML_Attribute_Group; -- Created through calls to Create_Global_Attribute_Group below procedure Add_Attribute (Group : in out XML_Attribute_Group; Attr : access Attribute_Validator_Record'Class); -- Add a new attribute to the group --------------------- -- Type validators -- --------------------- -- Such validators are build to validate specific parts of an XML -- document (a whole element). procedure Free (Validator : in out XML_Validator_Record); procedure Free (Validator : in out XML_Validator); -- Free the memory occupied by Validator function Create_Validator_Data (Validator : access XML_Validator_Record) return Validator_Data; -- Create an instance of the data that the validator needs to check its -- associated node. This data will be automatically freed when the node -- ends. This function is called once when the element starts. -- By default, this returns null, and no data is associated. procedure Validate_Start_Element (Validator : access XML_Validator_Record; Local_Name : Unicode.CES.Byte_Sequence; Namespace_URI : Unicode.CES.Byte_Sequence; NS : XML_Grammar_NS; Data : Validator_Data; Schema_Target_NS : XML_Grammar_NS; Element_Validator : out XML_Element); -- Check whether this Start_Element event is valid in the context of the -- validator. Data is the result of Create_Validator_Data. -- -- NS is the *apparent* namespace, ie for local elements it is -- resolved to the parent element's namespace automatically. -- Namespace_URI is the actual namespace found in the XML file, possibly -- the empty string for an unqualified element. -- -- Element_Validator is set, on exit, to the validator that should be used -- to validate the next element. -- Element_Validator should be set to null if no validation could be -- performed and the control should be given back to the caller (for -- instance in the case of nested sequences and choices). -- -- Raise XML_Validation_Error in case of error procedure Validate_Attributes (Validator : access XML_Validator_Record; Atts : Sax.Attributes.Attributes'Class; Id_Table : in out Id_Htable_Access; Nillable : Boolean; Is_Nil : out Boolean; Grammar : in out XML_Grammar); -- 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. -- -- Nillable indicates whether the xsi:nil attribute should be supported, -- even if not explicitely inserted in the list. Is_Nil is set to the value -- of this attribute. procedure Validate_End_Element (Validator : access XML_Validator_Record; Local_Name : Unicode.CES.Byte_Sequence; Data : Validator_Data); -- Check whether this End_Element event is valid. -- This is called for the node associated with the validator itself, not -- for the child, as opposed to what is done for Validate_Start_Element. -- Raise XML_Validation_Error in case of error procedure Validate_Characters (Validator : access XML_Validator_Record; Ch : Unicode.CES.Byte_Sequence; Empty_Element : Boolean); -- Check whether this Characters event is valid in the context of -- Validator. Multiple calls to the SAX event Characters are grouped before -- calling this subprogram. -- If Empty_Element is true, this indicates that the element is in fact -- empty. This is to distinguish from the empty string: -- and -- If Empty_Element is true, then Ch is irrelevant function Get_Facets_Description (Validator : access XML_Validator_Record) return Facets_Description; -- Allocate a new record to store some values for the facets associated -- with Validator. This is used in restrictions or extensions of base -- types to override some of the facets. The returned description contains -- no preset facets. -- null is returned if the type doesn't have any facet. -- Return value must be freed by the caller procedure Add_Facet (Validator : access XML_Validator_Record; Facet_Name : Unicode.CES.Byte_Sequence; Facet_Value : Unicode.CES.Byte_Sequence); -- Add a restriction to the set of possible values for Validator. -- The valid list of restrictions and their values depends on the type -- of Validator. -- By default, an error is reported through Invalid_Restriction procedure Add_Attribute (Validator : access XML_Validator_Record; Attribute : access Attribute_Validator_Record'Class); -- Add a valid attribute to Validator. procedure Add_Attribute_Group (Validator : access XML_Validator_Record; Group : XML_Attribute_Group); -- Add a new group of attributes procedure Set_Mixed_Content (Validator : access XML_Validator_Record; Mixed : Boolean); -- Whether character data is allowed within that element, in addition to -- children nodes procedure Check_Replacement (Validator : access XML_Validator_Record; Typ : XML_Type; Had_Restriction : in out Boolean; Had_Extension : in out Boolean); -- Check whether Validator is a valid replacement for Typ (either an -- extension or a restriction, and not blocked by a "block" attribute). -- If there is an error, an XML_Validation_Error is raised. -- Otherwise, this function returns the type of replacement that is done. -- -- Had_* Indicate whether a restriction or extension was encountered while -- going up the inheritance tree so far. procedure Check_Content_Type (Validator : access XML_Validator_Record; Should_Be_Simple : Boolean); -- Check whether Validator describes a simple Type (or a complex Type with -- simpleContent), if Should_Be_Simple is true, or the opposite otherwise. -- Raises XML_Validator_Error in case of error. ------------ -- Unions -- ------------ function Create_Union return XML_Validator; -- Create a new empty union procedure Add_Union (Validator : access XML_Validator_Record'Class; Part : XML_Type); -- Add a new element to the union in Validator -------------- -- Elements -- -------------- function Create_Local_Element (Local_Name : Unicode.CES.Byte_Sequence; NS : XML_Grammar_NS; Of_Type : XML_Type; Form : Form_Type) return XML_Element; -- Create a new element, with a specific type. -- This element is a local element, that cannot be registered in the -- grammar and looked up later on. -- See Register below if you want to create a global element procedure Set_Substitution_Group (Element : XML_Element; Head : XML_Element); -- Define a substitution group for Validator, as declared through the -- "substitutionGroup" attribute of the XML Schema. -- Anywhere Head is referenced, Validator can be used -- instead. function Get_Type (Element : XML_Element) return XML_Type; procedure Set_Type (Element : XML_Element; Element_Type : XML_Type); -- Return the type validator for this element function Get_Local_Name (Element : XML_Element) return Unicode.CES.Byte_Sequence; -- Return the local name of Element procedure Set_Default (Element : XML_Element; Default : Unicode.CES.Byte_Sequence); function Has_Default (Element : XML_Element) return Boolean; function Get_Default (Element : XML_Element) return Unicode.CES.Byte_Sequence_Access; -- Manipulation of the "default" attribute. -- The value returned by Get_Default mustn't be altered or freed, and -- will be null if the attribute wasn't set. We return a pointer for -- efficiency only procedure Set_Fixed (Element : XML_Element; Fixed : Unicode.CES.Byte_Sequence); function Has_Fixed (Element : XML_Element) return Boolean; function Get_Fixed (Element : XML_Element) return Unicode.CES.Byte_Sequence_Access; -- Manipulation of the "fixed" attribute -- The value returned by Get_Fixed mustn't be altered or freed, and -- will be null if the attribute wasn't set. We return a pointer for -- efficiency only procedure Set_Abstract (Element : XML_Element; Is_Abstract : Boolean); function Is_Abstract (Element : XML_Element) return Boolean; -- Whether the element is abstract procedure Set_Nillable (Element : XML_Element; Nillable : Boolean); function Is_Nillable (Element : XML_Element) return Boolean; -- Whether the element is nillable (this only adds support for the -- attribute xsi:nil procedure Set_Final (Element : XML_Element; On_Restriction : Boolean; On_Extension : Boolean); -- Set the final status of the element procedure Set_Block (Element : XML_Element; On_Restriction : Boolean; On_Extension : Boolean); function Get_Block_On_Restriction (Element : XML_Element) return Boolean; function Get_Block_On_Extension (Element : XML_Element) return Boolean; -- Set the "block" status of the element procedure Check_Qualification (Target_NS : XML_Grammar_NS; Element : XML_Element; Namespace_URI : Unicode.CES.Byte_Sequence); -- Check whether the element should have been qualified or not, -- depending on its "form" attribute. -- Namespace_URI is the namespace as read in the file. -- Target_NS is the namespace described by the current schema function Is_Global (Element : XML_Element) return Boolean; -- Whether Element is a global element (ie declared at the top-level of -- the schema file), as opposed to a local element declared inside a -- global element: -- -- -- -- ------------- -- XML_Any -- ------------- type XML_Any_Record is new XML_Validator_Record with private; type XML_Any is access all XML_Any_Record'Class; function Create_Any (Process_Contents : Process_Contents_Type := Process_Strict; Namespace : Unicode.CES.Byte_Sequence; Target_NS : XML_Grammar_NS) return XML_Any; -- Create a new validator for ------------ -- Groups -- ------------ type Group_Model_Record is abstract new XML_Validator_Record with private; type Group_Model is access all Group_Model_Record'Class; type XML_Group is private; No_XML_Group : constant XML_Group; -- A group of elements, Create through a call to Create_Global_Group procedure Add_Particle (Group : in out XML_Group; Particle : access Group_Model_Record'Class; Min_Occurs : Natural := 1; Max_Occurs : Natural := 1); -- Add a new particle in the group function Extension_Of (Base : XML_Type; Group : XML_Group; Min_Occurs : Natural := 1; Max_Occurs : Integer := 1) return XML_Validator; -- Create an extension of Base. -- Base doesn't need to be a Clone of some other type, since it isn't -- altered function Get_Local_Name (Group : XML_Group) return Unicode.CES.Byte_Sequence; -- Return the local name of the group --------------- -- Particles -- --------------- type Sequence_Record is new Group_Model_Record with private; type Sequence is access all Sequence_Record'Class; type Choice_Record is new Group_Model_Record with private; type Choice is access all Choice_Record'Class; function Create_Sequence return Sequence; -- Create a new empty sequence -- (Min_Occurs, Max_Occurs) indicate the number of repetition allowed for -- that sequence. -- If Max_Occurs = Unbounded, the number of repeats is unbounded procedure Add_Particle (Seq : access Sequence_Record; Item : XML_Element; Min_Occurs : Natural := 1; Max_Occurs : Integer := 1); procedure Add_Particle (Seq : access Sequence_Record; Item : Sequence; Min_Occurs : Natural := 1; Max_Occurs : Integer := 1); procedure Add_Particle (Seq : access Sequence_Record; Item : Choice; Min_Occurs : Natural := 1; Max_Occurs : Integer := 1); procedure Add_Particle (Seq : access Sequence_Record; Item : XML_Any; Min_Occurs : Integer := 1; Max_Occurs : Integer := 1); procedure Add_Particle (Seq : access Sequence_Record; Item : XML_Group; Min_Occurs : Natural := 1; Max_Occurs : Integer := 1); function Create_Choice return Choice; -- Create a new empty choice. -- (Min_Occurs, Max_Occurs) indicate the number of repetition allowed for -- that choice. -- If Max_Occurs = Unbounded, the number of repeats is unbounded procedure Add_Particle (C : access Choice_Record; Item : XML_Element; Min_Occurs : Natural := 1; Max_Occurs : Integer := 1); procedure Add_Particle (C : access Choice_Record; Item : Sequence; Min_Occurs : Natural := 1; Max_Occurs : Integer := 1); procedure Add_Particle (C : access Choice_Record; Item : Choice; Min_Occurs : Natural := 1; Max_Occurs : Integer := 1); procedure Add_Particle (C : access Choice_Record; Item : XML_Any; Min_Occurs : Integer := 1; Max_Occurs : Integer := 1); procedure Add_Particle (C : access Choice_Record; Item : XML_Group; Min_Occurs : Natural := 1; Max_Occurs : Integer := 1); ------------- -- XML_All -- ------------- type XML_All_Record is new Group_Model_Record with private; type XML_All is access all XML_All_Record'Class; function Create_All (Min_Occurs : Natural := 1; Max_Occurs : Integer := 1) return XML_All; -- Return a new validator that checks that all its elements appear the -- right number of time subtype Zero_Or_One is Integer range 0 .. 1; procedure Add_Particle (Validator : access XML_All_Record; Item : XML_Element; Min_Occurs : Zero_Or_One := 1; Max_Occurs : Zero_Or_One := 1); -- Add a new element to Validator -------------- -- Grammars -- -------------- procedure Get_NS (Grammar : in out XML_Grammar; Namespace_URI : Unicode.CES.Byte_Sequence; Result : out XML_Grammar_NS); -- Return the part of the grammar specialized for a given namespace. -- If no such namespace exists yet in the grammar, it is created. procedure Set_Target_NS (Grammar : in out XML_Grammar; NS : XML_Grammar_NS); function Get_Target_NS (Grammar : XML_Grammar) return XML_Grammar_NS; -- Set the target namespace for the grammar. This is the "targetNamespace" -- attribute of the node. function Lookup_Element (Grammar : XML_Grammar_NS; Local_Name : Unicode.CES.Byte_Sequence; Create_If_Needed : Boolean := True) return XML_Element; function Lookup (Grammar : XML_Grammar_NS; Local_Name : Unicode.CES.Byte_Sequence; Create_If_Needed : Boolean := True) return XML_Type; function Lookup_Group (Grammar : XML_Grammar_NS; Local_Name : Unicode.CES.Byte_Sequence) return XML_Group; function Lookup_Attribute (Grammar : XML_Grammar_NS; Local_Name : Unicode.CES.Byte_Sequence; Create_If_Needed : Boolean := True) return Attribute_Validator; function Lookup_Attribute_Group (Grammar : XML_Grammar_NS; Local_Name : Unicode.CES.Byte_Sequence) return XML_Attribute_Group; -- Return the type validator to use for elements with name Local_Name. -- "null" is returned if there is no validator defined for these elements. -- The returned value must be freed by the user. -- If you are going to modify the returned value in any way (adding new -- restrictions,...), you must clone it, or you will modify the actual -- type stored in the grammar. -- If the element doesn't exist yet, a forward declaration is created for -- it, that must be overriden later on. function Create_Global_Type (Grammar : XML_Grammar_NS; Local_Name : Unicode.CES.Byte_Sequence; Validator : access XML_Validator_Record'Class) return XML_Type; function Create_Global_Element (Grammar : XML_Grammar_NS; Local_Name : Unicode.CES.Byte_Sequence; Form : Form_Type) return XML_Element; function Create_Global_Group (Grammar : XML_Grammar_NS; Local_Name : Unicode.CES.Byte_Sequence) return XML_Group; function Create_Global_Attribute (NS : XML_Grammar_NS; Local_Name : Unicode.CES.Byte_Sequence; Attribute_Type : XML_Type; Is_ID : Boolean := False) return Attribute_Validator; function Create_Global_Attribute_Group (NS : XML_Grammar_NS; Local_Name : Unicode.CES.Byte_Sequence) return XML_Attribute_Group; -- Register a new type or element in the grammar. procedure Create_Global_Type (Grammar : XML_Grammar_NS; Local_Name : Unicode.CES.Byte_Sequence; Validator : access XML_Validator_Record'Class); procedure Create_Global_Attribute (NS : XML_Grammar_NS; Local_Name : Unicode.CES.Byte_Sequence; Attribute_Type : XML_Type; Is_ID : Boolean := False); -- Same as above, but doesn't return the newly created type. Use Lookup if -- you need access to it later on function Redefine_Type (Grammar : XML_Grammar_NS; Local_Name : Unicode.CES.Byte_Sequence) return XML_Type; function Redefine_Group (Grammar : XML_Grammar_NS; Local_Name : Unicode.CES.Byte_Sequence) return XML_Group; -- Indicate that a given type or element is being redefined inside a -- tag. The old definition is returned, and all types that -- were referencing it will now refer to a new, invalid type. You need to -- register the new type or element before using the grammar. procedure Set_Block_Default (Grammar : XML_Grammar_NS; On_Restriction : Boolean; On_Extension : Boolean); -- Set the default value for the "block" attribute procedure Initialize (Grammar : in out XML_Grammar); -- Initialize the internal structure of the grammar procedure Free (Grammar : in out XML_Grammar); -- Free the memory occupied by the grammar procedure Global_Check (Grammar : XML_Grammar); -- Perform checks on the grammar, once it has been fully declared. -- This must be called before you start using the grammar, since some -- validation checks can only be performed at the end, not while the -- grammar is being constructed. function Get_Namespace_URI (Grammar : XML_Grammar_NS) return Unicode.CES.Byte_Sequence; -- Return the namespace URI associated with Grammar function URI_Was_Parsed (Grammar : XML_Grammar; URI : Unicode.CES.Byte_Sequence) 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 (Grammar : in out XML_Grammar; URI : Unicode.CES.Byte_Sequence); -- Indicate that the schema found at URI was fully parsed and integrated -- into Grammar. It can then be tested through URI_Was_Parsed. procedure Set_Debug_Name (Typ : access XML_Validator_Record'Class; Name : String); -- Will be removed procedure Set_Debug_Output (Output : Boolean); -- Whether we should output debug traces procedure Validation_Error (Message : String); -- Raise Validation_Error with a proper error message. function To_QName (Namespace_URI, Local_Name : String) return String; -- Return the name as it should be displayed in error messages private procedure Debug_Push_Prefix (Append : String); procedure Debug_Pop_Prefix; -- Append a prefix to the current output --------- -- Ids -- --------- type Id_Ref is record Key : Unicode.CES.Byte_Sequence_Access; end record; No_Id : constant Id_Ref := (Key => null); procedure Free (Id : in out Id_Ref); function Get_Key (Id : Id_Ref) return Unicode.CES.Byte_Sequence; package Id_Htable is new Sax.HTable (Element => Id_Ref, Empty_Element => No_Id, Free => Free, Key => Unicode.CES.Byte_Sequence, Get_Key => Get_Key, Hash => Sax.Utils.Hash, Equal => "="); type Id_Htable_Access is access Id_Htable.HTable; -- This table is used to store the list of IDs that have been used in the -- document so far, and prevent their duplication in the document. -------------------- -- Validator_Data -- -------------------- type Validator_Data_Record is abstract tagged null record; -------------- -- XML_Type -- -------------- type Content_Type is (Simple_Content, Complex_Content, Unknown_Content); type XML_Type_Record is record Local_Name : Unicode.CES.Byte_Sequence_Access; Validator : XML_Validator; Simple_Type : Content_Type; Block_Restriction : Boolean; Block_Extension : Boolean; -- The value for the "block" attribute of the type end record; type XML_Type is access all XML_Type_Record; No_Type : constant XML_Type := null; ------------------ -- Element_List -- ------------------ type XML_Element_Record; type XML_Element_Access is access all XML_Element_Record; type Element_List is array (Natural range <>) of XML_Element_Access; type Element_List_Access is access Element_List; procedure Append (List : in out Element_List_Access; Element : XML_Element); ----------------- -- XML_Element -- ----------------- type XML_Element_Record is record Local_Name : Unicode.CES.Byte_Sequence_Access; NS : XML_Grammar_NS; Of_Type : XML_Type; Substitution_Groups : Element_List_Access; -- List of all validators in the same substitution group Default : Unicode.CES.Byte_Sequence_Access; Fixed : Unicode.CES.Byte_Sequence_Access; Is_Abstract : Boolean; -- Whether the corresponding type is abstract Nillable : Boolean; -- Whether the element is nillable Final_Restriction : Boolean; Final_Extension : Boolean; -- Whether this element is final for "restriction" or "extension" or -- both Block_Restriction : Boolean; Block_Extension : Boolean; -- The value for the "block" attribute of the element Form : Form_Type; -- The value of the "form" attribute of the element Is_Global : Boolean; -- Whether the element was declared at the toplevel of the end record; type XML_Element is record Elem : XML_Element_Access; Is_Ref : Boolean; -- Whether this element was defined through a Lookup_Element, or a -- Create_Element call. end record; No_Element : constant XML_Element := (null, False); ------------------------- -- Attribute_Validator -- ------------------------- type Attribute_Validator_Record is abstract tagged record NS : XML_Grammar_NS; end record; type Attribute_Or_Group (Is_Group : Boolean := False) is record case Is_Group is when True => Group : XML_Attribute_Group; when False => Attr : Attribute_Validator; end case; end record; type Attribute_Validator_List is array (Natural range <>) of Attribute_Or_Group; type Attribute_Validator_List_Access is access Attribute_Validator_List; type Named_Attribute_Validator_Record is new Attribute_Validator_Record with record Local_Name : Unicode.CES.Byte_Sequence_Access; Attribute_Type : XML_Type; Attribute_Form : Form_Type; Attribute_Use : Attribute_Use_Type; Value : Unicode.CES.Byte_Sequence_Access; Is_Id : Boolean; end record; type Named_Attribute_Validator is access all Named_Attribute_Validator_Record'Class; procedure Validate_Attribute (Validator : Named_Attribute_Validator_Record; Atts : Sax.Attributes.Attributes'Class; Index : Natural; Grammar : in out XML_Grammar); procedure Free (Validator : in out Named_Attribute_Validator_Record); function Is_Equal (Attribute : Named_Attribute_Validator_Record; Attr2 : Attribute_Validator_Record'Class) return Boolean; procedure Set_Type (Attr : access Named_Attribute_Validator_Record; Attr_Type : XML_Type); function Get_Type (Attr : access Named_Attribute_Validator_Record) return XML_Type; type Any_Attribute_Validator is new Attribute_Validator_Record with record Process_Contents : Process_Contents_Type; Kind : Namespace_Kind; end record; procedure Validate_Attribute (Validator : Any_Attribute_Validator; Atts : Sax.Attributes.Attributes'Class; Index : Natural; Grammar : in out XML_Grammar); procedure Free (Validator : in out Any_Attribute_Validator); function Is_Equal (Attribute : Any_Attribute_Validator; Attr2 : Attribute_Validator_Record'Class) return Boolean; procedure Get_Attribute_Lists (Validator : access XML_Validator_Record; List : out Attribute_Validator_List_Access; Dependency1 : out XML_Validator; Dependency2 : out XML_Validator); -- Return the list of attributes that need to be checked for this -- validator, and a set of other validators whose list of attributes also -- need to be checked (they in turn will be called through this subprogram -- to get their own lists of attributes). -- There is generally a single list, although restrictions and -- extensions will have two or more. -- The lists are checked in turn, and any attribute already encountered -- will not be checked again. --------------------- -- Attribute_Group -- --------------------- type XML_Attribute_Group_Record is record Local_Name : Unicode.CES.Byte_Sequence_Access; Attributes : Attribute_Validator_List_Access; Is_Forward_Decl : Boolean; end record; type XML_Attribute_Group is access XML_Attribute_Group_Record; Empty_Attribute_Group : constant XML_Attribute_Group := null; ------------------- -- XML_Validator -- ------------------- type XML_Validator_Record is tagged record Debug_Name : Unicode.CES.Byte_Sequence_Access; -- Temporary, will be removed Attributes : Attribute_Validator_List_Access; -- The list of valid attributes registered for this validator. -- ??? Could be implemented more efficiently through a htable Mixed_Content : Boolean := False; -- Whether character data is allowed in addition to children nodes end record; --------------- -- XML_Group -- --------------- type XML_Group_Record; type XML_Group is access all XML_Group_Record; No_XML_Group : constant XML_Group := null; --------------- -- Particles -- --------------- type Particle_Type is (Particle_Element, Particle_Nested, Particle_Group, Particle_Any, Particle_XML_Type); type XML_Particle; type XML_Particle_Access is access XML_Particle; type XML_Particle (Typ : Particle_Type) is record Min_Occurs : Natural; Max_Occurs : Integer; Next : XML_Particle_Access; case Typ is when Particle_Element => Element : XML_Element; when Particle_Nested => Validator : Group_Model; when Particle_Group => Group : XML_Group; when Particle_XML_Type => Type_Descr : XML_Type; when Particle_Any => Any : XML_Any; end case; end record; type Particle_List_Record is record First, Last : XML_Particle_Access; end record; type Particle_List is access Particle_List_Record; function Empty_Particle_List return Particle_List; -- Return an empty list procedure Append (List : in out Particle_List; Item : XML_Particle); -- Append a new element to the list ----------------------- -- Particle_Iterator -- ----------------------- -- This iterator iterates over a list of particles, but consider a group -- as a set of particles that are also iterated type Particle_Iterator_Record; type Particle_Iterator is access Particle_Iterator_Record; type Particle_Iterator_Record is record Current : XML_Particle_Access; Parent : Particle_Iterator; end record; No_Iter : constant Particle_Iterator := null; function Start (List : Particle_List) return Particle_Iterator; procedure Next (Iter : in out Particle_Iterator); function Get (Iter : Particle_Iterator) return XML_Particle_Access; function Get_Min_Occurs (Iter : Particle_Iterator) return Natural; function Get_Max_Occurs (Iter : Particle_Iterator) return Integer; procedure Free (Iter : in out Particle_Iterator); -- Iterate over a list of particles. Get returns null at the end of the -- iteration ---------------------- -- XML_Group_Record -- ---------------------- type XML_Group_Record is record Local_Name : Unicode.CES.Byte_Sequence_Access; Particles : Particle_List; Is_Forward_Decl : Boolean; -- Set to true if the group was defined as a call to Lookup, but never -- through Create_Global_Group end record; ------------- -- Grammar -- ------------- procedure Free (Typ : in out XML_Type); function Get_Key (Typ : XML_Type) return Unicode.CES.Byte_Sequence; package Types_Htable is new Sax.HTable (Element => XML_Type, Empty_Element => No_Type, Free => Free, Key => Unicode.CES.Byte_Sequence, Get_Key => Get_Key, Hash => Sax.Utils.Hash, Equal => "="); type Types_Htable_Access is access Types_Htable.HTable; -- We store a pointer to an XML_Type_Record, since the validator might not -- be known when we first reference the type (it is valid in an XML schema -- to ref to a type described later on). procedure Free (Element : in out XML_Element_Access); function Get_Key (Element : XML_Element_Access) return Unicode.CES.Byte_Sequence; package Elements_Htable is new Sax.HTable (Element => XML_Element_Access, Empty_Element => null, Free => Free, Key => Unicode.CES.Byte_Sequence, Get_Key => Get_Key, Hash => Sax.Utils.Hash, Equal => "="); type Elements_Htable_Access is access Elements_Htable.HTable; procedure Free (Group : in out XML_Group); function Get_Key (Group : XML_Group) return Unicode.CES.Byte_Sequence; package Groups_Htable is new Sax.HTable (Element => XML_Group, Empty_Element => No_XML_Group, Free => Free, Key => Unicode.CES.Byte_Sequence, Get_Key => Get_Key, Hash => Sax.Utils.Hash, Equal => "="); type Groups_Htable_Access is access Groups_Htable.HTable; function Get_Key (Att : Named_Attribute_Validator) return Unicode.CES.Byte_Sequence; procedure Do_Nothing (Att : in out Named_Attribute_Validator); package Attributes_Htable is new Sax.HTable (Element => Named_Attribute_Validator, Empty_Element => null, Free => Do_Nothing, Key => Unicode.CES.Byte_Sequence, Get_Key => Get_Key, Hash => Sax.Utils.Hash, Equal => "="); type Attributes_Htable_Access is access Attributes_Htable.HTable; function Get_Key (Att : XML_Attribute_Group) return Unicode.CES.Byte_Sequence; procedure Free (Att : in out XML_Attribute_Group); package Attribute_Groups_Htable is new Sax.HTable (Element => XML_Attribute_Group, Empty_Element => Empty_Attribute_Group, Free => Free, Key => Unicode.CES.Byte_Sequence, Get_Key => Get_Key, Hash => Sax.Utils.Hash, Equal => "="); type Attribute_Groups_Htable_Access is access Attribute_Groups_Htable.HTable; type XML_Grammar_NS_Record is record Namespace_URI : Unicode.CES.Byte_Sequence_Access; Types : Types_Htable_Access; Elements : Elements_Htable_Access; Groups : Groups_Htable_Access; Attributes : Attributes_Htable_Access; Attribute_Groups : Attribute_Groups_Htable_Access; Block_Extension : Boolean := False; Block_Restriction : Boolean := False; end record; procedure Free (Grammar : in out XML_Grammar_NS); -- Free the memory occupied by Grammar type Grammar_NS_Array is array (Natural range <>) of XML_Grammar_NS; type Grammar_NS_Array_Access is access all Grammar_NS_Array; type String_List_Record; type String_List is access String_List_Record; type String_List_Record is record Str : Unicode.CES.Byte_Sequence_Access; 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 XML_Grammar is record Grammars : Grammar_NS_Array_Access; -- All the namespaces known for that grammar 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. Target_NS : XML_Grammar_NS; end record; No_Grammar : constant XML_Grammar := (Grammars => null, Target_NS => null, Parsed_Locations => null); ------------------------ -- Group_Model_Record -- ------------------------ type Group_Model_Record is abstract new XML_Validator_Record with record Particles : Particle_List := Empty_Particle_List; end record; type Group_Model_Data_Record is new Validator_Data_Record with record Nested : Group_Model := null; -- If a group_model is nested inside another (a sequence within a -- a sequence for instance), then Nested will point to the nested -- group_model while it is being processed. Nested_Data : Validator_Data := null; -- The data used to evaluate Nested end record; type Group_Model_Data is access all Group_Model_Data_Record'Class; procedure Free_Nested_Group (Data : Group_Model_Data); -- Free the nested group and its data, if any procedure Applies_To_Tag (Group : access Group_Model_Record; Local_Name : Unicode.CES.Byte_Sequence; Namespace_URI : Unicode.CES.Byte_Sequence; NS : XML_Grammar_NS; Schema_Target_NS : XML_Grammar_NS; Applies : out Boolean; Skip_Current : out Boolean); -- Whether Group can process Local_Name. This is used for group_models -- nested in a choice, so that we can find out which one should be applied -- (given the restrictions in schema, only one of them can apply). -- If Group should be called to validate Local_Name, Applies is set to -- True. -- If Local_Name is not handled by Group, Applies is set to False. -- However, if Skip_Current is then set to true, then the group -- matches in fact an empty item, and Local_Name should be passed over to -- the successor of Group in its parent sequence or choice. function Can_Be_Empty (Group : access Group_Model_Record) return Boolean; -- Whether having no child is acceptable for Group procedure Validate_Characters (Validator : access Group_Model_Record; Ch : Unicode.CES.Byte_Sequence; Empty_Element : Boolean); -- See doc for inherited subprograms function Type_Model (Validator : access Group_Model_Record; First_Only : Boolean) return Unicode.CES.Byte_Sequence; -- Return the type model described by Validator. -- If First_Only is true, then only the first element(s) expected should -- be returned. This is mostly to deal with with sequences. -------------------- -- XML_Any_Record -- -------------------- type XML_Any_Record is new XML_Validator_Record with record Process_Contents : Process_Contents_Type; Namespace : Unicode.CES.Byte_Sequence_Access; Target_NS : XML_Grammar_NS; end record; procedure Validate_Start_Element (Validator : access XML_Any_Record; Local_Name : Unicode.CES.Byte_Sequence; Namespace_URI : Unicode.CES.Byte_Sequence; NS : XML_Grammar_NS; Data : Validator_Data; Schema_Target_NS : XML_Grammar_NS; Element_Validator : out XML_Element); procedure Validate_Characters (Validator : access XML_Any_Record; Ch : Unicode.CES.Byte_Sequence; Empty_Element : Boolean); function Get_Namespace_From_Parent_For_Locals (Validator : access XML_Any_Record) return Boolean; --------------------- -- Sequence_Record -- --------------------- type Sequence_Record is new Group_Model_Record with null record; type Sequence_Data is new Group_Model_Data_Record with record Current : Particle_Iterator := No_Iter; Num_Occurs_Of_Current : Integer := 0; -- Number of repeats for the current particle of the sequence. This is -- set to Unbounded to force transition to the next element in the -- sequence. end record; type Sequence_Data_Access is access all Sequence_Data'Class; procedure Validate_Start_Element (Validator : access Sequence_Record; Local_Name : Unicode.CES.Byte_Sequence; Namespace_URI : Unicode.CES.Byte_Sequence; NS : XML_Grammar_NS; Data : Validator_Data; Schema_Target_NS : XML_Grammar_NS; Element_Validator : out XML_Element); procedure Validate_End_Element (Validator : access Sequence_Record; Local_Name : Unicode.CES.Byte_Sequence; Data : Validator_Data); function Create_Validator_Data (Validator : access Sequence_Record) return Validator_Data; procedure Applies_To_Tag (Group : access Sequence_Record; Local_Name : Unicode.CES.Byte_Sequence; Namespace_URI : Unicode.CES.Byte_Sequence; NS : XML_Grammar_NS; Schema_Target_NS : XML_Grammar_NS; Applies : out Boolean; Skip_Current : out Boolean); function Can_Be_Empty (Group : access Sequence_Record) return Boolean; function Type_Model (Validator : access Sequence_Record; First_Only : Boolean) return Unicode.CES.Byte_Sequence; -- See doc for inherited subprograms ------------------- -- Choice_Record -- ------------------- type Choice_Record is new Group_Model_Record with null record; type Choice_Data is new Group_Model_Data_Record with record Current : Particle_Iterator := No_Iter; Num_Occurs_Of_Current : Natural; end record; type Choice_Data_Access is access all Choice_Data'Class; procedure Validate_Start_Element (Validator : access Choice_Record; Local_Name : Unicode.CES.Byte_Sequence; Namespace_URI : Unicode.CES.Byte_Sequence; NS : XML_Grammar_NS; Data : Validator_Data; Schema_Target_NS : XML_Grammar_NS; Element_Validator : out XML_Element); procedure Validate_End_Element (Validator : access Choice_Record; Local_Name : Unicode.CES.Byte_Sequence; Data : Validator_Data); function Create_Validator_Data (Validator : access Choice_Record) return Validator_Data; procedure Applies_To_Tag (Group : access Choice_Record; Local_Name : Unicode.CES.Byte_Sequence; Namespace_URI : Unicode.CES.Byte_Sequence; NS : XML_Grammar_NS; Schema_Target_NS : XML_Grammar_NS; Applies : out Boolean; Skip_Current : out Boolean); function Can_Be_Empty (Group : access Choice_Record) return Boolean; function Type_Model (Validator : access Choice_Record; First_Only : Boolean) return Unicode.CES.Byte_Sequence; -- See doc for inherited subprograms -------------------- -- XML_All_Record -- -------------------- type Natural_Array is array (Natural range <>) of Natural; type XML_All_Record is new Choice_Record with record Min_Occurs : Natural; Max_Occurs : Integer; end record; type All_Data (Num_Elements : Integer) is new Group_Model_Data_Record with record All_Elements : Natural_Array (1 .. Num_Elements); Num_Occurs : Natural; end record; type All_Data_Access is access all All_Data'Class; procedure Validate_Start_Element (Validator : access XML_All_Record; Local_Name : Unicode.CES.Byte_Sequence; Namespace_URI : Unicode.CES.Byte_Sequence; NS : XML_Grammar_NS; Data : Validator_Data; Schema_Target_NS : XML_Grammar_NS; Element_Validator : out XML_Element); procedure Validate_End_Element (Validator : access XML_All_Record; Local_Name : Unicode.CES.Byte_Sequence; Data : Validator_Data); function Create_Validator_Data (Validator : access XML_All_Record) return Validator_Data; function Type_Model (Validator : access XML_All_Record; First_Only : Boolean) return Unicode.CES.Byte_Sequence; function Can_Be_Empty (Group : access XML_All_Record) return Boolean; -- See doc for inherited subprograms procedure Debug_Output (Str : String); pragma Inline (Debug_Output); -- Display a string for debugging purposes function Get_Name (Validator : access XML_Validator_Record'Class) return String; -- Return a string "(rule "name")" if the name of the validator is defined. -- This is for debug purposes only end Schema.Validators;