------------------------------------------------------------------------------ -- 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.Characters.Handling; use Ada.Characters.Handling; with Ada.Exceptions; use Ada.Exceptions; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with Ada.Unchecked_Deallocation; with GNAT.Task_Lock; with Interfaces; use Interfaces; with Sax.Attributes; use Sax.Attributes; with Sax.Locators; use Sax.Locators; with Sax.Symbols; use Sax.Symbols; with Sax.Utils; use Sax.Utils; with Schema.Simple_Types; use Schema.Simple_Types; with Schema.Validators.XSD_Grammar; use Schema.Validators.XSD_Grammar; with Unicode.CES; use Unicode.CES; with Unicode; use Unicode; package body Schema.Validators is use XML_Grammars, Attributes_Tables, Enumeration_Tables; use Schema_State_Machines_Matchers; function To_Graphic_String (Str : byte_sequence) return String; -- Convert non-graphic characters in Str to make them visible in a display type attribute_validator_data is record Validator : named_attribute_list; -- Index into the table Visited : Boolean; end record; type attribute_validator_index is new Natural; type attribute_validator_array is array (attribute_validator_index range <>) of attribute_validator_data; function To_Attribute_Array (NFA : access schema_nfa'class; Attributes : attributes_list) return attribute_validator_array; -- The data required to validate attributes procedure Create_Grammar_If_Needed (Grammar : in out xml_grammar; Symbols : symbol_table := No_Symbol_Table); -- Create the grammar if needed -- Symbols is used only when a new grammar is created. procedure Validate_Attribute (Attr : attribute_descr; Reader : access abstract_validation_reader'class; Atts : in out sax_attribute_list; Index : Natural); -- Validate the value of a single attribute procedure Reset_Simple_Types (NFA : access schema_nfa'class; To : simple_type_index := No_Simple_Type_Index); -- Resets the contents of G.Simple_Types by resizing the table and freeing -- needed data -- If [To] is [No_Simple_Type_Index], the table is freed function To_String (Any : any_descr) return String; -- Debug only --------------- -- To_String -- --------------- function To_String (Any : any_descr) return String is Str : Unbounded_String; begin Append (Str, "{" & Any.Process_Contents'img); if Any.Namespaces /= No_Symbol then Append (Str, " ns={" & Get (Any.Namespaces).all & "}"); end if; if Any.No_Namespaces /= No_Symbol then Append (Str, " no_ns={" & Get (Any.No_Namespaces).all & "}"); end if; return To_String (Str) & "}"; end To_String; ---------------------- -- Validation_Error -- ---------------------- procedure Validation_Error (Reader : access abstract_validation_reader; Message : byte_sequence; Loc : Sax.Locators.location := Sax.Locators.No_Location; Except : Exception_Id := XML_Validation_Error'identity) is begin if Debug then Debug_Output ("Validation_Error: " & Message); end if; if Loc /= No_Location then Reader.Error_Location := Loc; else Reader.Error_Location := Reader.Current_Location; end if; if Message (Message'first) = '#' then Reader.Error_Msg := Find_Symbol (Reader.all, Message (Message'first + 1 .. Message'last)); raise XML_Not_Implemented; else Reader.Error_Msg := Find_Symbol (Reader.all, Message); Raise_Exception (Except); end if; end Validation_Error; ----------------------- -- Get_Error_Message -- ----------------------- function Get_Error_Message (Reader : abstract_validation_reader) return Unicode.CES.byte_sequence is Loc : location; begin if Reader.Error_Msg = No_Symbol then return ""; else Loc := Reader.Error_Location; if Loc = No_Location then Loc := Reader.Current_Location; end if; declare Error : constant cst_byte_sequence_access := Get (Reader.Error_Msg); begin if Loc /= No_Location then return To_String (Loc, Use_Basename_In_Error_Messages (Reader)) & ": " & Error.all; else return Error.all; end if; end; end if; end Get_Error_Message; ----------------------- -- Add_Any_Attribute -- ----------------------- procedure Add_Any_Attribute (Grammar : xml_grammar; List : in out attributes_list; Any : internal_any_descr; As_Restriction : Boolean) is begin List.Any := Combine (Grammar => Grammar, Base_Any => List.Any, Local_Process => Any.Process_Contents, Local => Any.Namespaces, As_Restriction => As_Restriction, Target_NS => Any.Target_NS); end Add_Any_Attribute; ---------------------------- -- Normalize_And_Validate -- ---------------------------- 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) is begin if Fixed /= No_Symbol and then Simple /= No_Simple_Type_Index then declare Simple_Descr : constant simple_type_descr := Get_NFA (Parser.Grammar).Get_Simple_Type (Simple); Norm : byte_sequence := Get (Fixed).all; Last : Integer := Norm'last; begin -- Normalize whitespaces, for faster comparison later -- on. if Simple_Descr.Mask (facet_whitespace) then Normalize_Whitespace (Simple_Descr.Whitespace, Norm, Last); Fixed := Find (Get_Symbol_Table (Parser.Grammar), Norm (Norm'first .. Last)); end if; Validate_Simple_Type (Reader => Parser, Simple_Type => Simple, Ch => Norm (Norm'first .. Last), Loc => Loc, Insert_Id => True); end; end if; end Normalize_And_Validate; ------------------- -- Add_Attribute -- ------------------- 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) is NFA : constant schema_nfa_access := Get_NFA (Parser.Grammar); L : named_attribute_list := List.Named; Tmp : named_attribute_list; Attr : attribute_descr := Attribute; begin if Debug then Debug_Output ("Adding attribute " & To_QName (Attribute.Name) & " Use_Type=" & Attribute.Use_Type'img & " local=" & Attribute.Is_Local'img); end if; while L /= Empty_Named_Attribute_List loop if NFA.Attributes.Table (L).Name = Attribute.Name then -- Override use_type, form,... from the Tmp := NFA.Attributes.Table (L).Next; Attr := Attribute; Normalize_And_Validate (Parser, Attr.Simple_Type, Attr.Fixed, Loc); NFA.Attributes.Table (L) := Attr; NFA.Attributes.Table (L).Next := Tmp; return; end if; L := NFA.Attributes.Table (L).Next; end loop; if Ref /= Empty_Named_Attribute_List then Attr := NFA.Attributes.Table (Ref); Attr.Use_Type := Attribute.Use_Type; Attr.Is_Local := Attribute.Is_Local; if Attribute.Fixed /= No_Symbol then Attr.Fixed := Attribute.Fixed; end if; end if; Normalize_And_Validate (Parser, Attr.Simple_Type, Attr.Fixed, Loc); Append (NFA.Attributes, Attr); NFA.Attributes.Table (Last (NFA.Attributes)).Next := List.Named; List.Named := Last (NFA.Attributes); end Add_Attribute; -------------------- -- Add_Attributes -- -------------------- procedure Add_Attributes (Parser : access abstract_validation_reader'class; List : in out attributes_list; Attributes : attributes_list; As_Restriction : Boolean; Loc : Sax.Locators.location) is NFA : constant schema_nfa_access := Get_NFA (Parser.Grammar); L : named_attribute_list := Attributes.Named; begin while L /= Empty_Named_Attribute_List loop Add_Attribute (Parser, List, NFA.Attributes.Table (L), Loc => Loc); L := NFA.Attributes.Table (L).Next; end loop; Add_Any_Attribute (Parser.Grammar, List, internal_any_descr' (Target_NS => Empty_String, Process_Contents => Attributes.Any.Process_Contents, Namespaces => Attributes.Any.Namespaces), As_Restriction); end Add_Attributes; ------------------------ -- To_Attribute_Array -- ------------------------ function To_Attribute_Array (NFA : access schema_nfa'class; Attributes : attributes_list) return attribute_validator_array is Count : attribute_validator_index := 0; L : named_attribute_list := Attributes.Named; begin while L /= Empty_Named_Attribute_List loop Count := Count + 1; L := NFA.Attributes.Table (L).Next; end loop; declare Result : attribute_validator_array (1 .. Count); begin Count := Result'first; L := Attributes.Named; while L /= Empty_Named_Attribute_List loop Result (Count) := (Validator => L, Visited => False); Count := Count + 1; L := NFA.Attributes.Table (L).Next; end loop; return Result; end; end To_Attribute_Array; ------------- -- Combine -- ------------- function Combine (Grammar : xml_grammar; Base_Any : any_descr; Local_Process : process_contents_type; Local : Sax.Symbols.symbol; As_Restriction : Boolean; Target_NS : Sax.Symbols.symbol) return any_descr is use Symbol_Htable; Namespaces : Symbol_Htable.htable (127); No_Namespaces : Symbol_Htable.htable (127); Tmp : Symbol_Htable.htable (127); Result : any_descr; Base_Is_Any, Local_Is_Any : Boolean; Symbols : constant symbol_table := Get (Grammar).Symbols; procedure Callback (Str : byte_sequence); procedure Add_To_Table (Sym : symbol; Table : in out Symbol_Htable.htable); procedure Merge (Sym : symbol); -- Take all namespaces in [Sym], and copy, in [Namespaces], those that -- are also in [Tmp], but not in [No_Namespaces] function To_Symbol (Table : Symbol_Htable.htable) return symbol; -- Return the list of strings in Table ----------- -- Merge -- ----------- procedure Merge (Sym : symbol) is procedure Callback (Str : byte_sequence); procedure Do_Merge (S : symbol); -------------- -- Do_Merge -- -------------- procedure Do_Merge (S : symbol) is begin if Base_Is_Any or else ((Base_Any.Namespaces = No_Symbol or else Get (Tmp, S) /= No_Symbol) and then Get (No_Namespaces, S) = No_Symbol) then Set (Namespaces, S); end if; end Do_Merge; -------------- -- Callback -- -------------- procedure Callback (Str : byte_sequence) is begin if Str = "##targetNamespace" then Do_Merge (Target_NS); elsif Str = "##other" then if Target_NS /= No_Symbol then Set (No_Namespaces, Target_NS); end if; Set (No_Namespaces, Find (Symbols, "##local")); else Do_Merge (Find (Symbols, Str)); -- including ##any, ##local end if; end Callback; procedure All_Add is new For_Each_Item (Callback); begin if Sym /= No_Symbol then All_Add (Get (Sym).all); end if; end Merge; ------------------ -- Add_To_Table -- ------------------ procedure Add_To_Table (Sym : symbol; Table : in out Symbol_Htable.htable) is procedure Callback (Str : byte_sequence); -------------- -- Callback -- -------------- procedure Callback (Str : byte_sequence) is begin Set (Table, Find (Symbols, Str)); end Callback; procedure All_Add is new For_Each_Item (Callback); begin if Sym /= No_Symbol then All_Add (Get (Sym).all); end if; end Add_To_Table; --------------- -- To_Symbol -- --------------- function To_Symbol (Table : Symbol_Htable.htable) return symbol is Str : Unbounded_String; S : symbol; Iter : iterator := Symbol_Htable.First (Table); begin if Iter = No_Iterator then return No_Symbol; end if; while Iter /= No_Iterator loop S := Current (Iter); if Str = Null_Unbounded_String then Append (Str, Get (S).all); else Append (Str, " " & Get (S).all); end if; Symbol_Htable.Next (Table, Iter); end loop; return Find (Get (Grammar).Symbols, To_String (Str)); end To_Symbol; -------------- -- Callback -- -------------- procedure Callback (Str : byte_sequence) is begin if Str = "##targetNamespace" then if Target_NS = Empty_String then Set (Namespaces, Find (Symbols, "##local")); else Set (Namespaces, Target_NS); end if; elsif Str = "##other" then if Target_NS /= No_Symbol then Set (No_Namespaces, Target_NS); end if; Set (No_Namespaces, Find (Symbols, "##local")); else Set (Namespaces, Find (Symbols, Str)); -- including ##any, ##local end if; end Callback; procedure All_Items is new For_Each_Item (Callback); begin if Base_Any = No_Any_Descr then if Local /= No_Symbol then All_Items (Get (Local).all); end if; declare Result : constant any_descr := any_descr' (Process_Contents => Local_Process, No_Namespaces => To_Symbol (No_Namespaces), Namespaces => To_Symbol (Namespaces)); begin Reset (Namespaces); Reset (No_Namespaces); Reset (Tmp); return Result; end; end if; Local_Is_Any := Local /= No_Symbol and then Get (Local).all = "##any"; Base_Is_Any := Base_Any.Namespaces /= No_Symbol and then Get (Base_Any.Namespaces).all = "##any"; if As_Restriction then -- The list of "Namespaces" is the intersection of the two (and -- empty if local is empty) -- From this, remove the list of the base's "No_Namespaces". -- We preserve those "No_Namespaces" into the new type, though. Add_To_Table (Base_Any.No_Namespaces, No_Namespaces); if Local_Is_Any then if Base_Any.Namespaces /= No_Symbol then Add_To_Table (Base_Any.Namespaces, Namespaces); elsif Local /= No_Symbol then Add_To_Table (Local, Namespaces); end if; else Add_To_Table (Base_Any.Namespaces, Tmp); Merge (Local); end if; else -- If the base type or the extension contains ##any, we will still -- accept any namespace if Base_Is_Any then Add_To_Table (Base_Any.Namespaces, Namespaces); -- ##any elsif Local_Is_Any then if Base_Any.No_Namespaces /= No_Symbol then Add_To_Table (Base_Any.No_Namespaces, No_Namespaces); elsif Local /= No_Symbol then Add_To_Table (Local, Namespaces); -- ##any end if; else -- None of the two is ##any, so we just combine them. Since we -- have an extension, the attributes will have to match any of -- the namespaces. Add_To_Table (Base_Any.Namespaces, Namespaces); Add_To_Table (Base_Any.No_Namespaces, No_Namespaces); if Local /= No_Symbol then All_Items (Get (Local).all); end if; end if; end if; Result.Process_Contents := Local_Process; Result.Namespaces := To_Symbol (Namespaces); Result.No_Namespaces := To_Symbol (No_Namespaces); -- ??? If .Namespaces contain one common NS with .No_Namespaces, then -- we really have a ##any if Debug then if Local /= No_Symbol then Debug_Output ("Combine " & To_String (Base_Any) & " and {" & Local_Process'img & " " & Get (Local).all & " target=" & Get (Target_NS).all & "} restr=" & As_Restriction'img & " => " & To_String (Result)); else Debug_Output ("Combine " & To_String (Base_Any) & " and {" & Local_Process'img & " target=" & Get (Target_NS).all & "} restr=" & As_Restriction'img & " => " & To_String (Result)); end if; end if; Reset (Namespaces); Reset (No_Namespaces); Reset (Tmp); return Result; exception when others => Reset (Namespaces); Reset (No_Namespaces); Reset (Tmp); raise; end Combine; --------------- -- Match_Any -- --------------- function Match_Any (Any : any_descr; Name : qualified_name) return Boolean is Matches : Boolean := False; Invalid_No_NS : Boolean := False; procedure Callback (Str : byte_sequence); procedure Negate_Callback (Str : byte_sequence); --------------------- -- Negate_Callback -- --------------------- procedure Negate_Callback (Str : byte_sequence) is begin if Str = "##local" then Invalid_No_NS := Invalid_No_NS or else Name.NS = Empty_String; else Invalid_No_NS := Invalid_No_NS or else Get (Name.NS).all = Str; end if; end Negate_Callback; -------------- -- Callback -- -------------- procedure Callback (Str : byte_sequence) is begin if Matches then null; elsif Str = "##local" then Matches := Name.NS = Empty_String; else Matches := Get (Name.NS).all = Str; end if; end Callback; procedure All_Items is new For_Each_Item (Callback); procedure Negate_All_Items is new For_Each_Item (Negate_Callback); begin if Debug then Debug_Output ("match : " & To_String (Any) & " and " & To_QName (Name)); end if; if Any.Namespaces /= No_Symbol and then Get (Any.Namespaces).all = "##any" then return True; end if; if Any.Namespaces /= No_Symbol then All_Items (Get (Any.Namespaces).all); end if; if Any.No_Namespaces /= No_Symbol then Negate_All_Items (Get (Any.No_Namespaces).all); end if; if Debug then Debug_Output ("Matches=" & Matches'img & " Invalid_No_NS=" & Invalid_No_NS'img); end if; if Any.Namespaces /= No_Symbol and then Any.No_Namespaces /= No_Symbol then return Matches or else not Invalid_No_NS; elsif Any.Namespaces /= No_Symbol then return Matches; elsif Any.No_Namespaces /= No_Symbol then return not Invalid_No_NS; else return False; end if; end Match_Any; ------------------------- -- Validate_Attributes -- ------------------------- 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) is Length : constant Natural := Get_Length (Atts); Valid_Attrs : attribute_validator_array := To_Attribute_Array (NFA, Typ.Attributes); type attr_status is record Prohibited : Boolean := False; -- Prohibited explicitly, but it might be allowed through -- Seen : Boolean := False; end record; Seen : array (1 .. Length) of attr_status := (others => (False, False)); function Find_Attribute (Attr : attribute_descr) return Integer; -- Chech whether Named appears in Atts procedure Check_Named_Attribute (Index : attribute_validator_index); -- Check a named attribute or a wildcard attribute procedure Check_Single_ID; -- If using XSD 1.0, check that there is a single ID attribute. -- This relies on the Sax.Attributes.Get_Type being set correctly. -- XSD 1.0 prevents having two such attributes, for easier conversion -- to DTD (see G.1.7 ID, IDREF, and related types) --------------------- -- Check_Single_ID -- --------------------- procedure Check_Single_ID is Seen_ID : Boolean := False; begin for A in 1 .. Length loop if Get_Type (Atts, A) = Sax.Attributes.id then if Seen_ID then Validation_Error (Reader, "Elements can have a single ID attribute in XSD 1.0"); end if; Seen_ID := True; end if; end loop; end Check_Single_ID; --------------------------- -- Check_Named_Attribute -- --------------------------- procedure Check_Named_Attribute (Index : attribute_validator_index) is Found : Integer; Attr : attribute_descr renames NFA.Attributes.Table (Valid_Attrs (Index).Validator); begin if not Valid_Attrs (Index).Visited then if Debug then Debug_Output ("Checking attribute: " & To_QName (NFA.Attributes.Table (Valid_Attrs (Index).Validator) .Name) & " " & Attr.Use_Type'img & " " & Attr.Form'img); end if; Valid_Attrs (Index).Visited := True; Found := Find_Attribute (Attr); if Found = -1 then case Attr.Use_Type is when required => Validation_Error (Reader, "Attribute """ & To_QName (Attr.Name) & """ is required in this context"); when prohibited | optional | default => null; end case; else Seen (Found).Seen := True; case Attr.Form is when qualified => if Attr.Is_Local and then Get_Prefix (Atts, Found) = Empty_String then Validation_Error (Reader, "Attribute " & Get_Qname (Atts, Found) & " must have a namespace"); end if; when unqualified => if Attr.Is_Local and then Get_Prefix (Atts, Found) /= Empty_String then Validation_Error (Reader, "Attribute " & Get_Qname (Atts, Found) & " must not have a namespace"); end if; end case; case Attr.Use_Type is when prohibited => if Debug then Debug_Output ("Marking as prohibited, might be accepted by" & " "); end if; Seen (Found) := (Seen => False, Prohibited => True); when optional | required | default => -- We do not need to check id here, since that is -- automatically checked from Validate_Characters for the -- attribute Validate_Attribute (Attr, Reader, Atts, Found); end case; end if; end if; end Check_Named_Attribute; -------------------- -- Find_Attribute -- -------------------- function Find_Attribute (Attr : attribute_descr) return Integer is Is_Local : constant Boolean := Attr.Is_Local; Matches : Boolean; begin for A in 1 .. Length loop if not Seen (A).Seen and then Get_Name (Atts, A).Local = Attr.Name.Local then Matches := (Is_Local and Get_Prefix (Atts, A) = Empty_String) or else Get_Name (Atts, A).NS = Attr.Name.NS; if Matches then if Debug then Debug_Output ("Found attribute: " & To_QName (Get_Name (Atts, A)) & " prefix=" & Get (Get_Prefix (Atts, A)).all & " at index" & A'img & " Is_Local=" & Is_Local'img & " Form=" & Attr.Form'img); end if; return A; end if; end if; end loop; return -1; end Find_Attribute; begin -- All the xsi:* attributes should be valid, whatever the schema for S in Seen'range loop if Get_Name (Atts, S).NS = Reader.XML_Instance_URI then if Get_Name (Atts, S).Local = Reader.Nil then Is_Nil := S; Seen (S).Seen := True; -- Following attributes are always valid -- See "Element Locally Valid (Complex Type)" 3.4.4.2 elsif Get_Name (Atts, S).Local = Reader.Typ or else Get_Name (Atts, S).Local = Reader.Schema_Location or else Get_Name (Atts, S).Local = Reader.No_Namespace_Schema_Location then Seen (S).Seen := True; end if; end if; end loop; for L in Valid_Attrs'range loop Check_Named_Attribute (L); end loop; declare TRef : global_reference; begin for S in Seen'range loop if not Seen (S).Seen then Seen (S).Seen := Match_Any (Typ.Attributes.Any, Get_Name (Atts, S)); if not Seen (S).Seen then if Seen (S).Prohibited then Validation_Error (Reader, "Attribute """ & Get_Qname (Atts, S) & """ is prohibited in this context " & To_QName (Typ.Name)); elsif Typ.Attributes.Any = No_Any_Descr then Validation_Error (Reader, "Attribute """ & Get_Qname (Atts, S) & """ invalid for type " & To_QName (Typ.Name)); else Validation_Error (Reader, "Attribute """ & Get_Qname (Atts, S) & """ does not match attribute wildcard"); end if; end if; -- If the processing content forces it, we must check that -- there is indeed a valid definition for this attribute. case Typ.Attributes.Any.Process_Contents is when process_skip => null; -- Always OK TRef := No_Global_Reference; when process_lax => TRef := Reference_HTables.Get (NFA.References.all, (Get_Name (Atts, S), ref_attribute)); when process_strict => TRef := Reference_HTables.Get (NFA.References.all, (Get_Name (Atts, S), ref_attribute)); if TRef = No_Global_Reference then Validation_Error (Reader, "No definition found for """ & Get_Qname (Atts, S) & """"); end if; end case; if TRef /= No_Global_Reference then Validate_Attribute (NFA.Attributes.Table (TRef.Attributes.Named), Reader, Atts, S); end if; Seen (S).Prohibited := False; end if; end loop; end; Check_Single_ID; end Validate_Attributes; ----------------------- -- To_Graphic_String -- ----------------------- function To_Graphic_String (Str : byte_sequence) return String is To_Hex : constant array (0 .. 15) of Character := ('0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'); Result : String (1 .. 4 * Str'length); Index : Integer := Result'first; begin for S in Str'range loop if Character'pos (Str (S)) >= 32 and then Character'pos (Str (S)) <= 128 and then Is_Graphic (Str (S)) then Result (Index) := Str (S); Index := Index + 1; else Result (Index) := '['; Result (Index + 1) := To_Hex (Character'pos (Str (S)) / 16); Result (Index + 2) := To_Hex (Character'pos (Str (S)) mod 16); Result (Index + 3) := ']'; Index := Index + 4; end if; end loop; return Result (1 .. Index - 1); end To_Graphic_String; ------------------------ -- Validate_Attribute -- ------------------------ procedure Validate_Attribute (Attr : attribute_descr; Reader : access abstract_validation_reader'class; Atts : in out sax_attribute_list; Index : Natural) is Value : symbol := Get_Value (Atts, Index); Val : cst_byte_sequence_access; Is_Equal : Boolean; Descr : simple_type_descr; begin if Debug then Debug_Output ("Validate attribute " & To_QName (Attr.Name) & " simpleType=" & Attr.Simple_Type'img); end if; if Attr.Simple_Type = No_Simple_Type_Index then if Debug then Debug_Output ("No simple type defined"); end if; else Descr := Get_Simple_Type (Get (Reader.Grammar).NFA, Attr.Simple_Type); Normalize_And_Validate (Parser => Reader, Simple => Attr.Simple_Type, Fixed => Value, Loc => Get_Location (Atts, Index)); Set_Value (Atts, Index, Value); if Descr.Kind = primitive_id then Set_Type (Atts, Index, Sax.Attributes.id); end if; end if; Val := Get (Value); -- 3.2.4 [Attribute Declaration Value] indicates we should check Fixed -- with the "actual value" of the attribute, not the "normalized value". -- However, we need to match depending on the type of the attribute: if -- it is an integer, the whitespaces are irrelevant; likewise for a list if Attr.Fixed /= No_Symbol then if Debug then Debug_Output ("Attribute value must be equal to """ & Get (Attr.Fixed).all & """"); end if; if Attr.Simple_Type = No_Simple_Type_Index then Is_Equal := Get (Attr.Fixed).all = Val.all; else Is_Equal := Equal (Reader, Attr.Simple_Type, Attr.Fixed, Val.all); end if; if not Is_Equal then Validation_Error (Reader, "value must be """ & To_Graphic_String (Get (Attr.Fixed).all) & """ (found """ & To_Graphic_String (Val.all) & """)", Get_Location (Atts, Index)); end if; end if; end Validate_Attribute; -------------- -- To_QName -- -------------- function To_QName (Name : qualified_name) return Unicode.CES.byte_sequence is begin if Name = No_Qualified_Name then return ""; else return Sax.Readers.To_QName (Name.NS, Name.Local); end if; end To_QName; ---------------------- -- Get_Symbol_Table -- ---------------------- function Get_Symbol_Table (Grammar : xml_grammar) return Sax.Utils.symbol_table is begin if Grammar = No_Grammar then return Symbol_Table_Pointers.Null_Pointer; else return Get (Grammar).Symbols; end if; end Get_Symbol_Table; ---------------------- -- Set_Symbol_Table -- ---------------------- procedure Set_Symbol_Table (Grammar : xml_grammar; Symbols : Sax.Utils.symbol_table) is begin if Grammar /= No_Grammar then Get (Grammar).Symbols := Symbols; end if; end Set_Symbol_Table; ---------- -- Free -- ---------- procedure Free (List : in out string_list) is procedure Unchecked_Free is new Ada.Unchecked_Deallocation (string_list_record, string_list); L : string_list; begin while List /= null loop L := List.Next; Unchecked_Free (List); List := L; end loop; end Free; ------------------------------ -- Create_Grammar_If_Needed -- ------------------------------ procedure Create_Grammar_If_Needed (Grammar : in out xml_grammar; Symbols : symbol_table := No_Symbol_Table) is use Types_Tables; G : XML_Grammars.encapsulated_access; begin if Grammar = No_Grammar then G := new xml_grammar_record; G.Symbols := Symbols; G.NFA := new schema_nfa; G.NFA.Initialize (States_Are_Statefull => True); Init (G.NFA.Attributes); Init (G.NFA.Enumerations); Init (G.NFA.Types); G.NFA.References := new Reference_HTables.htable (Size => reference_htable_size); Simple_Type_Tables.Init (G.NFA.Simple_Types); Grammar := Allocate (G); end if; end Create_Grammar_If_Needed; --------------------- -- Set_XSD_Version -- --------------------- procedure Set_XSD_Version (Grammar : in out xml_grammar; XSD_Version : xsd_versions) is begin Create_Grammar_If_Needed (Grammar); GNAT.Task_Lock.Lock; Get (Grammar).XSD_Version := XSD_Version; GNAT.Task_Lock.Unlock; end Set_XSD_Version; --------------------- -- Get_XSD_Version -- --------------------- function Get_XSD_Version (Grammar : xml_grammar) return xsd_versions is G : XML_Grammars.encapsulated_access; begin G := Get (Grammar); if G = null then return xsd_1_1; else return G.XSD_Version; end if; end Get_XSD_Version; ----------------------------- -- Create_Global_Attribute -- ----------------------------- procedure Create_Global_Attribute (Parser : access abstract_validation_reader'class; Attr : attribute_descr; Loc : Sax.Locators.location) is use Reference_HTables; NFA : constant schema_nfa_access := Get_NFA (Parser.Grammar); List : attributes_list := No_Attributes; begin Add_Attribute (Parser, List, Attr, Loc => Loc); Set (NFA.References.all, (Kind => ref_attribute, Name => Attr.Name, Attributes => List)); end Create_Global_Attribute; ------------------------ -- Create_Simple_Type -- ------------------------ function Create_Simple_Type (NFA : access schema_nfa'class; Descr : Schema.Simple_Types.simple_type_descr) return Schema.Simple_Types.simple_type_index is use Simple_Type_Tables; begin Append (NFA.Simple_Types, Descr); return Last (NFA.Simple_Types); end Create_Simple_Type; ----------------- -- Create_Type -- ----------------- function Create_Type (NFA : access schema_nfa'class; Descr : type_descr) return type_index is use Reference_HTables, Types_Tables; begin Append (NFA.Types, Descr); if Descr.Name /= No_Qualified_Name then if Debug then Debug_Output ("Create_global_type: " & To_QName (Descr.Name) & " at index" & Last (NFA.Types)'img); end if; Set (NFA.References.all, (ref_type, Descr.Name, Last (NFA.Types))); end if; return Last (NFA.Types); end Create_Type; --------------------- -- Get_Simple_Type -- --------------------- function Get_Simple_Type (NFA : access schema_nfa'class; Simple : Schema.Simple_Types.simple_type_index) return Schema.Simple_Types.simple_type_descr is begin return NFA.Simple_Types.Table (Simple); end Get_Simple_Type; -------------------- -- Get_Type_Descr -- -------------------- function Get_Type_Descr (NFA : access schema_nfa'class; Index : type_index) return access type_descr is begin return NFA.Types.Table (Index)'unrestricted_access; end Get_Type_Descr; ------------------- -- Simple_Nested -- ------------------- function Simple_Nested (NFA : access schema_nfa'class) return Schema_State_Machines.state is begin return NFA.Simple_Nested; end Simple_Nested; ------------------------ -- Initialize_Grammar -- ------------------------ procedure Initialize_Grammar (Reader : in out abstract_validation_reader'class) is use Reference_HTables, Simple_Type_Tables; G : XML_Grammars.encapsulated_access; function Register (Local : byte_sequence; Descr : simple_type_descr; Restriction_Of : type_index) return type_index; function Create_UR_Type (Process_Contents : process_contents_type) return state; -- Return the start state for a nested NFA for ur-type -- All children (at any depth level) are allowed. -- Any character contents is allowed. -------------- -- Register -- -------------- function Register (Local : byte_sequence; Descr : simple_type_descr; Restriction_Of : type_index) return type_index is Simple : simple_type_index; begin Simple := Create_Simple_Type (G.NFA, Descr); return Create_Type (G.NFA, type_descr' (Name => (NS => Reader.XML_Schema_URI, Local => Find (G.Symbols, Local)), Attributes => No_Attributes, Block => No_Block, Final => (others => False), Restriction_Of => Restriction_Of, Extension_Of => No_Type_Index, Simple_Content => Simple, Mixed => False, Is_Abstract => False, Complex_Content => No_State)); end Register; -------------------- -- Create_UR_Type -- -------------------- function Create_UR_Type (Process_Contents : process_contents_type) return state is S1 : constant state := G.NFA.Add_State; Ur_Type : constant nested_nfa := G.NFA.Create_Nested (S1); S2, S3 : state; List : attributes_list := No_Attributes; Index : type_index; begin List.Any := any_descr' (Process_Contents => process_lax, No_Namespaces => No_Symbol, Namespaces => Reader.Any_Namespace); Index := Create_Type (G.NFA, type_descr' (Name => (NS => Reader.XML_Schema_URI, Local => Reader.Ur_Type), Attributes => List, Mixed => True, Complex_Content => S1, others => <>)); G.NFA.Set_Data (S1, (Simple => Index, Fixed => No_Symbol, Default => No_Symbol, Nillable => True, Block => No_Block)); S2 := G.NFA.Add_State ((Simple => Index, Fixed => No_Symbol, Default => No_Symbol, Nillable => True, Block => No_Block)); G.NFA.Set_Nested (S2, Ur_Type); pragma assert (Reader.Any_Namespace /= No_Symbol); G.NFA.Add_Transition (S1, S2, (Kind => transition_any, Any => (Process_Contents => Process_Contents, Namespaces => Reader.Any_Namespace, No_Namespaces => No_Symbol))); S3 := G.NFA.Add_State; G.NFA.On_Empty_Nested_Exit (S2, S3); G.NFA.Add_Empty_Transition (S3, S1); -- maxOccurs="unbounded" G.NFA.Add_Empty_Transition (S1, S3); -- minOccurs="0" G.NFA.Add_Transition (S3, Final_State, (Kind => transition_close)); return S1; end Create_UR_Type; procedure Do_Register is new Register_Predefined_Types (type_index, No_Type_Index, Register); Attr : attribute_descr; begin Create_Grammar_If_Needed (Reader.Grammar, Get_Symbol_Table (Reader)); -- In the case of a shared grammar, created will always be false (since -- it has already been parsed), so the code below will not be called. -- As such, it is safe to let it modify the grammar. G := Get (Reader.Grammar); if Get (G.NFA.References.all, (Name => (NS => Reader.XML_Schema_URI, Local => Reader.S_Boolean), Kind => ref_type)) = No_Global_Reference then Do_Register (G.Symbols); -- Simple types Attr := (Name => (NS => Reader.XML_URI, Local => Reader.Lang), Form => qualified, others => <>); Create_Global_Attribute (Reader'access, Attr, No_Location); Attr := (Name => (NS => Reader.XML_URI, Local => Find (G.Symbols, "space")), Form => qualified, others => <>); Create_Global_Attribute (Reader'access, Attr, No_Location); Attr := (Name => (NS => Reader.XML_URI, Local => Reader.Base), Form => qualified, others => <>); Create_Global_Attribute (Reader'access, Attr, No_Location); -- Added support for G.NFA.Ur_Type := Create_UR_Type (process_lax); G.NFA.Ur_Type_Skip := Create_UR_Type (process_skip); Add_Schema_For_Schema (Reader); -- The simple nested NFA G.NFA.Simple_Nested := G.NFA.Add_State; G.NFA.Add_Transition (G.NFA.Simple_Nested, Final_State, (Kind => transition_close)); -- Save the current state, so that we can restore the grammar to just -- this metaschema. G.NFA.Metaschema_NFA_Last := Get_Snapshot (G.NFA); G.NFA.Metaschema_Simple_Types_Last := Simple_Type_Tables.Last (G.NFA.Simple_Types); G.NFA.Metaschema_Attributes_Last := Attributes_Tables.Last (G.NFA.Attributes); G.NFA.Metaschema_Enumerations_Last := Enumeration_Tables.Last (G.NFA.Enumerations); G.NFA.Metaschema_Types_Last := Types_Tables.Last (G.NFA.Types); end if; end Initialize_Grammar; ------------- -- Ur_Type -- ------------- function Ur_Type (NFA : access schema_nfa'class; Process_Contents : process_contents_type) return Schema_State_Machines.nested_nfa is begin case Process_Contents is when process_skip => return NFA.Create_Nested (NFA.Ur_Type_Skip); when others => return NFA.Create_Nested (NFA.Ur_Type); end case; end Ur_Type; ---------------- -- Debug_Dump -- ---------------- procedure Debug_Dump (Grammar : xml_grammar) is Str : string_list; G : constant XML_Grammars.encapsulated_access := Get (Grammar); begin if Debug then Str := G.Parsed_Locations; while Str /= null loop Debug_Output (" Parsed location: " & Get (Str.Str).all); Str := Str.Next; end loop; end if; end Debug_Dump; ---------- -- Free -- ---------- procedure Free (Grammar : in out xml_grammar_record) is procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Reference_HTables.htable, reference_htable); begin if Debug then Debug_Output ("Freeing grammar"); end if; Reset_Simple_Types (Grammar.NFA, No_Simple_Type_Index); Enumeration_Tables.Free (Grammar.NFA.Enumerations); Free (Grammar.NFA.Attributes); Reference_HTables.Reset (Grammar.NFA.References.all); Unchecked_Free (Grammar.NFA.References); Types_Tables.Free (Grammar.NFA.Types); Symbol_Htable.Reset (Grammar.NFA.Notations); Free (nfa_access (Grammar.NFA)); Free (Grammar.Parsed_Locations); end Free; ------------------------ -- Reset_Simple_Types -- ------------------------ procedure Reset_Simple_Types (NFA : access schema_nfa'class; To : simple_type_index := No_Simple_Type_Index) is begin for S in To + 1 .. Simple_Type_Tables.Last (NFA.Simple_Types) loop Free (NFA.Simple_Types.Table (S).Pattern); end loop; if To = No_Simple_Type_Index then Simple_Type_Tables.Free (NFA.Simple_Types); else Simple_Type_Tables.Set_Last (NFA.Simple_Types, To); end if; end Reset_Simple_Types; ----------- -- Reset -- ----------- procedure Reset (Grammar : in out xml_grammar) is use Reference_HTables; G : constant XML_Grammars.encapsulated_access := Get (Grammar); NFA : schema_nfa_access; function Preserve (TRef : global_reference) return Boolean; -------------- -- Preserve -- -------------- function Preserve (TRef : global_reference) return Boolean is R : Boolean; begin case TRef.Kind is when ref_element => R := Exists (NFA.Metaschema_NFA_Last, TRef.Element); when ref_type => R := TRef.Typ <= NFA.Metaschema_Types_Last; when ref_group => R := Exists (NFA.Metaschema_NFA_Last, TRef.Gr_Start); when ref_attribute | ref_attrgroup => R := TRef.Attributes.Named <= NFA.Metaschema_Attributes_Last; end case; return R; end Preserve; procedure Remove_All is new Reference_HTables.Remove_All (Preserve); begin if Debug then Debug_Output ("Partial reset of the grammar"); end if; if G = null then return; end if; NFA := G.NFA; Free (G.Parsed_Locations); if NFA.Metaschema_NFA_Last /= No_NFA_Snapshot then if Debug then Debug_Output ("Preserve metaschema information"); end if; Enumeration_Tables.Set_Last (NFA.Enumerations, NFA.Metaschema_Enumerations_Last); Attributes_Tables.Set_Last (NFA.Attributes, NFA.Metaschema_Attributes_Last); Types_Tables.Set_Last (NFA.Types, NFA.Metaschema_Types_Last); Reset_Simple_Types (NFA, NFA.Metaschema_Simple_Types_Last); Remove_All (NFA.References.all); -- From the toplevel choice (ie the list of valid global elements), -- we need to keep only those belonging to our metaschema, not those -- from grammars loaded afterward Reset_To_Snapshot (NFA, NFA.Metaschema_NFA_Last); end if; end Reset; ------------- -- Get_Key -- ------------- function Get_Key (Ref : global_reference) return reference_name is begin return (Kind => Ref.Kind, Name => Ref.Name); end Get_Key; -------------------- -- URI_Was_Parsed -- -------------------- function URI_Was_Parsed (Grammar : xml_grammar; URI : symbol) return Boolean is L : string_list; begin if Grammar /= No_Grammar then L := Get (Grammar).Parsed_Locations; while L /= null loop if Debug then Debug_Output ("URI_Was_Parsed (" & Get (URI).all & ") ? Compare with " & Get (L.Str).all); end if; if L.Str = URI then if Debug then Debug_Output (" => Yes, already parsed"); end if; return True; end if; L := L.Next; end loop; end if; return False; end URI_Was_Parsed; -------------------- -- Set_Parsed_URI -- -------------------- procedure Set_Parsed_URI (Reader : in out abstract_validation_reader'class; URI : symbol) is begin Initialize_Grammar (Reader); if Debug then Debug_Output ("Set_Parsed_UI: " & Get (URI).all); end if; Get (Reader.Grammar).Parsed_Locations := new string_list_record' (Str => URI, Next => Get (Reader.Grammar).Parsed_Locations); end Set_Parsed_URI; ------------- -- Get_NFA -- ------------- function Get_NFA (Grammar : xml_grammar) return schema_nfa_access is begin return Get (Grammar).NFA; end Get_NFA; -------------------- -- Get_References -- -------------------- function Get_References (Grammar : xml_grammar) return reference_htable is begin return Get (Grammar).NFA.References; end Get_References; ------------------------ -- Initialize_Symbols -- ------------------------ overriding procedure Initialize_Symbols (Parser : in out abstract_validation_reader) is use Symbol_Table_Pointers; begin Initialize_Symbols (sax_reader (Parser)); if Parser.Grammar /= No_Grammar then if Get (Parser.Grammar).Symbols = Symbol_Table_Pointers.Null_Pointer then if Debug then Debug_Output ("Initialze_Symbols, set grammar's symbol table"); end if; Get (Parser.Grammar).Symbols := Get_Symbol_Table (Parser); end if; end if; if Parser.Xmlns /= No_Symbol then return; end if; Parser.All_NNI := Find_Symbol (Parser, "allNNI"); Parser.Annotated := Find_Symbol (Parser, "annotated"); Parser.Annotation := Find_Symbol (Parser, "annotation"); Parser.Any := Find_Symbol (Parser, "any"); Parser.Any_Attribute := Find_Symbol (Parser, "anyAttribute"); Parser.Any_Namespace := Find_Symbol (Parser, "##any"); Parser.Any_Simple_Type := Find_Symbol (Parser, "anySimpleType"); Parser.Anytype := Find_Symbol (Parser, "anyType"); Parser.Appinfo := Find_Symbol (Parser, "appinfo"); Parser.Attr_Decls := Find_Symbol (Parser, "attrDecls"); Parser.Attribute := Find_Symbol (Parser, "attribute"); Parser.Attribute_Group := Find_Symbol (Parser, "attributeGroup"); Parser.Attribute_Group_Ref := Find_Symbol (Parser, "attributeGroupRef"); Parser.Base := Find_Symbol (Parser, "base"); Parser.Block := Find_Symbol (Parser, "block"); Parser.Block_Default := Find_Symbol (Parser, "blockDefault"); Parser.Block_Set := Find_Symbol (Parser, "blockSet"); Parser.Choice := Find_Symbol (Parser, "choice"); Parser.Complex_Content := Find_Symbol (Parser, "complexContent"); Parser.Complex_Extension_Type := Find_Symbol (Parser, "complexExtensionType"); Parser.Complex_Restriction_Type := Find_Symbol (Parser, "complexRestrictionType"); Parser.Complex_Type := Find_Symbol (Parser, "complexType"); Parser.Complex_Type_Model := Find_Symbol (Parser, "complexTypeModel"); Parser.Def_Ref := Find_Symbol (Parser, "defRef"); Parser.Default := Find_Symbol (Parser, "default"); Parser.Derivation_Control := Find_Symbol (Parser, "derivationControl"); Parser.Derivation_Set := Find_Symbol (Parser, "derivationSet"); Parser.Documentation := Find_Symbol (Parser, "documentation"); Parser.Element := Find_Symbol (Parser, "element"); Parser.Enumeration := Find_Symbol (Parser, "enumeration"); Parser.Explicit_Group := Find_Symbol (Parser, "explicitGroup"); Parser.Extension := Find_Symbol (Parser, "extension"); Parser.Extension_Type := Find_Symbol (Parser, "extensionType"); Parser.Facet := Find_Symbol (Parser, "facet"); Parser.Field := Find_Symbol (Parser, "field"); Parser.Final := Find_Symbol (Parser, "final"); Parser.Final_Default := Find_Symbol (Parser, "finalDefault"); Parser.Fixed := Find_Symbol (Parser, "fixed"); Parser.Form := Find_Symbol (Parser, "form"); Parser.Form_Choice := Find_Symbol (Parser, "formChoice"); Parser.Fraction_Digits := Find_Symbol (Parser, "fractionDigits"); Parser.Group := Find_Symbol (Parser, "group"); Parser.Group_Def_Particle := Find_Symbol (Parser, "groupDefParticle"); Parser.Group_Ref := Find_Symbol (Parser, "groupRef"); Parser.Id := Find_Symbol (Parser, "id"); Parser.IDREF := Find_Symbol (Parser, "IDREF"); Parser.IDREFS := Find_Symbol (Parser, "IDREFS"); Parser.Identity_Constraint := Find_Symbol (Parser, "identityConstraint"); Parser.Import := Find_Symbol (Parser, "import"); Parser.Include := Find_Symbol (Parser, "include"); Parser.Item_Type := Find_Symbol (Parser, "itemType"); Parser.Key := Find_Symbol (Parser, "key"); Parser.Keybase := Find_Symbol (Parser, "keybase"); Parser.Keyref := Find_Symbol (Parser, "keyref"); Parser.Lang := Find_Symbol (Parser, "lang"); Parser.Lax := Find_Symbol (Parser, "lax"); Parser.Length := Find_Symbol (Parser, "length"); Parser.List := Find_Symbol (Parser, "list"); Parser.Local := Find_Symbol (Parser, "##local"); Parser.Local_Complex_Type := Find_Symbol (Parser, "localComplexType"); Parser.Local_Element := Find_Symbol (Parser, "localElement"); Parser.Local_Simple_Type := Find_Symbol (Parser, "localSimpleType"); Parser.MaxExclusive := Find_Symbol (Parser, "maxExclusive"); Parser.MaxInclusive := Find_Symbol (Parser, "maxInclusive"); Parser.MaxOccurs := Find_Symbol (Parser, "maxOccurs"); Parser.Max_Bound := Find_Symbol (Parser, "maxBound"); Parser.Maxlength := Find_Symbol (Parser, "maxLength"); Parser.Member_Types := Find_Symbol (Parser, "memberTypes"); Parser.MinExclusive := Find_Symbol (Parser, "minExclusive"); Parser.MinInclusive := Find_Symbol (Parser, "minInclusive"); Parser.MinOccurs := Find_Symbol (Parser, "minOccurs"); Parser.Min_Bound := Find_Symbol (Parser, "minBound"); Parser.Minlength := Find_Symbol (Parser, "minLength"); Parser.Mixed := Find_Symbol (Parser, "mixed"); Parser.NCName := Find_Symbol (Parser, "NCName"); Parser.NMTOKEN := Find_Symbol (Parser, "NMTOKEN"); Parser.Name := Find_Symbol (Parser, "name"); Parser.Named_Attribute_Group := Find_Symbol (Parser, "namedAttributeGroup"); Parser.Named_Group := Find_Symbol (Parser, "namedGroup"); Parser.Namespace := Find_Symbol (Parser, "namespace"); Parser.Namespace_List := Find_Symbol (Parser, "namespaceList"); Parser.Nested_Particle := Find_Symbol (Parser, "nestedParticle"); Parser.Nil := Find_Symbol (Parser, "nil"); Parser.Nillable := Find_Symbol (Parser, "nillable"); Parser.No_Namespace_Schema_Location := Find_Symbol (Parser, "noNamespaceSchemaLocation"); Parser.Non_Negative_Integer := Find_Symbol (Parser, "nonNegativeInteger"); Parser.Notation := Find_Symbol (Parser, "notation"); Parser.Num_Facet := Find_Symbol (Parser, "numFacet"); Parser.Occurs := Find_Symbol (Parser, "occurs"); Parser.Open_Attrs := Find_Symbol (Parser, "openAttrs"); Parser.Optional := Find_Symbol (Parser, "optional"); Parser.Other_Namespace := Find_Symbol (Parser, "##other"); Parser.Particle := Find_Symbol (Parser, "particle"); Parser.Pattern := Find_Symbol (Parser, "pattern"); Parser.Positive_Integer := Find_Symbol (Parser, "positiveInteger"); Parser.Precision_Decimal := Find_Symbol (Parser, "precisionDecimal"); Parser.Process_Contents := Find_Symbol (Parser, "processContents"); Parser.Prohibited := Find_Symbol (Parser, "prohibited"); Parser.Public := Find_Symbol (Parser, "public"); Parser.QName := Find_Symbol (Parser, "QName"); Parser.Qualified := Find_Symbol (Parser, "qualified"); Parser.Real_Group := Find_Symbol (Parser, "realGroup"); Parser.Redefinable := Find_Symbol (Parser, "redefinable"); Parser.Redefine := Find_Symbol (Parser, "redefine"); Parser.Reduced_Derivation_Control := Find_Symbol (Parser, "reducedDerivationControl"); Parser.Ref := Find_Symbol (Parser, "ref"); Parser.Refer := Find_Symbol (Parser, "refer"); Parser.Required := Find_Symbol (Parser, "required"); Parser.Restriction := Find_Symbol (Parser, "restriction"); Parser.Restriction_Type := Find_Symbol (Parser, "restrictionType"); Parser.S_1 := Find_Symbol (Parser, "1"); Parser.S_Abstract := Find_Symbol (Parser, "abstract"); Parser.S_All := Find_Symbol (Parser, "all"); Parser.S_Attribute_Form_Default := Find_Symbol (Parser, "attributeFormDefault"); Parser.S_Boolean := Find_Symbol (Parser, "boolean"); Parser.S_Element_Form_Default := Find_Symbol (Parser, "elementFormDefault"); Parser.S_False := Find_Symbol (Parser, "false"); Parser.S_Schema := Find_Symbol (Parser, "schema"); Parser.S_String := Find_Symbol (Parser, "string"); Parser.S_Use := Find_Symbol (Parser, "use"); Parser.Schema_Location := Find_Symbol (Parser, "schemaLocation"); Parser.Schema_Top := Find_Symbol (Parser, "schemaTop"); Parser.Selector := Find_Symbol (Parser, "selector"); Parser.Sequence := Find_Symbol (Parser, "sequence"); Parser.Simple_Content := Find_Symbol (Parser, "simpleContent"); Parser.Simple_Derivation := Find_Symbol (Parser, "simpleDerivation"); Parser.Simple_Derivation_Set := Find_Symbol (Parser, "simpleDerivationSet"); Parser.Simple_Extension_Type := Find_Symbol (Parser, "simpleExtensionType"); Parser.Simple_Restriction_Model := Find_Symbol (Parser, "simpleRestrictionModel"); Parser.Simple_Restriction_Type := Find_Symbol (Parser, "simpleRestrictionType"); Parser.Simple_Type := Find_Symbol (Parser, "simpleType"); Parser.Source := Find_Symbol (Parser, "source"); Parser.Strict := Find_Symbol (Parser, "strict"); Parser.Substitution_Group := Find_Symbol (Parser, "substitutionGroup"); Parser.System := Find_Symbol (Parser, "system"); Parser.Target_Namespace := Find_Symbol (Parser, "##targetNamespace"); Parser.Namespace_Target := Find_Symbol (Parser, "targetNamespace"); Parser.Token := Find_Symbol (Parser, "token"); Parser.Top_Level_Attribute := Find_Symbol (Parser, "topLevelAttribute"); Parser.Top_Level_Complex_Type := Find_Symbol (Parser, "topLevelComplexType"); Parser.Top_Level_Element := Find_Symbol (Parser, "topLevelElement"); Parser.Top_Level_Simple_Type := Find_Symbol (Parser, "topLevelSimpleType"); Parser.Total_Digits := Find_Symbol (Parser, "totalDigits"); Parser.Typ := Find_Symbol (Parser, "type"); Parser.Type_Def_Particle := Find_Symbol (Parser, "typeDefParticle"); Parser.UC_ID := Find_Symbol (Parser, "ID"); Parser.URI_Reference := Find_Symbol (Parser, "uriReference"); Parser.Unbounded := Find_Symbol (Parser, "unbounded"); Parser.Union := Find_Symbol (Parser, "union"); Parser.Unique := Find_Symbol (Parser, "unique"); Parser.Unqualified := Find_Symbol (Parser, "unqualified"); Parser.Ur_Type := Find_Symbol (Parser, "ur-Type"); Parser.Value := Find_Symbol (Parser, "value"); Parser.Version := Find_Symbol (Parser, "version"); Parser.Whitespace := Find_Symbol (Parser, "whiteSpace"); Parser.Wildcard := Find_Symbol (Parser, "wildcard"); Parser.XML_Instance_URI := Find_Symbol (Parser, XML_Instance_URI); Parser.XML_Schema_URI := Find_Symbol (Parser, XML_Schema_URI); Parser.XML_URI := Find_Symbol (Parser, XML_URI); Parser.XPath := Find_Symbol (Parser, "xpath"); Parser.XPath_Expr_Approx := Find_Symbol (Parser, "XPathExprApprox"); Parser.XPath_Spec := Find_Symbol (Parser, "XPathSpec"); Parser.Xmlns := Find_Symbol (Parser, "xmlns"); end Initialize_Symbols; ----------- -- Image -- ----------- function Image (Trans : transition_descr) return String is begin case Trans.Kind is when transition_symbol | transition_symbol_from_all => if Trans.Name.Local = No_Symbol then return ""; else return To_QName (Trans.Name); end if; when transition_close | transition_close_from_all => return "close parent"; when transition_any => return ""; end case; end Image; ----------- -- Image -- ----------- function Image (Self : access nfa'class; S : Schema_State_Machines.state; Data : state_data) return String is pragma unreferenced (S); Local : symbol; begin if Data.Simple = No_Type_Index then return ""; else Local := schema_nfa_access (Self).Types.Table (Data.Simple).Name.Local; if Local = No_Symbol then return ""; else return Get (Local).all; end if; end if; end Image; ---------- -- Hash -- ---------- function Hash (Name : reference_name) return Interfaces.Unsigned_32 is begin return Interfaces.Unsigned_32 (Hash (Name.Name) + reference_kind'pos (Name.Kind)); end Hash; ---------- -- Hash -- ---------- function Hash (Name : qualified_name) return header_num is begin return (Hash (Name.NS) + Hash (Name.Local)) / 2; end Hash; ---------- -- Hash -- ---------- function Hash (Name : Sax.Symbols.symbol) return header_num is begin if Name = No_Symbol then return 0; else return header_num (Sax.Symbols.Hash (Name) mod Interfaces.Unsigned_32 (header_num'last)); end if; end Hash; -------------------------- -- Validate_Simple_Type -- -------------------------- 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) is Error : symbol; G : constant XML_Grammars.encapsulated_access := Get (Reader.Grammar); begin Validate_Simple_Type (Simple_Types => G.NFA.Simple_Types, Enumerations => G.NFA.Enumerations, Notations => G.NFA.Notations, Symbols => G.Symbols, Id_Table => Reader.Id_Table, Insert_Id => Insert_Id, Simple_Type => Simple_Type, Ch => Ch, Error => Error, XML_Version => Get_XML_Version (Reader.all)); if Error /= No_Symbol then Validation_Error (Reader, Get (Error).all, Loc); end if; end Validate_Simple_Type; ----------- -- Equal -- ----------- function Equal (Reader : access abstract_validation_reader'class; Simple_Type : simple_type_index; Ch1 : Sax.Symbols.symbol; Ch2 : Unicode.CES.byte_sequence) return Boolean is Is_Equal : Boolean; G : constant XML_Grammars.encapsulated_access := Get (Reader.Grammar); begin Equal (Simple_Types => G.NFA.Simple_Types, Enumerations => G.NFA.Enumerations, Notations => G.NFA.Notations, Symbols => G.Symbols, Id_Table => Reader.Id_Table, Simple_Type => Simple_Type, Ch1 => Ch1, Ch2 => Ch2, Is_Equal => Is_Equal, XML_Version => Get_XML_Version (Reader.all)); return Is_Equal; end Equal; --------------- -- Add_Facet -- --------------- 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) is begin Add_Facet (Facets, Symbols => Get (Grammar).Symbols, Enumerations => Get (Grammar).NFA.Enumerations, Facet_Name => Facet_Name, Value => Value, Loc => Loc); end Add_Facet; --------------- -- To_String -- --------------- function To_String (Blocks : block_status) return String is begin return "{restr=" & Blocks (block_restriction)'img & " ext=" & Blocks (block_extension)'img & " sub=" & Blocks (block_substitution)'img & '}'; end To_String; --------------------------------- -- Check_Substitution_Group_OK -- --------------------------------- 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) is NFA : constant schema_nfa_access := Get_NFA (Handler.Grammar); Old_Descr : constant access type_descr := NFA.Get_Type_Descr (Old_Type); New_Descr : constant access type_descr := NFA.Get_Type_Descr (New_Type); Has_Restriction, Has_Extension : Boolean := False; Simple_Old_Type : simple_type_index := No_Simple_Type_Index; -- Current target for [Old_Type], when considered a simple type function From_Descr_To_Old (Index : type_index; Descr : access type_descr) return Boolean; -- Try moving from [Descr] to [Old_Descr] through a series of extensions -- or restrictions. [False] is returned if we could not reach the old -- description. ----------------------- -- From_Descr_To_Old -- ----------------------- function From_Descr_To_Old (Index : type_index; Descr : access type_descr) return Boolean is Result : Boolean := False; R : access type_descr; begin if Index = Old_Type or else (Simple_Old_Type /= No_Simple_Type_Index and then Descr.Simple_Content = Simple_Old_Type) then return True; end if; if Descr.Restriction_Of /= No_Type_Index then R := NFA.Get_Type_Descr (Descr.Restriction_Of); Has_Restriction := True; Result := From_Descr_To_Old (Descr.Restriction_Of, R); end if; if not Result and then Descr.Extension_Of /= No_Type_Index then R := NFA.Get_Type_Descr (Descr.Extension_Of); Has_Extension := True; Result := From_Descr_To_Old (Descr.Extension_Of, R); end if; return Result; end From_Descr_To_Old; begin if New_Type = Old_Type or else Old_Type = NFA.Get_Data (NFA.Ur_Type).Simple or else Old_Descr.Name = (NS => Handler.XML_Schema_URI, Local => Handler.Anytype) then return; end if; if Element_Block (block_substitution) then Validation_Error (Handler, "Element blocks substitutions", Loc); end if; if Old_Descr.Simple_Content /= No_Simple_Type_Index then declare Simple : constant simple_type_descr := NFA.Get_Simple_Type (Old_Descr.Simple_Content); begin case Simple.Kind is when primitive_union => for U in Simple.Union'range loop if Simple.Union (U) /= No_Simple_Type_Index then Simple_Old_Type := Simple.Union (U); if From_Descr_To_Old (New_Type, New_Descr) then return; end if; end if; end loop; Validation_Error (Handler, To_QName (New_Descr.Name) & " is not a derivation of union " & To_QName (Old_Descr.Name), Loc); when primitive_list => Validation_Error (Handler, To_QName (New_Descr.Name) & " is not a derivation of list " & To_QName (Old_Descr.Name), Loc); when others => null; -- Will be dealt with below end case; end; end if; if not From_Descr_To_Old (New_Type, New_Descr) then Validation_Error (Handler, To_QName (New_Descr.Name) & " is not a derivation of " & To_QName (Old_Descr.Name), Loc); end if; if Has_Restriction and then Old_Descr.Block (block_restriction) then Validation_Error (Handler, To_QName (Old_Descr.Name) & " blocks restrictions", Loc); end if; if Has_Restriction and then Element_Block (block_restriction) then Validation_Error (Handler, "Element blocks restrictions", Loc); end if; if Has_Extension and then Old_Descr.Block (block_extension) then Validation_Error (Handler, To_QName (Old_Descr.Name) & " blocks extensions", Loc); end if; if Has_Extension and then Element_Block (block_extension) then Validation_Error (Handler, "Element blocks extensions", Loc); end if; end Check_Substitution_Group_OK; ------------------ -- Dump_Dot_NFA -- ------------------ function Dump_Dot_NFA (Grammar : xml_grammar; Nested : nested_nfa := No_Nested) return String is NFA : constant schema_nfa_access := Get (Grammar).NFA; begin if Nested = No_Nested then return Schema_State_Machines_PP.Dump (NFA, Mode => dump_dot_compact, Show_Details => True, Show_Isolated_Nodes => False, Since => NFA.Metaschema_NFA_Last); else return Schema_State_Machines_PP.Dump (NFA, Nested => Nested, Mode => dump_dot_compact); end if; end Dump_Dot_NFA; -------------- -- Expected -- -------------- function Expected (Self : abstract_nfa_matcher'class; From_State, To_State : state; Parent_Data : access active_state_data; Trans : transition_descr) return String is pragma unreferenced (Self, From_State, To_State); Mask : visited_all_children; begin case Trans.Kind is when transition_symbol_from_all => -- Only if the element has not been visited yet Mask := 2**Trans.All_Child_Index; if (Parent_Data.Visited and Mask) = 0 then return Image (Trans); end if; when transition_close_from_all => -- Only if all children have been visited. if (Parent_Data.Visited and Trans.Mask) = Trans.Mask then return "close parent"; end if; when others => return Image (Trans); end case; return ""; end Expected; ----------- -- Match -- ----------- 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 is pragma unreferenced (To_State); Result : Boolean; Mask : visited_all_children; begin case Trans.Kind is when transition_close => Result := Sym.Closing; when transition_symbol | transition_symbol_from_all => if Sym.Closing then Result := False; else if From_State = Start_State then -- At toplevel, always qualified Result := Trans.Name = Sym.Name; else case Trans.Form is when unqualified => Result := (NS => Empty_String, Local => Trans.Name.Local) = Sym.Name; when qualified => Result := Trans.Name = Sym.Name; end case; end if; end if; if Result and then Trans.Kind = transition_symbol_from_all then -- Check that the transition hasn't been visited yet Mask := 2**Trans.All_Child_Index; if (Parent_Data.Visited and Mask) = 1 then Result := False; else Parent_Data.Visited := Parent_Data.Visited or Mask; Result := True; end if; end if; when transition_close_from_all => -- Check that all children have been visited or are optional Result := ((Parent_Data.Visited and Trans.Mask) = Trans.Mask) and then Sym.Closing; when transition_any => if Sym.Closing then Result := False; else Result := Match_Any (Trans.Any, Sym.Name); if Result then schema_nfa_matcher (Self.all).Matched_Through_Any := True; schema_nfa_matcher (Self.all).Matched_Process_Content := Trans.Any.Process_Contents; end if; end if; end case; return Result; end Match; -------------- -- Do_Match -- -------------- 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) is begin Matcher.Matched_Through_Any := False; Process (Matcher, Input => Sym, Success => Success); Through_Any := Matcher.Matched_Through_Any; Through_Process := Matcher.Matched_Process_Content; end Do_Match; ------------------ -- Add_Notation -- ------------------ procedure Add_Notation (NFA : access schema_nfa'class; Name : Sax.Symbols.symbol) is begin Symbol_Htable.Set (NFA.Notations, Name); end Add_Notation; ---------- -- Free -- ---------- procedure Free (Reader : in out abstract_validation_reader) is begin Free (Reader.Id_Table); end Free; end Schema.Validators;