------------------------------------------------------------------------------ -- XML/Ada - An XML suite for Ada95 -- -- -- -- Copyright (C) 2004-2012, AdaCore -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- -- -- -- -- -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ pragma ada_05; with Ada.Exceptions; use Ada.Exceptions; with GNAT.Task_Lock; use GNAT.Task_Lock; with Unicode; use Unicode; with Unicode.CES; use Unicode.CES; with Sax.Encodings; use Sax.Encodings; with Sax.Exceptions; use Sax.Exceptions; 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.Readers; use Schema.Readers; with Ada.Unchecked_Deallocation; with Ada.IO_Exceptions; with Input_Sources.File; use Input_Sources.File; package body Schema.Schema_Readers is use Schema_State_Machines, Schema_State_Machines_PP; use Type_Tables, Element_HTables, Group_HTables; use AttrGroup_HTables, Reference_HTables, Attribute_HTables; default_contexts : constant := 30; -- Default number of nested levels in a schema. -- If the actual schema uses more, we will simply reallocate some memory. max_max_occurs : constant := 300; -- Maximum value for maxOccurs. -- Higher values result in an explosion in the number of states in the NFA, -- so should not be used for now. procedure Push_Context (Handler : access schema_reader'class; Ctx : context); -- Add a new context to the list procedure Unchecked_Free is new Ada.Unchecked_Deallocation (attr_array, attr_array_access); procedure Unchecked_Free is new Ada.Unchecked_Deallocation (context_array, context_array_access); procedure Free (Shared : in out xsd_data_access); -- Free [Shared] and its htables procedure Free (Self : in out type_details_access); -- Free [Self], [Self.Next] and so on procedure Create_NFA (Parser : access schema_reader); -- Create the state machine from the registered elements and types -- Return the start state for the current grammar (we do not use the -- NFA's default start state, since each grammar has its own list of valid -- toplevel elements. function To_String (Final : final_status) return String; function In_Redefine_Context (Handler : schema_reader'class) return Boolean; -- Whether we are currently processing a tag function Resolve_QName (Handler : access schema_reader'class; QName : Sax.Symbols.symbol; NS_If_Empty : Sax.Symbols.symbol := Empty_String; Loc : location) return qualified_name; -- Resolve namespaces for QName. -- [NS_If_Empty] is used if no namespace was found for the element. This -- will often be the target namespace of the schema. procedure Internal_Parse (Parser : in out schema_reader; Input : in out Input_Sources.input_source'class; Default_Namespace : symbol; Do_Create_NFA : Boolean; Do_Initialize_Shared : Boolean); -- Internal version of [Parse], which allows reuse of the shared data. -- This is useful while parsing a XSD procedure Insert_In_Type (Handler : access schema_reader'class; Element : in out type_details_access); -- Insert Element in the type definition in [Handler.Contexts]. -- If there is an error inserting the element, an exception is raised and -- [Element] is freed. procedure Prepare_Type (Handler : access schema_reader'class; Atts : sax_attribute_list; Is_Simple : Boolean); -- Prepare a type context (simpleType or complexType) procedure Add_Type_Member (Handler : access schema_reader'class; List : in out type_member_array; Member : type_member; Loc : location); -- Add a new item in [List], and raise an exception if [List] is full. procedure Compute_Blocks (Atts : sax_attribute_list; Handler : access schema_reader'class; Blocks : out block_status; Is_Set : out Boolean; Index : Integer); -- Compute the list of blocked elements from the attribute "block". function Compute_Final (Atts : sax_attribute_list; Handler : access schema_reader'class; Index : Integer) return final_status; -- Compute the list of final attributes from value. Value is a list similar -- to what is used for the "final" attribute of elements in a schema function Compute_Form (Atts : sax_attribute_list; Handler : access schema_reader'class; Index : Integer) return form_type; -- Parse the given attribute procedure Append (List : in out attr_array_access; Attr : attr_descr); -- Add an attribute to the list procedure Insert_Attribute (Handler : access schema_reader'class; In_Context : Natural; Attribute : attr_descr); -- Insert attribute at the right location in In_Context. function Process_Contents_From_Atts (Handler : access schema_reader'class; Atts : sax_attribute_list; Index : Integer) return process_contents_type; -- Get the value of processContents from the attributes procedure Create_Element (Handler : access schema_reader'class; Atts : sax_attribute_list); procedure Create_Notation (Handler : access schema_reader'class; Atts : sax_attribute_list); procedure Create_Complex_Type (Handler : access schema_reader'class; Atts : sax_attribute_list); procedure Create_Simple_Type (Handler : access schema_reader'class; Atts : sax_attribute_list); procedure Create_Restriction (Handler : access schema_reader'class; Atts : sax_attribute_list); procedure Create_All (Handler : access schema_reader'class; Atts : sax_attribute_list); procedure Create_Sequence (Handler : access schema_reader'class; Atts : sax_attribute_list); procedure Create_Attribute (Handler : access schema_reader'class; Atts : sax_attribute_list); procedure Create_Schema (Handler : access schema_reader'class; Atts : sax_attribute_list); procedure Create_Extension (Handler : access schema_reader'class; Atts : sax_attribute_list); procedure Create_List (Handler : access schema_reader'class; Atts : sax_attribute_list); procedure Create_Union (Handler : access schema_reader'class; Atts : sax_attribute_list); procedure Create_Choice (Handler : access schema_reader'class; Atts : sax_attribute_list); procedure Create_Redefine (Handler : access schema_reader'class; Atts : sax_attribute_list); procedure Create_Include (Handler : access schema_reader'class; Atts : sax_attribute_list); procedure Create_Group (Handler : access schema_reader'class; Atts : sax_attribute_list); procedure Create_Attribute_Group (Handler : access schema_reader'class; Atts : sax_attribute_list); procedure Create_Any (Handler : access schema_reader'class; Atts : sax_attribute_list); procedure Create_Import (Handler : access schema_reader'class; Atts : sax_attribute_list); procedure Create_Any_Attribute (Handler : access schema_reader'class; Atts : sax_attribute_list); -- Create a new context for a specific tag: -- resp. , , , , , -- , , , , , , -- , , , , , procedure Finish_Element (Handler : access schema_reader'class); procedure Finish_Complex_Type (Handler : access schema_reader'class); procedure Finish_Simple_Type (Handler : access schema_reader'class); procedure Finish_Restriction (Handler : access schema_reader'class); procedure Finish_Extension (Handler : access schema_reader'class); procedure Finish_Attribute (Handler : access schema_reader'class); procedure Finish_Union (Handler : access schema_reader'class); procedure Finish_List (Handler : access schema_reader'class); procedure Finish_Group (Handler : access schema_reader'class); procedure Finish_Attribute_Group (Handler : access schema_reader'class); -- Finish the handling of various tags: -- resp. , , , , , -- , , , , procedure Get_Occurs (Handler : access schema_reader'class; Atts : sax_attribute_list; Min_Occurs, Max_Occurs : out occurrences); -- Get the "minOccurs" and "maxOccurs" attributes --------------- -- To_String -- --------------- function To_String (Final : final_status) return String is begin return "restr=" & Final (final_restriction)'img & " ext=" & Final (final_extension)'img & " union=" & Final (final_union)'img & " list=" & Final (final_list)'img; end To_String; ------------------------- -- In_Redefine_Context -- ------------------------- function In_Redefine_Context (Handler : schema_reader'class) return Boolean is begin for J in 1 .. Handler.Contexts_Last loop if Handler.Contexts (J).Typ = context_redefine then return True; end if; end loop; return False; end In_Redefine_Context; ---------------- -- Create_NFA -- ---------------- procedure Create_NFA (Parser : access schema_reader) is NFA : constant schema_nfa_access := Get_NFA (Get_Grammar (Parser.all)); Ref : constant reference_htable := Get_References (Get_Grammar (Parser.all)); Any_Simple_Type_Index : constant type_index := Get (Ref.all, ((Local => Parser.Any_Simple_Type, NS => Parser.XML_Schema_URI), ref_type)) .Typ; Shared : xsd_data_access renames Parser.Shared; package Type_HTables is new GNAT.Dynamic_HTables.Simple_HTable (Header_Num => header_num, Element => internal_type_index, No_Element => No_Internal_Type_Index, Key => qualified_name, Hash => Hash, Equal => "="); use Type_HTables; Types : Type_HTables.instance; procedure Process_Global_Element (Info : in out element_descr; Start_At : state); procedure Process_Type (Info : in out internal_type_descr); procedure Process_Details (In_Type : access type_descr; Details : type_details_access; Start, From : state; Nested_End : out state; Mask : out visited_all_children); -- [Start] is the start of the current nested. -- [Mask] is the mask to apply to a closing transition out of a -- node. It is only set if Details.Kind = Type_All. procedure Create_Element_State (Info : in out element_descr; Start, From : state; Global : Boolean; S1, S2 : out state; Trans_Kind : transition_kind; All_Child_Index : Integer := 0); -- Create (and decorate) the nodes [S1]..[S2] corresponding to an -- . A link is created [From]->[S1]. -- [Start] is the first element of the current nested machine. -- Trans_Kind is the kind of the first transition, from From to the -- first created state. This transition is associated with the name of -- the element. -- All_Child_Index indicates the index of the created transition in all -- the children of an node. This is used to memory efficiently -- which transitions have already been visited for this . type type_descr_access is access all type_descr; procedure Create_Simple_Type (J : internal_type_index; Descr : out type_descr_access; Index : out type_index); -- Create the new simple type info at index [J] procedure Get_Type_Descr (Name : qualified_name; Loc : location; NFA_Type : out type_index; Internal_Type : out internal_type_index); -- Lookup the type information in the grammar. This type information -- could be in several places: -- - Either defined in the current XSD and its : in that case, -- [Internal_Type] will be set. -- - Or in a previously loaded XSD. In that case, it is set to -- [No_Internal_Type_Index] procedure Lookup_Simple_Type (Name : qualified_name; Loc : location; Descr : out type_descr_access; Index : out type_index); -- Search for the simpleType [Name] procedure Add_Attributes (List : in out attributes_list; Attrs : attr_array_access; Processed_Groups : in out AttrGroup_HTables.instance; As_Restriction : Boolean; Had_Any : in out Boolean); -- Create List from the list of attributes or attribute groups in -- [Attrs]. [Had_Any] is set to true if a was -- encountered. The caller should first set it to False. procedure Check_Unique_Particle_Attribution (Details : type_details_access); -- Check that all elements in the content model are unique (we must not -- have two elements that compete with each other). procedure Create_Global_Attributes (Attr : internal_attribute_descr); -- Register a global attribute. procedure Resolve_Attribute_Type (Attr : in out internal_attribute_descr; Loc : Sax.Locators.location); -- Set [Attr.Descr.Simple_Type] to the appropriate value, after looking -- up the type -------------------------- -- Create_Element_State -- -------------------------- procedure Create_Element_State (Info : in out element_descr; Start, From : state; Global : Boolean; S1, S2 : out state; Trans_Kind : transition_kind; All_Child_Index : Integer := 0) is pragma unreferenced (Start); Real : element_descr; Trans : transition_descr; TRef : global_reference := No_Global_Reference; S : state := No_State; function Build_Trans (N : qualified_name; F : form_type) return transition_descr; function Build_Trans (N : qualified_name; F : form_type) return transition_descr is begin case Trans_Kind is when transition_symbol => return (transition_symbol, N, F, All_Child_Index => 0); when transition_symbol_from_all => return (transition_symbol_from_all, N, F, All_Child_Index => All_Child_Index); when others => raise Program_Error with "Invalid transition type"; end case; end Build_Trans; begin if Info.Is_Abstract then -- ??? Should use the substitutionGroup elements, instead S1 := No_State; S2 := No_State; Validation_Error (Parser, "Abstract elements not handled yet", Except => XML_Not_Implemented'identity); return; end if; S1 := NFA.Add_State; Info.S := S1; if Debug then Debug_Output ("Create_Element_State S1 for element " & To_QName (Info.Name) & To_QName (Info.Ref) & S1'img); end if; -- Resolve element references if Info.Name = No_Qualified_Name then Real := Get (Shared.Global_Elements, Info.Ref); if Real = No_Element_Descr then TRef := Get (Ref.all, (Info.Ref, ref_element)); if TRef = No_Global_Reference then Validation_Error (Parser, "Unknown refed element " & To_QName (Info.Ref), Info.Loc); end if; S := TRef.Element; Trans := Build_Trans (Info.Ref, Info.Form); else Trans := Build_Trans (Real.Name, Info.Form); S := Real.S; end if; if S /= No_State then if Debug then Debug_Output ("copying data from" & S'img & " to" & S1'img); end if; NFA.Get_Data (S1).all := NFA.Get_Data (S).all; NFA.Set_Nested (S1, NFA.Get_Nested (S)); end if; else declare NFA_Type : type_index; Internal_Type : internal_type_index; Data : access state_data; begin Real := Info; Trans := Build_Trans (Real.Name, Info.Form); -- Create nested NFA for the type, if needed if Real.Typ /= No_Qualified_Name then Get_Type_Descr (Real.Typ, Info.Loc, NFA_Type, Internal_Type); elsif Real.Local_Type /= No_Internal_Type_Index then Internal_Type := Real.Local_Type; NFA_Type := Shared.Types.Table (Internal_Type).In_NFA; else -- "" (3.3.2.1 {type definition}) NFA_Type := No_Type_Index; end if; if Info.Substitution_Group /= No_Qualified_Name then -- ??? Handling of substitutionGroup: the type of the -- element is the same as the head unless overridden. Validation_Error (Parser, "substitutionGroup not supported", Except => XML_Not_Implemented'identity); end if; Data := NFA.Get_Data (S1); if NFA_Type /= No_Type_Index then Data.all := state_data' (Simple => NFA_Type, Fixed => No_Symbol, -- See below Default => Info.Default, Nillable => Info.Nillable, Block => Info.Block); NFA.Set_Nested (S1, NFA.Create_Nested (Get_Type_Descr (NFA, NFA_Type).Complex_Content)); else NFA.Set_Nested (S1, NFA.Ur_Type (process_lax)); Data.Default := Info.Default; Data.Block := Info.Block; Data.Nillable := Info.Nillable; end if; -- Check that the fixed value is valid if Info.Fixed /= No_Symbol and then NFA.Get_Data (S1).Simple /= No_Type_Index then Normalize_And_Validate (Parser => Parser, Simple => Get_Type_Descr (NFA, NFA.Get_Data (S1).Simple) .Simple_Content, Fixed => Info.Fixed, Loc => Info.Loc); end if; Data.Fixed := Info.Fixed; end; end if; -- Link with previous element NFA.Add_Transition (From, S1, Trans); S2 := NFA.Add_State; if NFA.Get_Nested (S1) /= No_Nested then NFA.On_Empty_Nested_Exit (S1, S2); -- a complexType else NFA.Add_Transition (S1, S2, (Kind => transition_close)); end if; -- Save this element for later reuse in other namespaces if Global then if Debug then Debug_Output ("Global elem: " & To_QName (Real.Name)); end if; Set (Ref.all, (Kind => ref_element, Name => Real.Name, Element => S1)); end if; end Create_Element_State; ---------------------------- -- Process_Global_Element -- ---------------------------- procedure Process_Global_Element (Info : in out element_descr; Start_At : state) is S1, S2 : state; begin Create_Element_State (Info, Start_At, Start_At, True, S1, S2, transition_symbol); if S2 /= No_State then NFA.Add_Empty_Transition (S2, Final_State); end if; end Process_Global_Element; -------------------- -- Get_Type_Descr -- -------------------- procedure Get_Type_Descr (Name : qualified_name; Loc : location; NFA_Type : out type_index; Internal_Type : out internal_type_index) is TRef : global_reference; begin Internal_Type := Get (Types, Name); if Internal_Type = No_Internal_Type_Index then TRef := Get (Ref.all, (Name, ref_type)); if TRef = No_Global_Reference then Validation_Error (Parser, "Unknown type " & To_QName (Name), Loc); end if; NFA_Type := TRef.Typ; else NFA_Type := Shared.Types.Table (Internal_Type).In_NFA; end if; if Name = (NS => Parser.XML_Schema_URI, Local => Parser.IDREF) or else Name = (NS => Parser.XML_Schema_URI, Local => Parser.IDREFS) then Validation_Error (Parser, "Unsupported type IDREF and IDREFS", Loc => Loc, Except => XML_Not_Implemented'identity); end if; end Get_Type_Descr; ------------------------ -- Lookup_Simple_Type -- ------------------------ procedure Lookup_Simple_Type (Name : qualified_name; Loc : location; Descr : out type_descr_access; Index : out type_index) is TRef : global_reference; Internal : internal_type_index; begin TRef := Get (Ref.all, (Name, ref_type)); if TRef = No_Global_Reference then Validation_Error (Parser, "Unknown type " & To_QName (Name), Loc); end if; Index := TRef.Typ; Descr := type_descr_access (Get_Type_Descr (NFA, Index)); if Descr.Simple_Content = No_Simple_Type_Index then if Debug then Debug_Output ("Lookup_Simple_Type: generate " & To_QName (Name) & " early"); end if; Internal := Get (Types, Name); if Internal = No_Internal_Type_Index then Validation_Error (Parser, "Type is not a simple type: " & To_QName (Name), Loc); end if; Create_Simple_Type (Internal, Descr, Index); end if; end Lookup_Simple_Type; --------------------------------------- -- Check_Unique_Particle_Attribution -- --------------------------------------- procedure Check_Unique_Particle_Attribution (Details : type_details_access) is Duplicates : Element_HTables.instance; -- Used to check for duplicate elements within a sequence or choice. -- ??? Could use a htable of locations, so that we can point to the -- two duplicate declarations. T : type_details_access; Elem : element_descr; begin case Details.Kind is when type_sequence => T := Details.First_In_Seq; when type_choice => T := Details.First_In_Choice; when type_all => T := Details.First_In_All; when others => raise Program_Error with "Internal error"; end case; while T /= null loop case T.Kind is when type_element => if T.Element.Name /= No_Qualified_Name then Elem := Element_HTables.Get (Duplicates, T.Element.Name); if Elem /= No_Element_Descr then -- It is always invalid to have an element with the -- same name but with different types in the same -- model, even if there is no ambiguity (for instance -- in a sequence). if Elem.Typ /= No_Qualified_Name and then Elem.Typ /= T.Element.Typ then Validation_Error (Parser, "Multiple elements with name '" & To_QName (T.Element.Name) & "', with different types, appear in the model" & " group", Details.Loc); end if; -- In a or , we cannot have the same -- element multiple times, since that would be -- ambiguous. if Details.Kind = type_choice or else Details.Kind = type_all then Validation_Error (Parser, "'" & To_QName (T.Element.Name) & "' and '" & To_QName (Elem.Name) & "' violate the Unique" & " Particle Attribution rule, creating an" & " ambiguity for the validation", Details.Loc); end if; else Element_HTables.Set (Duplicates, T.Element.Name, T.Element); end if; end if; when type_group => null; when others => -- ??? Should check, in particular for groups or nested -- sequences (we can have a Sequence that contains choices) null; end case; T := T.Next; end loop; Reset (Duplicates); exception when others => Reset (Duplicates); raise; end Check_Unique_Particle_Attribution; --------------------- -- Process_Details -- --------------------- procedure Process_Details (In_Type : access type_descr; Details : type_details_access; Start, From : state; Nested_End : out state; Mask : out visited_all_children) is S, S1 : state; T : type_details_access; Gr : group_descr; begin Nested_End := From; Mask := 0; if Details = null then return; end if; Details.In_Process := True; case Details.Kind is when type_empty => null; when type_sequence => Check_Unique_Particle_Attribution (Details); S := From; T := Details.First_In_Seq; while T /= null loop Process_Details (In_Type, T, Start, S, Nested_End, Mask); S := Nested_End; T := T.Next; end loop; when type_choice => Check_Unique_Particle_Attribution (Details); T := Details.First_In_Choice; Nested_End := NFA.Add_State; while T /= null loop Process_Details (In_Type, T, Start, From, S, Mask); NFA.Add_Empty_Transition (S, Nested_End); T := T.Next; end loop; when type_all => Check_Unique_Particle_Attribution (Details); if Details.First_In_All /= null then declare Count : Natural := 0; begin Mask := 0; T := Details.First_In_All; while T /= null loop pragma assert (T.Kind = type_element, "Children of must be simple elements"); -- If the element has maxOccurs=0, there is no need to -- put it in the state machine. if T.Max_Occurs.Value /= 0 then Create_Element_State (T.Element, Start, From, False, S1 => S1, S2 => S, Trans_Kind => transition_symbol_from_all, All_Child_Index => Count); if T.Min_Occurs.Value = 1 then -- The child is mandatory Mask := Mask or (2**Count); end if; Count := Count + 1; -- All elements, after being processed, come back -- to itself. The latter is in charge of -- deciding, through the subprogram Match, which -- transitions are valid in the current state. NFA.Add_Empty_Transition (S, Start); end if; T := T.Next; end loop; -- The actual end of is through a conditional empty -- transition controlled by Match. Nested_End := NFA.Add_State; NFA.Add_Empty_Transition (From, Nested_End); end; end if; when type_element => Create_Element_State (Details.Element, Start, From, False, S1, Nested_End, transition_symbol); when type_group => Gr := Get (Parser.Shared.Global_Groups, Details.Group.Ref); if Gr = No_Group_Descr then Validation_Error (Parser, "No group """ & To_QName (Details.Group.Ref) & '"', Details.Group.Loc); elsif Gr.Details.In_Process then Validation_Error (Parser, "Circular group reference for " & To_QName (Details.Group.Ref), Details.Group.Loc); end if; Process_Details (In_Type, Gr.Details, Start, From, Nested_End, Mask); when type_extension => declare NFA_Type : type_index; -- Attributes of the base type Internal_Type : internal_type_index; Base_Descr : access type_descr; begin Get_Type_Descr (Name => Details.Extension.Base, Loc => Details.Extension.Loc, NFA_Type => NFA_Type, Internal_Type => Internal_Type); Base_Descr := Get_Type_Descr (NFA, NFA_Type); if Base_Descr.Final (final_extension) then Validation_Error (Parser, To_QName (Base_Descr.Name) & " is final for extensions", Details.Extension.Loc); end if; if Base_Descr.Simple_Content = No_Simple_Type_Index then if Internal_Type /= No_Internal_Type_Index then -- We have all the details, and just have to copy them -- Details might be null, for instance for an -- that just adds attributes if Shared.Types.Table (Internal_Type).Details /= null and then Shared.Types.Table (Internal_Type).Details .In_Process then Validation_Error (Parser, "Circular inheritance of type " & To_QName (Details.Extension.Base), Details.Extension.Loc); end if; Process_Details (In_Type, Shared.Types.Table (Internal_Type).Details, Start, From, S, Mask); else -- ??? Should copy the nested NFA for TyS Validation_Error (Parser, "Extension's base in a different file " & To_QName (Details.Extension.Base), Details.Extension.Loc, XML_Not_Implemented'identity); end if; Process_Details (In_Type, Details.Extension.Details, Start, S, Nested_End, Mask); else -- ??? Should handle simple types Nested_End := Start; -- The test is correct. However, it makes -- msData/particles/particlesZ031.xsd fails, because the -- test is incorrect. The test pretends that the XSD is -- valid, but later checkins in the testsuite have proven -- it incorrect. The following Ada test would make the -- test pass, but then -- MS-Additional2006-07-15/addB036 -- fails -- -- and then -- (Internal_Type = No_Internal_Type_Index -- or else Shared.Types.Table (Internal_Type).Is_Simple) if not Details.Simple_Content then Validation_Error (Parser, "base type specified in complexContent definition" & " must be a complex type", Details.Extension.Loc); end if; end if; In_Type.Extension_Of := NFA_Type; In_Type.Restriction_Of := No_Type_Index; end; when type_restriction => declare Internal : internal_type_index; NFA_Type : type_index; -- Attributes of the base type Base_Descr : access type_descr; begin Get_Type_Descr (Name => Details.Restriction.Base, Loc => No_Location, NFA_Type => NFA_Type, Internal_Type => Internal); Base_Descr := Get_Type_Descr (NFA, NFA_Type); if Base_Descr.Final (final_restriction) then Validation_Error (Parser, To_QName (Base_Descr.Name) & " is final for restrictions", Details.Restriction.Loc); end if; if Base_Descr.Simple_Content = No_Simple_Type_Index then if Internal /= No_Internal_Type_Index and then Shared.Types.Table (Internal).Details /= null and then Shared.Types.Table (Internal).Details .In_Process then Validation_Error (Parser, "Circular inheritance of type " & To_QName (Details.Restriction.Base), Details.Restriction.Loc); end if; Process_Details (In_Type, Details.Restriction.Details, Start, From, Nested_End, Mask); else -- ??? Should handle simple types Nested_End := Start; if not Details.Simple_Content_Restriction then Validation_Error (Parser, "base type specified in complexContent definition" & " must be a complex type", Details.Restriction.Loc); end if; end if; In_Type.Restriction_Of := NFA_Type; In_Type.Extension_Of := No_Type_Index; end; when type_any => S := NFA.Add_State; -- ((Simple => 1, others => <>)); NFA.Set_Nested (S, Ur_Type (NFA, Details.Any.Process_Contents)); NFA.Add_Transition (From, S, (transition_any, Combine (Parser.Grammar, No_Any_Descr, Local_Process => Details.Any.Process_Contents, Local => Details.Any.Namespaces, As_Restriction => False, Target_NS => Details.Any.Target_NS))); Nested_End := NFA.Add_State; NFA.On_Empty_Nested_Exit (S, Nested_End); end case; -- For elements, we can only have maxOccurs=1 and minOccurs=0 -- or 1. In the case of minOccurs=0, and since we use conditional -- links there, we cannot create a direct empty transition from the -- start state to the final state (since the -- transition_close_from_all is on exit of that final state, and -- thus would be *after* the new empty transition). So this case -- is handled specially in Process_Type. if Details.Kind /= type_all then if Details.Max_Occurs.Unbounded then Nested_End := NFA.Repeat (From, Nested_End, Details.Min_Occurs.Value, Natural'last); else Nested_End := NFA.Repeat (From, Nested_End, Details.Min_Occurs .Value, Details.Max_Occurs .Value); end if; end if; Details.In_Process := False; end Process_Details; ---------------------------- -- Resolve_Attribute_Type -- ---------------------------- procedure Resolve_Attribute_Type (Attr : in out internal_attribute_descr; Loc : Sax.Locators.location) is TRef : global_reference; NFA_Type : type_index; -- In NFA begin if Attr.Local_Type /= No_Internal_Type_Index then NFA_Type := Shared.Types.Table (Attr.Local_Type).In_NFA; Attr.Descr.Simple_Type := Get_Type_Descr (NFA, NFA_Type).Simple_Content; elsif Attr.Typ = No_Qualified_Name then -- ??? Type should be ur-type (3.2.2) null; else TRef := Get (Ref.all, (Attr.Typ, ref_type)); if TRef = No_Global_Reference then Validation_Error (Parser, "Unknown type: " & To_QName (Attr.Typ), Loc); else Attr.Descr.Simple_Type := Get_Type_Descr (NFA, TRef.Typ).Simple_Content; end if; end if; end Resolve_Attribute_Type; -------------------- -- Add_Attributes -- -------------------- procedure Add_Attributes (List : in out attributes_list; Attrs : attr_array_access; Processed_Groups : in out AttrGroup_HTables.instance; As_Restriction : Boolean; Had_Any : in out Boolean) is Gr : attrgroup_descr; TRef : global_reference; begin if Attrs /= null then for A in Attrs'range loop case Attrs (A).Kind is when kind_unset => null; when kind_group => Gr := Get (Shared.Global_AttrGroups, Attrs (A).Group_Ref); if Gr = No_AttrGroup_Descr then Validation_Error (Parser, "Reference to undefined attributeGroup: " & To_QName (Attrs (A).Group_Ref), Attrs (A).Loc); elsif Get (Processed_Groups, Gr.Name) /= No_AttrGroup_Descr then Validation_Error (Parser, "attributeGroup """ & To_QName (Attrs (A).Group_Ref) & """ has circular reference", Attrs (A).Loc); else Set (Processed_Groups, Gr.Name, Gr); Add_Attributes (List, Gr.Attributes, Processed_Groups, As_Restriction, Had_Any); end if; when kind_attribute => if Attrs (A).Attr.Ref /= No_Qualified_Name then TRef := Get (Ref.all, (Attrs (A).Attr.Ref, ref_attribute)); if TRef = No_Global_Reference then Validation_Error (Parser, "Unknown referenced attribute: " & To_QName (Attrs (A).Attr.Ref), Attrs (A).Loc); end if; Add_Attribute (Parser, List, Attribute => Attrs (A).Attr.Descr, Ref => TRef.Attributes.Named, Loc => Attrs (A).Loc); else Resolve_Attribute_Type (Attrs (A).Attr, Attrs (A).Loc); if Attrs (A).Attr.Any /= No_Internal_Any_Descr then Had_Any := True; Add_Any_Attribute (Parser.Grammar, List, Attrs (A).Attr.Any, As_Restriction); else Add_Attribute (Parser, List, Attrs (A).Attr.Descr, Loc => Attrs (A).Loc); end if; end if; end case; end loop; end if; end Add_Attributes; ------------------------ -- Create_Simple_Type -- ------------------------ procedure Create_Simple_Type (J : internal_type_index; Descr : out type_descr_access; Index : out type_index) is Info : internal_type_descr renames Shared.Types.Table (J); Simple : simple_type_descr; Index_In_Simple : Natural; Internal : internal_simple_type_descr; Result : simple_type_index; begin Index := Info.In_NFA; Descr := type_descr_access (NFA.Get_Type_Descr (Index)); Result := Descr.Simple_Content; if Result /= No_Simple_Type_Index then if Debug then Debug_Output ("Create_Simple_Type: already done " & To_QName (Info.Properties.Name)); end if; return; end if; Internal := Info.Simple; if Internal.Kind = simple_type_none then -- Not a simple type, nothing to do Descr := null; return; end if; if Internal.In_Process then Validation_Error (Parser, "Circular inheritance of type " & To_QName (Info.Properties.Name), Info.Loc); end if; if Debug then Debug_Output ("Create_Simple_Type " & To_QName (Info.Properties.Name) & " " & Internal.Kind'img); end if; Info.Simple.In_Process := True; case Internal.Kind is when simple_type_none => Descr := null; return; when simple_type => -- ??? Shouldn't we set Simple_Content as well ? Descr.Restriction_Of := Any_Simple_Type_Index; when simple_type_union => Simple := (Kind => primitive_union, Union => (others => No_Simple_Type_Index), others => <>); Index_In_Simple := Simple.Union'first; for U in Internal.Union_Items'range loop declare Member : constant type_member := Internal.Union_Items (U); Item : type_descr_access; Index : type_index; begin exit when Member = No_Type_Member; if Member.Name /= No_Qualified_Name then Lookup_Simple_Type (Member.Name, Internal.Loc, Item, Index); if Item.Final (final_union) then Validation_Error (Parser, To_QName (Member.Name) & " is final for union", Internal.Loc); end if; else Create_Simple_Type (Member.Local, Item, Index); end if; Simple.Union (Index_In_Simple) := Item.Simple_Content; Index_In_Simple := Index_In_Simple + 1; end; end loop; Result := Create_Simple_Type (NFA, Simple); Descr.Simple_Content := Result; Descr.Restriction_Of := Any_Simple_Type_Index; when simple_type_list => Simple := (Kind => primitive_list, List_Item => No_Simple_Type_Index, others => <>); for U in Internal.List_Items'range loop declare Member : constant type_member := Internal.List_Items (U); Item : type_descr_access; Index : type_index; begin exit when Member = No_Type_Member; if Member.Name /= No_Qualified_Name then Lookup_Simple_Type (Member.Name, Internal.Loc, Item, Index); if Item.Final (final_list) then Validation_Error (Parser, To_QName (Member.Name) & " is final for list", Internal.Loc); end if; else Create_Simple_Type (Member.Local, Item, Index); end if; Simple.List_Item := Item.Simple_Content; end; end loop; Result := Create_Simple_Type (NFA, Simple); Descr.Simple_Content := Result; Descr.Restriction_Of := Any_Simple_Type_Index; when simple_type_restriction | simple_type_extension => declare Base : simple_type_descr; Error : symbol; Loc : location; NFA_Simple : type_descr_access; NFA_Type : type_index; begin if Internal.Base.Name /= No_Qualified_Name then Lookup_Simple_Type (Internal.Base.Name, Internal.Loc, NFA_Simple, NFA_Type); else Create_Simple_Type (Internal.Base.Local, NFA_Simple, NFA_Type); end if; if Internal.Base = No_Type_Member then Base := Any_Simple_Type; NFA_Type := Any_Simple_Type_Index; elsif NFA_Simple = null or else NFA_Simple.Simple_Content = No_Simple_Type_Index then Validation_Error (Parser, "base type specified in simpleContent definition must" & " be a simple type", Loc); else Base := Copy (Get_Simple_Type (NFA, NFA_Simple.Simple_Content)); Override (Simple => Base, Facets => Internal.Facets, Symbols => Get_Symbol_Table (Parser.all), As_Restriction => Internal.Kind = simple_type_restriction, Error => Error, Error_Loc => Loc); if Error /= No_Symbol then Validation_Error (Parser, Get (Error).all, Loc); end if; end if; case Internal.Kind is when simple_type_restriction => Descr.Restriction_Of := NFA_Type; when simple_type_extension => Descr.Extension_Of := NFA_Type; when others => null; end case; Result := Create_Simple_Type (NFA, Base); Descr.Simple_Content := Result; end; end case; Info.Simple.In_Process := False; end Create_Simple_Type; ------------------------------ -- Create_Global_Attributes -- ------------------------------ procedure Create_Global_Attributes (Attr : internal_attribute_descr) is Attr2 : internal_attribute_descr; begin pragma assert (Attr.Ref = No_Qualified_Name, "A global attribute cannot define ref"); pragma assert (Attr.Descr.Name /= No_Qualified_Name, "A global attribute must have a name"); pragma assert (Attr.Any = No_Internal_Any_Descr, "A global attribute is not "); pragma assert (Attr.Descr.Next = Empty_Named_Attribute_List, "Global attributes cannot be in a list"); pragma assert (Attr.Descr.Simple_Type = No_Simple_Type_Index, "Type of global attributes should be undefined here"); Attr2 := Attr; Resolve_Attribute_Type (Attr2, No_Location); Create_Global_Attribute (Parser, Attr2.Descr, No_Location); end Create_Global_Attributes; ------------------ -- Process_Type -- ------------------ procedure Process_Type (Info : in out internal_type_descr) is S1 : state; List : attributes_list := No_Attributes; Processed_Groups : AttrGroup_HTables.instance; -- ??? If this table is here, we can't have an with the -- same attributeGroup as its base type. Maybe this should be local -- to Recursive_Add_Attributes instead procedure Recursive_Add_Attributes (Info : internal_type_descr); procedure Recursive_Add_Attributes (Info : internal_type_descr) is Ty : global_reference; Index : internal_type_index; Had_Any : Boolean := False; Base : qualified_name; As_Restriction : Boolean; begin if Info.Is_Simple then -- A simpleType has no attribute return; elsif Info.Details = null then Add_Attributes (List, Info.Attributes, Processed_Groups, As_Restriction => True, Had_Any => Had_Any); Reset (Processed_Groups); return; end if; if Info.Details.Kind = type_extension then Base := Info.Details.Extension.Base; As_Restriction := False; elsif Info.Details.Kind = type_restriction then Base := Info.Details.Restriction.Base; As_Restriction := True; else Base := No_Qualified_Name; end if; if Base = No_Qualified_Name then -- No character data is allowed, but we might have attributes Add_Attributes (List, Info.Attributes, Processed_Groups, As_Restriction => True, Had_Any => Had_Any); elsif not As_Restriction then Ty := Get (Ref.all, (Base, ref_type)); if Ty = No_Global_Reference then Validation_Error (Parser, "No type """ & To_QName (Base) & """", Info.Loc); end if; -- If the base type is in the current package, we might not -- have computed all its attributes. Otherwise, get the list of -- attributes already computed in the grammar, since it is -- complete. Index := Get (Types, Base); if Index /= No_Internal_Type_Index then Recursive_Add_Attributes (Shared.Types.Table (Index)); else Add_Attributes (Parser, List, Get_Type_Descr (NFA, Ty.Typ).Attributes, As_Restriction => False, Loc => Info.Loc); end if; Add_Attributes (List, Info.Attributes, Processed_Groups, As_Restriction => False, Had_Any => Had_Any); else Ty := Get (Ref.all, (Base, ref_type)); if Ty = No_Global_Reference then Validation_Error (Parser, "No type """ & To_QName (Base) & """", Info.Loc); end if; Index := Get (Types, Base); if Index /= No_Internal_Type_Index then Recursive_Add_Attributes (Shared.Types.Table (Index)); else Add_Attributes (Parser, List, Get_Type_Descr (NFA, Ty.Typ).Attributes, As_Restriction => True, Loc => Info.Loc); end if; Had_Any := False; Add_Attributes (List, Info.Attributes, Processed_Groups, As_Restriction => True, Had_Any => Had_Any); -- Always add , even if none was given in the -- restriction (in which case none should exist for the type -- either); if not Had_Any then List.Any := No_Any_Descr; -- Nothing matches end if; end if; end Recursive_Add_Attributes; begin if Info.Is_Simple then null; -- Already done in Process_Type else if Debug then Debug_Output ("Process complexType " & To_QName (Info.Properties.Name)); end if; declare Descr : constant access type_descr := Get_Type_Descr (NFA, Info.In_NFA); Mask : visited_all_children; Start : state := Descr.Complex_Content; Is_All : constant Boolean := Info.Details /= null and then Info.Details.Kind = type_all; begin pragma assert (Descr.Complex_Content /= No_State); if Is_All and then Info.Details.Min_Occurs.Value = 0 then -- See comment in Process_Details as to why this is -- handled here. -- We should not make the transition directly from the -- start node (Descr.Complex_Content), because it would -- mean a user can start a and stop -- in the middle with no error Start := NFA.Add_State; NFA.Add_Empty_Transition (Descr.Complex_Content, Start); end if; Process_Details (In_Type => Descr, Details => Info.Details, Start => Start, -- Descr.Complex_Content, From => Start, Nested_End => S1, Mask => Mask); -- Add the attributes only after we did the details, so that we -- know there is no infinite recursion between the base types -- of extensions and restrictions if Debug then Debug_Output ("Process attributes for complexType " & To_QName (Info.Properties.Name) & " State=" & Descr.Complex_Content'img & " type_index=" & Info.In_NFA'img); end if; Recursive_Add_Attributes (Info); Descr.Attributes := List; if Is_All then NFA.Add_Transition (S1, Final_State, (Kind => transition_close_from_all, Mask => Mask)); if Info.Details.Min_Occurs.Value = 0 then NFA.Add_Transition (Descr .Complex_Content, Final_State, (Kind => transition_close)); end if; else NFA.Add_Transition (S1, Final_State, (Kind => transition_close)); end if; end; end if; Reset (Processed_Groups); exception when others => Reset (Processed_Groups); raise; end Process_Type; Element_Info : element_descr; Attr : internal_attribute_descr; S : state; Ignored : type_descr_access; Ignored_Index : type_index; pragma unreferenced (Ignored, Ignored_Index); begin if Debug then Debug_Output ("Create_NFA"); end if; -- Prepare the entries for the types. These are empty to start with, but -- they are needed to be able to create the more complex types, and the -- global element. for J in Type_Tables.First .. Last (Shared.Types) loop -- Create the empty nested NFA if needed S := No_State; if not Shared.Types.Table (J).Is_Simple then S := NFA.Add_State; Shared.Types.Table (J).Properties.Complex_Content := S; if Debug then Debug_Output ("Created state for complexContent " & To_QName (Shared.Types.Table (J).Properties.Name) & " type=" & J'img & " state=" & S'img); end if; end if; Shared.Types.Table (J).In_NFA := Create_Type (NFA, Shared.Types.Table (J).Properties); if S /= No_State then -- At least .Complex_Content has changed, so we need to reset data NFA.Set_Data (S, state_data' (Simple => Shared.Types.Table (J).In_NFA, Block => No_Block, Nillable => False, Default => No_Symbol, Fixed => No_Symbol)); end if; if Shared.Types.Table (J).Properties.Name /= No_Qualified_Name then Set (Types, Shared.Types.Table (J).Properties.Name, J); end if; end loop; -- Process the simple types (must be in a separate loop, since a -- restriction or a union needs to know about its base type) for J in Type_Tables.First .. Last (Shared.Types) loop Create_Simple_Type (J, Ignored, Ignored_Index); end loop; -- Prepare the entries for the global attributes Attr := Get_First (Shared.Global_Attributes); while Attr /= No_Internal_Attribute loop Create_Global_Attributes (Attr); Attr := Get_Next (Shared.Global_Attributes); end loop; -- Prepare schema for global elements if Debug then Debug_Output ("Create_NFA: adding global elements"); end if; Element_Info := Get_First (Shared.Global_Elements); while Element_Info /= No_Element_Descr loop Process_Global_Element (Element_Info, Start_State); -- Save the state Set (Shared.Global_Elements, Element_Info.Name, Element_Info); Element_Info := Get_Next (Shared.Global_Elements); end loop; if Debug then Debug_Output ("Create_NFA: complete type definition"); end if; -- Finally, complete the definition of complexTypes for J in Type_Tables.First .. Last (Shared.Types) loop Process_Type (Shared.Types.Table (J)); end loop; if Debug then Output_Action ("NFA: " & Dump_Dot_NFA (Get_Grammar (Parser.all))); end if; Reset (Types); exception when others => Reset (Types); raise; end Create_NFA; ---------- -- Free -- ---------- procedure Free (Shared : in out xsd_data_access) is procedure Unchecked_Free is new Ada.Unchecked_Deallocation (xsd_data, xsd_data_access); Attr : attrgroup_descr; Gr : group_descr; begin if Shared /= null then -- Free all data structures, no longer needed Reset (Shared.Global_Elements); Gr := Get_First (Shared.Global_Groups); while Gr /= No_Group_Descr loop Free (Gr.Details); Gr := Get_Next (Shared.Global_Groups); end loop; Reset (Shared.Global_Groups); Attr := Get_First (Shared.Global_AttrGroups); while Attr /= No_AttrGroup_Descr loop Unchecked_Free (Attr.Attributes); Attr := Get_Next (Shared.Global_AttrGroups); end loop; Reset (Shared.Global_AttrGroups); for T in Type_Tables.First .. Last (Shared.Types) loop if Shared.Types.Table (T).Is_Simple then null; else Unchecked_Free (Shared.Types.Table (T).Attributes); Free (Shared.Types.Table (T).Details); end if; end loop; Free (Shared.Types); Reset (Shared.Global_Attributes); Unchecked_Free (Shared); end if; end Free; ------------------- -- Parse_Grammar -- ------------------- procedure Parse_Grammar (Handler : access validating_reader'class; URI : symbol; Xsd_File : symbol; Do_Create_NFA : Boolean) is File : file_input; Schema : schema_reader; S_File_Full : constant symbol := To_Absolute_URI (Handler.all, Xsd_File); Need_To_Initialize : Boolean := True; begin GNAT.Task_Lock.Lock; Set_XML_Version (Schema, Get_XML_Version (Handler.all)); if URI_Was_Parsed (Get_Grammar (Handler.all), S_File_Full) then if Debug then Debug_Output ("Parse_Grammar " & Get (S_File_Full).all & " already parsed"); end if; GNAT.Task_Lock.Unlock; return; end if; if Debug then Debug_Output ("Parse_Grammar NS={" & Get (URI).all & "} XSD={" & Get (Xsd_File).all & "} " & Get (S_File_Full).all); end if; if Get_XSD_Version (Handler.Grammar) = xsd_1_0 then -- Must check that no element of the same namespace was seen -- already (as per 4.3.2 (4) in the XSD 1.0 norm, which was -- changed in XSD 1.1). declare NS : xml_ns; begin Find_NS_From_URI (Handler.all, URI => URI, NS => NS); if NS /= No_XML_NS and then Element_Count (NS) > 0 and then S_File_Full /= Get_System_Id (NS) and then Get_Feature (Handler.all, Sax.Readers.Schema_Validation_Feature) then Validation_Error (Handler, "schemaLocation for """ & Get (URI).all & """ cannot occur after the first" & " element of that namespace in XSD 1.0"); end if; end; end if; if Debug then Output_Seen ("Parsing grammar: " & Get (S_File_Full).all); end if; Open (Get (S_File_Full).all, File); Set_Public_Id (File, Get (S_File_Full).all); Set_System_Id (File, Get (S_File_Full).all); -- Add_To will likely already contain the grammar for the -- schema-for-schema, and we won't have to recreate it in most cases. Set_Symbol_Table (Schema, Get_Symbol_Table (Handler.all)); Set_Grammar (Schema, Handler.Grammar); Use_Basename_In_Error_Messages (Schema, Use_Basename_In_Error_Messages (Handler.all)); Set_Feature (Schema, Sax.Readers.Schema_Validation_Feature, Get_Feature (Handler.all, Sax.Readers.Schema_Validation_Feature)); if Handler.all in schema_reader'class then Schema.Shared := schema_reader (Handler.all).Shared; Need_To_Initialize := False; end if; begin Internal_Parse (Schema, File, Default_Namespace => URI, Do_Initialize_Shared => Need_To_Initialize, Do_Create_NFA => Need_To_Initialize and Do_Create_NFA); exception when XML_Not_Implemented | XML_Validation_Error => -- Copy the error message and location from Schema to Handler Close (File); Handler.Error_Msg := Schema.Error_Msg; Handler.Error_Location := Schema.Error_Location; raise; end; Free (Schema); Close (File); if Debug then Output_Seen ("Done parsing new grammar: " & Get (Xsd_File).all); end if; GNAT.Task_Lock.Unlock; exception when Ada.IO_Exceptions.Name_Error => Free (Schema); Close (File); GNAT.Task_Lock.Unlock; if Debug then Debug_Output (ASCII.LF & "!!!! Could not open file " & Get (S_File_Full).all & ASCII.LF); end if; -- According to XML Schema Primer 0, section 5.6, this is not an -- error when we do not find the schema, since this attribute is only -- a hint. Warning (Handler.all, Create (Message => "Could not open file " & Get (S_File_Full).all, Loc => Handler.Current_Location)); when others => GNAT.Task_Lock.Unlock; Close (File); raise; end Parse_Grammar; -------------------- -- Internal_Parse -- -------------------- procedure Internal_Parse (Parser : in out schema_reader; Input : in out Input_Sources.input_source'class; Default_Namespace : symbol; Do_Create_NFA : Boolean; Do_Initialize_Shared : Boolean) is Grammar : constant xml_grammar := Get_Grammar (Parser); URI : symbol; begin if Debug then Output_Action ("Parsing schema " & Input_Sources.Get_System_Id (Input)); end if; Initialize_Symbols (Parser); URI := Find_Symbol (Parser, Input_Sources.Get_System_Id (Input)); if not URI_Was_Parsed (Grammar, URI) then if Do_Initialize_Shared then Parser.Shared := new xsd_data; Init (Parser.Shared.Types); end if; Initialize_Grammar (Parser); Parser.Target_NS := Default_Namespace; Set_Grammar (Parser, Grammar); -- In case it was not initialized yet Set_Parsed_URI (Parser, URI); Schema.Readers.Parse (validating_reader (Parser), Input); if Do_Create_NFA then Create_NFA (Parser'access); end if; if Do_Initialize_Shared then Free (Parser.Shared); end if; Unchecked_Free (Parser.Contexts); end if; exception when others => Unchecked_Free (Parser.Contexts); if Do_Initialize_Shared then Free (Parser.Shared); end if; raise; end Internal_Parse; ----------- -- Parse -- ----------- procedure Parse (Parser : in out schema_reader; Input : in out Input_Sources.input_source'class) is begin Internal_Parse (Parser, Input, Default_Namespace => Empty_String, Do_Create_NFA => True, Do_Initialize_Shared => True); end Parse; ------------------- -- Resolve_QName -- ------------------- function Resolve_QName (Handler : access schema_reader'class; QName : Sax.Symbols.symbol; NS_If_Empty : Sax.Symbols.symbol := Empty_String; Loc : location) return qualified_name is Val : cst_byte_sequence_access; Separator : Integer; NS : xml_ns; Prefix : symbol; begin if QName = No_Symbol then return No_Qualified_Name; else Val := Get (QName); Separator := Split_Qname (Val.all); Prefix := Find_Symbol (Handler.all, Val (Val'first .. Separator - 1)); Get_Namespace_From_Prefix (Handler => Handler.all, Prefix => Prefix, NS => NS); if NS = No_XML_NS then if Prefix /= Empty_String then Validation_Error (Handler, "Cannot resolve namespace prefix " & Val (Val'first .. Separator - 1), Loc); return No_Qualified_Name; else return (NS => NS_If_Empty, Local => Find_Symbol (Handler.all, Val (Separator + 1 .. Val'last))); end if; else return (NS => Get_URI (NS), Local => Find_Symbol (Handler.all, Val (Separator + 1 .. Val'last))); end if; end if; end Resolve_QName; ---------------- -- Get_Occurs -- ---------------- procedure Get_Occurs (Handler : access schema_reader'class; Atts : sax_attribute_list; Min_Occurs, Max_Occurs : out occurrences) is Min_Occurs_Index : constant Integer := Get_Index (Atts, URI => Empty_String, Local_Name => Handler.MinOccurs); Max_Occurs_Index : constant Integer := Get_Index (Atts, URI => Empty_String, Local_Name => Handler.MaxOccurs); function Occurs_From_Value (Index : Integer) return occurrences; -- Return the value of maxOccurs from the attributes'value. This -- properly takes into account the "unbounded" case function Occurs_From_Value (Index : Integer) return occurrences is Value : constant symbol := Get_Value (Atts, Index); begin if Value = Handler.Unbounded then return (Unbounded => True); else declare Val : constant cst_byte_sequence_access := Get (Value); Pos : Integer; C : unicode_char; begin return (Unbounded => False, Value => Natural'value (Val.all)); exception when Constraint_Error => -- Either we have an integer too big to fit in Integer, or -- we do not have an integer at all Pos := Val'first; while Pos <= Val'last loop Encoding.Read (Val.all, Pos, C); if not Is_Digit (C) then Validation_Error (Handler, "Value for ""maxOccurs"" must" & " be an integer or ""unbounded"""); end if; end loop; return (Unbounded => False, Value => Natural'last); end; end if; end Occurs_From_Value; begin Min_Occurs := (False, 1); Max_Occurs := (False, 1); if Min_Occurs_Index /= -1 then Min_Occurs := Occurs_From_Value (Min_Occurs_Index); if Min_Occurs.Unbounded then Validation_Error (Handler, "minOccurs cannot be ""unbounded"""); end if; end if; if Max_Occurs_Index /= -1 then Max_Occurs := Occurs_From_Value (Max_Occurs_Index); end if; if not Max_Occurs.Unbounded and then Max_Occurs.Value > max_max_occurs then Validation_Error (Handler, "maxOccurs is too big, consider using ""unbounded""", Except => XML_Not_Implemented'identity); end if; end Get_Occurs; ------------------ -- Push_Context -- ------------------ procedure Push_Context (Handler : access schema_reader'class; Ctx : context) is Tmp : context_array_access; begin if Handler.Contexts_Last = 0 then Handler.Contexts := new context_array (1 .. default_contexts); elsif Handler.Contexts_Last = Handler.Contexts'last then Tmp := new context_array (1 .. Handler.Contexts'last + 30); Tmp (Handler.Contexts'range) := Handler.Contexts.all; Unchecked_Free (Handler.Contexts); Handler.Contexts := Tmp; end if; Handler.Contexts_Last := Handler.Contexts_Last + 1; Handler.Contexts (Handler.Contexts_Last) := Ctx; end Push_Context; ------------------ -- Create_Group -- ------------------ procedure Create_Group (Handler : access schema_reader'class; Atts : sax_attribute_list) is Min_Occurs, Max_Occurs : occurrences := (False, 1); Group : group_descr; Name : qualified_name; Details : type_details_access; begin Group.Loc := Handler.Current_Location; for J in 1 .. Get_Length (Atts) loop Name := Get_Name (Atts, J); if Name.NS = Empty_String then if Name.Local = Handler.Name then Group.Name := (NS => Handler.Target_NS, Local => Get_Value (Atts, J)); elsif Name.Local = Handler.Ref then Group.Ref := Resolve_QName (Handler, Get_Value (Atts, J), Loc => Get_Location (Atts, J)); end if; end if; end loop; case Handler.Contexts (Handler.Contexts_Last).Typ is when context_schema | context_redefine => null; when context_sequence | context_choice | context_extension | context_restriction => Get_Occurs (Handler, Atts, Min_Occurs, Max_Occurs); Details := new type_details' (Kind => type_group, Min_Occurs => Min_Occurs, Max_Occurs => Max_Occurs, Loc => Handler.Current_Location, In_Process => False, Next => null, Group => Group); Insert_In_Type (Handler, Details); when others => Validation_Error (Handler, "Unsupported ""group"" in this context", Except => XML_Not_Implemented'identity); end case; Push_Context (Handler, (Typ => context_group, Group => Group)); end Create_Group; ------------------ -- Finish_Group -- ------------------ procedure Finish_Group (Handler : access schema_reader'class) is Ctx : constant context_access := Handler.Contexts (Handler.Contexts_Last)'access; Next : constant context_access := Handler.Contexts (Handler.Contexts_Last - 1)'access; begin case Next.Typ is when context_schema | context_redefine => Set (Handler.Shared.Global_Groups, Ctx.Group.Name, Ctx.Group); when others => null; end case; end Finish_Group; ---------------------------- -- Create_Attribute_Group -- ---------------------------- procedure Create_Attribute_Group (Handler : access schema_reader'class; Atts : sax_attribute_list) is Group : attrgroup_descr; Name : qualified_name; begin for J in 1 .. Get_Length (Atts) loop Name := Get_Name (Atts, J); if Name.NS = Empty_String then if Name.Local = Handler.Name then Group.Name := (NS => Handler.Target_NS, Local => Get_Value (Atts, J)); elsif Name.Local = Handler.Ref then Group.Ref := Resolve_QName (Handler, Get_Value (Atts, J), Loc => Get_Location (Atts, J)); end if; end if; end loop; Push_Context (Handler, (Typ => context_attribute_group, Attr_Group => Group)); end Create_Attribute_Group; ---------------------------- -- Finish_Attribute_Group -- ---------------------------- procedure Finish_Attribute_Group (Handler : access schema_reader'class) is Ctx : constant context_access := Handler.Contexts (Handler.Contexts_Last)'access; Next : constant context_access := Handler.Contexts (Handler.Contexts_Last - 1)'access; Ctx2 : context_access; Index : Natural; begin case Next.Typ is when context_schema | context_redefine => Set (Handler.Shared.Global_AttrGroups, Ctx.Attr_Group.Name, Ctx.Attr_Group); when context_type_def => pragma assert (Ctx.Attr_Group.Attributes = null); Append (Handler.Shared.Types.Table (Next.Type_Info).Attributes, (Kind => kind_group, Loc => Handler.Current_Location, Group_Ref => Ctx.Attr_Group.Ref)); when context_extension => pragma assert (Ctx.Attr_Group.Attributes = null); Index := Handler.Contexts_Last - 1; while Index >= Handler.Contexts'first loop Ctx2 := Handler.Contexts (Index)'access; if Ctx2.Typ = context_type_def then Append (Handler.Shared.Types.Table (Ctx2.Type_Info).Attributes, (Kind => kind_group, Loc => Handler.Current_Location, Group_Ref => Ctx.Attr_Group.Ref)); exit; end if; Index := Index - 1; end loop; when context_attribute_group => pragma assert (Ctx.Attr_Group.Attributes = null); Append (Next.Attr_Group.Attributes, (Kind => kind_group, Loc => Handler.Current_Location, Group_Ref => Ctx.Attr_Group.Ref)); when others => Unchecked_Free (Ctx.Attr_Group.Attributes); Validation_Error (Handler, "Invalid context for attributeGroup: " & Next.Typ'img, Except => XML_Not_Implemented'identity); end case; end Finish_Attribute_Group; ------------ -- Append -- ------------ procedure Append (List : in out attr_array_access; Attr : attr_descr) is Tmp : attr_array_access; begin if List = null then List := new attr_array' (1 => Attr, 2 .. 10 => (Kind => kind_unset, Loc => No_Location)); elsif List (List'last).Kind /= kind_unset then Tmp := new attr_array (1 .. List'last + 10); Tmp (List'range) := List.all; Tmp (List'last + 1) := Attr; Tmp (List'last + 2 .. Tmp'last) := (others => attr_descr'(Kind => kind_unset, Loc => No_Location)); Unchecked_Free (List); List := Tmp; else for L in List'range loop if List (L).Kind = kind_unset then List (L) := Attr; return; end if; end loop; end if; end Append; -------------------- -- Create_Include -- -------------------- procedure Create_Include (Handler : access schema_reader'class; Atts : sax_attribute_list) is Schema_Location_Index : constant Integer := Get_Index (Atts, Empty_String, Handler.Schema_Location); begin Parse_Grammar (Handler, URI => Handler.Target_NS, Xsd_File => Get_Value (Atts, Schema_Location_Index), Do_Create_NFA => False); -- Will be performed later end Create_Include; --------------------- -- Create_Redefine -- --------------------- procedure Create_Redefine (Handler : access schema_reader'class; Atts : sax_attribute_list) is Location_Index : constant Integer := Get_Index (Atts, Empty_String, Handler.Schema_Location); begin -- Disable for now. -- On the test./testschema -xsd boeingData/ipo4/ipo.xsd -- -xsd boeingData/ipo4/address.xsd -- -xsd boeingData/ipo4/itematt.xsd -- boeingData/ipo4/ipo_1.xml -- we redefine an extension whose base type comes from the redefined -- grammar, and whose name is the same. As a result, the extension and -- its base type end up being the same XML_Type, and thus we get -- infinite loops. We should really merge the models when the grammar is -- parsed. Validation_Error (Handler, " not supported", Except => XML_Not_Implemented'identity); Parse_Grammar (Handler, URI => Handler.Target_NS, Do_Create_NFA => True, Xsd_File => Get_Value (Atts, Location_Index)); Push_Context (Handler, (Typ => context_redefine)); end Create_Redefine; ------------------- -- Create_Import -- ------------------- procedure Create_Import (Handler : access schema_reader'class; Atts : sax_attribute_list) is Location_Index : constant Integer := Get_Index (Atts, Empty_String, Handler.Schema_Location); Namespace_Index : constant Integer := Get_Index (Atts, Empty_String, Handler.Namespace); begin if Location_Index = -1 then if Namespace_Index = -1 then -- See 4.2.6.1: If that attribute is absent, then the import -- allows unqualified reference to components with no target -- namespace null; end if; Validation_Error (Handler, "Import with no schemaLocation is unsupported", Except => XML_Not_Implemented'identity); else declare Location : constant symbol := Get_Value (Atts, Location_Index); begin if Debug then Debug_Output ("Import: " & Get (Location).all); Debug_Output ("Adding new grammar to Handler.Created_Grammar"); end if; -- The namespace attribute indicates that the XSD may contain -- qualified references to schema components in that namespace. -- (4.2.6.1). It does not give the default targetNamespace Parse_Grammar (Handler, URI => Empty_String, Do_Create_NFA => True, Xsd_File => Location); end; end if; end Create_Import; -------------------------- -- Create_Any_Attribute -- -------------------------- procedure Create_Any_Attribute (Handler : access schema_reader'class; Atts : sax_attribute_list) is Name : qualified_name; Att : attr_descr (Kind => kind_attribute); begin Att.Loc := Handler.Current_Location; Att.Attr.Any := (Namespaces => Handler.Any_Namespace, Target_NS => Handler.Target_NS, Process_Contents => process_strict); for J in 1 .. Get_Length (Atts) loop Name := Get_Name (Atts, J); if Name.NS = Empty_String then if Name.Local = Handler.Namespace then Att.Attr.Any.Namespaces := Get_Value (Atts, J); elsif Name.Local = Handler.Process_Contents then Att.Attr.Any.Process_Contents := Process_Contents_From_Atts (Handler, Atts, J); end if; end if; end loop; Insert_Attribute (Handler, Handler.Contexts_Last, Att); end Create_Any_Attribute; --------------------- -- Create_Notation -- --------------------- procedure Create_Notation (Handler : access schema_reader'class; Atts : sax_attribute_list) is type notation_descr is record Name : symbol; System_Id : symbol := Empty_String; Public_Id : symbol := Empty_String; end record; Name : qualified_name; Notation : notation_descr; begin for J in 1 .. Get_Length (Atts) loop Name := Get_Name (Atts, J); if Name.NS = Empty_String then if Name.Local = Handler.Name then Notation.Name := Get_Value (Atts, J); elsif Name.Local = Handler.Public then Notation.Public_Id := Get_Value (Atts, J); elsif Name.Local = Handler.System then Notation.System_Id := Get_Value (Atts, J); end if; end if; end loop; Add_Notation (Get_NFA (Handler.Grammar), Notation.Name); Notation_Decl (sax_reader'class (Handler.all), Name => Get (Notation.Name).all, System_Id => Get (Notation.System_Id).all, Public_Id => Get (Notation.Public_Id).all); end Create_Notation; -------------------- -- Create_Element -- -------------------- procedure Create_Element (Handler : access schema_reader'class; Atts : sax_attribute_list) is Min_Occurs, Max_Occurs : occurrences := (False, 1); Info : element_descr; Name : qualified_name; Details : type_details_access; begin Info.Loc := Handler.Current_Location; Info.Form := Handler.Element_Form_Default; Info.Block := Handler.Target_Block_Default; for J in 1 .. Get_Length (Atts) loop Name := Get_Name (Atts, J); if Name.NS = Empty_String then if Name.Local = Handler.Typ then Info.Typ := Resolve_QName (Handler, Get_Value (Atts, J), NS_If_Empty => Handler.Target_NS, Loc => Get_Location (Atts, J)); elsif Name.Local = Handler.Name then Info.Name := (NS => Handler.Target_NS, Local => Get_Value (Atts, J)); elsif Name.Local = Handler.Ref then Info.Ref := Resolve_QName (Handler, Get_Value (Atts, J), Loc => Get_Location (Atts, J)); elsif Name.Local = Handler.Substitution_Group then Info.Substitution_Group := Resolve_QName (Handler, Get_Value (Atts, J), Loc => Get_Location (Atts, J)); elsif Name.Local = Handler.Default then Info.Default := Get_Value (Atts, J); elsif Name.Local = Handler.Fixed then Info.Fixed := Get_Value (Atts, J); elsif Name.Local = Handler.S_Abstract then Info.Is_Abstract := Get_Value_As_Boolean (Atts, J, False); elsif Name.Local = Handler.Nillable then Info.Nillable := Get_Value_As_Boolean (Atts, J, False); elsif Name.Local = Handler.Form then Info.Form := Compute_Form (Atts, Handler, J); elsif Name.Local = Handler.Final then Info.Final := Compute_Final (Atts, Handler, J); elsif Name.Local = Handler.Block then Compute_Blocks (Atts, Handler, Info.Block, Info.Has_Block, J); end if; end if; end loop; if Info.Name /= No_Qualified_Name then if Info.Ref /= No_Qualified_Name and then Info.Ref.NS = No_Symbol and then Info.Name = Info.Ref and then not In_Redefine_Context (Handler.all) then Validation_Error (Handler, """ref"" attribute cannot be self-referencing"); elsif Info.Ref /= No_Qualified_Name then Validation_Error (Handler, "Name and Ref cannot be both specified"); end if; elsif Info.Ref = No_Qualified_Name then Validation_Error (Handler, "Either ""name"" or ""ref"" attribute must be present"); else -- Section 3.3.2, validity constraints 3.3.3 if Info.Typ /= No_Qualified_Name then Validation_Error (Handler, """type"" attribute cannot be specified along with ""ref"""); end if; end if; if Info.Default /= No_Symbol and then Info.Fixed /= No_Symbol then Validation_Error (Handler, "Default and Fixed cannot be both specified"); end if; if Info.Ref /= No_Qualified_Name then Info.Form := qualified; end if; if Handler.Contexts (Handler.Contexts_Last).Typ /= context_schema then Get_Occurs (Handler, Atts, Min_Occurs, Max_Occurs); Details := new type_details' (Kind => type_element, Min_Occurs => Min_Occurs, Max_Occurs => Max_Occurs, Loc => Handler.Current_Location, In_Process => False, Next => null, Element => Info); Insert_In_Type (Handler, Details); end if; Push_Context (Handler, (Typ => context_element, Elem_Details => Details, Element => Info)); end Create_Element; -------------------- -- Finish_Element -- -------------------- procedure Finish_Element (Handler : access schema_reader'class) is Ctx : constant context_access := Handler.Contexts (Handler.Contexts_Last)'access; Next : constant context_access := Handler.Contexts (Handler.Contexts_Last - 1)'access; Info : constant element_descr := Ctx.Element; begin case Next.Typ is when context_schema | context_redefine => Set (Handler.Shared.Global_Elements, Info.Name, Info); when others => -- We might have added the type definition Ctx.Elem_Details.Element := Ctx.Element; end case; end Finish_Element; ------------------------ -- Create_Simple_Type -- ------------------------ procedure Create_Simple_Type (Handler : access schema_reader'class; Atts : sax_attribute_list) is Ctx : constant context_access := Handler.Contexts (Handler.Contexts_Last)'access; begin Prepare_Type (Handler, Atts, Is_Simple => True); if Ctx.Typ = context_simple_restriction then Ctx.Simple.Base := (Name => No_Qualified_Name, Local => Handler.Contexts (Handler.Contexts_Last).Type_Info); end if; end Create_Simple_Type; --------------------- -- Add_Type_Member -- --------------------- procedure Add_Type_Member (Handler : access schema_reader'class; List : in out type_member_array; Member : type_member; Loc : location) is begin for A in List'range loop if List (A) = No_Type_Member then List (A) := Member; return; end if; end loop; Validation_Error (Handler, "Too many types in the union", Loc, XML_Not_Implemented'identity); end Add_Type_Member; ------------------------ -- Finish_Simple_Type -- ------------------------ procedure Finish_Simple_Type (Handler : access schema_reader'class) is Ctx : constant context_access := Handler.Contexts (Handler.Contexts_Last)'access; Next : constant context_access := Handler.Contexts (Handler.Contexts_Last - 1)'access; begin case Next.Typ is when context_schema | context_redefine => null; when context_element => Next.Element.Local_Type := Ctx.Type_Info; when context_attribute => Next.Attribute.Attr.Local_Type := Ctx.Type_Info; when context_list => Add_Type_Member (Handler, Next.List.List_Items, (Name => No_Qualified_Name, Local => Ctx.Type_Info), No_Location); when context_union => Add_Type_Member (Handler, Next.Union.Union_Items, (Name => No_Qualified_Name, Local => Ctx.Type_Info), No_Location); when context_restriction => Next.Restriction.Restriction.Details := Handler.Shared.Types.Table (Ctx.Type_Info).Details; when context_simple_restriction => -- The simpleType is in fact the base type of the restriction. The -- following was already done in Create_Simple_Type: -- Next.Simple.Base.Local := Ctx.Type_Info; null; when others => Validation_Error (Handler, "Unsupported: ""simpleType"" in this context", Except => XML_Not_Implemented'identity); end case; end Finish_Simple_Type; -------------------- -- Compute_Blocks -- -------------------- procedure Compute_Blocks (Atts : sax_attribute_list; Handler : access schema_reader'class; Blocks : out block_status; Is_Set : out Boolean; Index : Integer) is procedure On_Item (Str : byte_sequence); procedure On_Item (Str : byte_sequence) is begin if Str = "restriction" then Blocks (block_restriction) := True; elsif Str = "extension" then Blocks (block_extension) := True; elsif Str = "substitution" then Blocks (block_substitution) := True; elsif Str = "#all" then Blocks := (others => True); else Validation_Error (Handler, "Invalid value for block: """ & Str & """"); end if; end On_Item; procedure For_Each is new For_Each_Item (On_Item); begin Is_Set := Index /= -1; Blocks := No_Block; if Index /= -1 then For_Each (Get (Get_Value (Atts, Index)).all); if Debug then Output_Action ("Set_Block (" & To_String (Blocks) & ")"); end if; end if; end Compute_Blocks; ------------------ -- Compute_Form -- ------------------ function Compute_Form (Atts : sax_attribute_list; Handler : access schema_reader'class; Index : Integer) return form_type is begin if Get_Value (Atts, Index) = Handler.Qualified then return qualified; else return unqualified; end if; end Compute_Form; ------------------- -- Compute_Final -- ------------------- function Compute_Final (Atts : sax_attribute_list; Handler : access schema_reader'class; Index : Integer) return final_status is Final : final_status; procedure On_Item (Str : byte_sequence); procedure On_Item (Str : byte_sequence) is begin if Str = "restriction" then Final (final_restriction) := True; elsif Str = "extension" then Final (final_extension) := True; elsif Str = "#all" then Final := (others => True); elsif Str = "union" then Final (final_union) := True; elsif Str = "list" then Final (final_list) := True; else Validation_Error (Handler, "Invalid value for final: """ & Str & """"); end if; end On_Item; procedure For_Each is new For_Each_Item (On_Item); begin Final := (others => False); if Index /= -1 then For_Each (Get (Get_Value (Atts, Index)).all); if Debug then Output_Action ("Set_Final (" & To_String (Final) & ")"); end if; end if; return Final; end Compute_Final; ------------------ -- Prepare_Type -- ------------------ procedure Prepare_Type (Handler : access schema_reader'class; Atts : sax_attribute_list; Is_Simple : Boolean) is Info : internal_type_descr (Is_Simple => Is_Simple); Is_Set : Boolean; Name : qualified_name; Props : type_descr; begin Info.Loc := Handler.Current_Location; Props.Block := Handler.Target_Block_Default; for J in 1 .. Get_Length (Atts) loop Name := Get_Name (Atts, J); if Name.NS = Empty_String then if Name.Local = Handler.Mixed then Props.Mixed := Get_Value_As_Boolean (Atts, J, False); elsif Name.Local = Handler.Name then Props.Name := (NS => Handler.Target_NS, Local => Get_Value (Atts, J)); elsif Name.Local = Handler.Block then Compute_Blocks (Atts, Handler, Props.Block, Is_Set, J); elsif Name.Local = Handler.Final then Props.Final := Compute_Final (Atts, Handler, J); elsif Name.Local = Handler.S_Abstract then Props.Is_Abstract := Get_Value_As_Boolean (Atts, J, False); end if; end if; end loop; -- block="substitution" does not apply to types, only to elements Props.Block (block_substitution) := False; Info.Properties := Props; Append (Handler.Shared.Types, Info); Push_Context (Handler, (Typ => context_type_def, Type_Info => Last (Handler.Shared.Types))); end Prepare_Type; ------------------------- -- Create_Complex_Type -- ------------------------- procedure Create_Complex_Type (Handler : access schema_reader'class; Atts : sax_attribute_list) is begin Prepare_Type (Handler, Atts, Is_Simple => False); end Create_Complex_Type; ------------------------- -- Finish_Complex_Type -- ------------------------- procedure Finish_Complex_Type (Handler : access schema_reader'class) is Ctx : constant context_access := Handler.Contexts (Handler.Contexts_Last)'access; Next : constant context_access := Handler.Contexts (Handler.Contexts_Last - 1)'access; begin case Next.Typ is when context_element => Next.Element.Local_Type := Ctx.Type_Info; when others => null; end case; end Finish_Complex_Type; ------------------------ -- Create_Restriction -- ------------------------ procedure Create_Restriction (Handler : access schema_reader'class; Atts : sax_attribute_list) is Ctx : constant context_access := Handler.Contexts (Handler.Contexts_Last)'access; Restr : restriction_descr; Details : type_details_access; Name : qualified_name; In_Type : constant internal_type_index := Ctx.Type_Info; begin Restr.Loc := Handler.Current_Location; Restr.Base := (NS => Handler.XML_Schema_URI, Local => Handler.Any_Simple_Type); for J in 1 .. Get_Length (Atts) loop Name := Get_Name (Atts, J); if Name.NS = Empty_String then if Name.Local = Handler.Base then Restr.Base := Resolve_QName (Handler, Get_Value (Atts, J), Handler.Target_NS, Get_Location (Atts, J)); end if; end if; end loop; if Handler.Shared.Types.Table (In_Type).Is_Simple or else Handler.Shared.Types.Table (In_Type).Simple.Kind /= simple_type_none then if Restr.Base = (NS => Handler.XML_Schema_URI, Local => Handler.IDREF) or else Restr.Base = (NS => Handler.XML_Schema_URI, Local => Handler.IDREFS) then Validation_Error (Handler, "Unsupported type IDREF and IDREFS", Except => XML_Not_Implemented'identity); end if; if not Handler.Shared.Types.Table (In_Type).Is_Simple then Details := new type_details' (Kind => type_restriction, Min_Occurs => (False, 1), Max_Occurs => (False, 1), Loc => Handler.Current_Location, In_Process => False, Next => null, Simple_Content_Restriction => True, Restriction => Restr); Insert_In_Type (Handler, Details); end if; Push_Context (Handler, (Typ => context_simple_restriction, Simple => (Kind => simple_type_restriction, In_Process => False, Facets => No_Facets, Base => (Name => Restr.Base, Local => No_Internal_Type_Index), Loc => Handler.Current_Location))); else Details := new type_details' (Kind => type_restriction, Min_Occurs => (False, 1), Max_Occurs => (False, 1), Loc => Handler.Current_Location, In_Process => False, Next => null, Simple_Content_Restriction => False, Restriction => Restr); Insert_In_Type (Handler, Details); Push_Context (Handler, (Typ => context_restriction, Restriction => Details)); end if; end Create_Restriction; ------------------------ -- Finish_Restriction -- ------------------------ procedure Finish_Restriction (Handler : access schema_reader'class) is Ctx : constant context_access := Handler.Contexts (Handler.Contexts_Last)'access; Next : constant context_access := Handler.Contexts (Handler.Contexts_Last - 1)'access; begin if Ctx.Typ = context_simple_restriction then pragma assert (Next.Typ = context_type_def); Handler.Shared.Types.Table (Next.Type_Info).Simple := Ctx.Simple; end if; end Finish_Restriction; ------------------ -- Create_Union -- ------------------ procedure Create_Union (Handler : access schema_reader'class; Atts : sax_attribute_list) is Name : qualified_name; procedure Add_Union (Str : byte_sequence); -- Add a unioned type to [Simple] procedure Add_Union (Str : byte_sequence) is Sym : constant symbol := Find_Symbol (Handler.all, Str); Ctx : constant context_access := Handler.Contexts (Handler.Contexts_Last)'access; Name : constant qualified_name := Resolve_QName (Handler, Sym, Handler.Target_NS, Loc => Ctx.Union.Loc); begin Add_Type_Member (Handler, Ctx.Union.Union_Items, (Name => Name, Local => No_Internal_Type_Index), Ctx.Union.Loc); end Add_Union; procedure For_Each_Union is new For_Each_Item (Add_Union); begin Push_Context (Handler, (Typ => context_union, Union => (Kind => simple_type_union, In_Process => False, Loc => Handler.Current_Location, Union_Items => (others => No_Type_Member)))); for J in 1 .. Get_Length (Atts) loop Name := Get_Name (Atts, J); if Name.NS = Empty_String then if Name.Local = Handler.Member_Types then For_Each_Union (Get (Get_Value (Atts, J)).all); end if; end if; end loop; end Create_Union; ------------------ -- Finish_Union -- ------------------ procedure Finish_Union (Handler : access schema_reader'class) is Ctx : constant context_access := Handler.Contexts (Handler.Contexts_Last)'access; Next : constant context_access := Handler.Contexts (Handler.Contexts_Last - 1)'access; begin case Next.Typ is when context_type_def => Handler.Shared.Types.Table (Next.Type_Info).Simple := Ctx.Union; when others => Validation_Error (Handler, "Unsupported: ""union"" in this context", Except => XML_Not_Implemented'identity); end case; end Finish_Union; ---------------------- -- Create_Extension -- ---------------------- procedure Create_Extension (Handler : access schema_reader'class; Atts : sax_attribute_list) is Ctx : constant context_access := Handler.Contexts (Handler.Contexts_Last)'access; Ext : extension_descr; Name : qualified_name; Details : type_details_access; In_Type : constant internal_type_index := Ctx.Type_Info; begin Ext.Loc := Handler.Current_Location; for J in 1 .. Get_Length (Atts) loop Name := Get_Name (Atts, J); if Name.NS = Empty_String then if Name.Local = Handler.Base then Ext.Base := Resolve_QName (Handler, Get_Value (Atts, J), Handler.Target_NS, Loc => Get_Location (Atts, J)); end if; end if; end loop; if Ext.Base = No_Qualified_Name then Validation_Error (Handler, "Attribute ""base"" required for "); end if; if Handler.Shared.Types.Table (In_Type).Is_Simple or else Handler.Shared.Types.Table (In_Type).Simple.Kind /= simple_type_none then if Debug then Debug_Output ("Create extension: in simpleContent or simpleType"); end if; if not Handler.Shared.Types.Table (In_Type).Is_Simple then Details := new type_details' (Kind => type_extension, Min_Occurs => (False, 1), Max_Occurs => (False, 1), Loc => Handler.Current_Location, In_Process => False, Next => null, Simple_Content => True, Extension => Ext); Insert_In_Type (Handler, Details); end if; Push_Context (Handler, (Typ => context_simple_extension, Simple => (Kind => simple_type_extension, In_Process => False, Base => (Name => Ext.Base, Local => No_Internal_Type_Index), Facets => No_Facets, Loc => Handler.Current_Location))); else Details := new type_details' (Kind => type_extension, Min_Occurs => (False, 1), Max_Occurs => (False, 1), Loc => Handler.Current_Location, In_Process => False, Next => null, Simple_Content => False, Extension => Ext); Insert_In_Type (Handler, Details); Push_Context (Handler, (Typ => context_extension, Extension => Details)); end if; end Create_Extension; ---------------------- -- Finish_Extension -- ---------------------- procedure Finish_Extension (Handler : access schema_reader'class) is Ctx : constant context_access := Handler.Contexts (Handler.Contexts_Last)'access; Next : constant context_access := Handler.Contexts (Handler.Contexts_Last - 1)'access; begin if Ctx.Typ = context_simple_extension then pragma assert (Next.Typ = context_type_def); -- a simple type Handler.Shared.Types.Table (Next.Type_Info).Simple := Ctx.Simple; end if; end Finish_Extension; ----------------- -- Create_List -- ----------------- procedure Create_List (Handler : access schema_reader'class; Atts : sax_attribute_list) is Name : qualified_name; begin Push_Context (Handler, (Typ => context_list, List => (Kind => simple_type_list, In_Process => False, Loc => Handler.Current_Location, List_Items => (others => No_Type_Member)))); for J in 1 .. Get_Length (Atts) loop Name := Get_Name (Atts, J); if Name.NS = Empty_String then if Name.Local = Handler.Item_Type then Name := Resolve_QName (Handler, Get_Value (Atts, J), Handler.Target_NS, Loc => Get_Location (Atts, J)); Add_Type_Member (Handler, Handler.Contexts (Handler.Contexts_Last).List.List_Items, (Name => Name, Local => No_Internal_Type_Index), Handler.Current_Location); end if; end if; end loop; end Create_List; ----------------- -- Finish_List -- ----------------- procedure Finish_List (Handler : access schema_reader'class) is Ctx : constant context_access := Handler.Contexts (Handler.Contexts_Last)'access; Next : constant context_access := Handler.Contexts (Handler.Contexts_Last - 1)'access; Next_Next : constant context_access := Handler.Contexts (Handler.Contexts_Last - 2)'access; begin case Next.Typ is when context_type_def => if Next.Type_Info = No_Internal_Type_Index then -- within a pragma assert (Next_Next.Typ = context_simple_restriction); Next_Next.Simple := Ctx.List; else -- within a pragma assert (Next.Type_Info /= No_Internal_Type_Index); Handler.Shared.Types.Table (Next.Type_Info).Simple := Ctx.List; end if; when others => Validation_Error (Handler, "Unsupported: ""list"" in this context", Except => XML_Not_Implemented'identity); end case; end Finish_List; -------------------- -- Insert_In_Type -- -------------------- procedure Insert_In_Type (Handler : access schema_reader'class; Element : in out type_details_access) is procedure Append (List : in out type_details_access; Elem : type_details_access); procedure Append (List : in out type_details_access; Elem : type_details_access) is Tmp : type_details_access; begin if List = null then List := Elem; else Tmp := List; while Tmp.Next /= null loop Tmp := Tmp.Next; end loop; Tmp.Next := Elem; end if; end Append; Ctx : constant context_access := Handler.Contexts (Handler.Contexts_Last)'access; begin case Ctx.Typ is when context_type_def => if Handler.Shared.Types.Table (Ctx.Type_Info).Is_Simple then Free (Element); Validation_Error (Handler, "Invalid element in simple type"); end if; if Debug and then Handler.Shared.Types.Table (Ctx.Type_Info).Details /= null then Debug_Output ("Insert_In_Type, type already has details " & " when inserting " & Element.Kind'img); end if; pragma assert (Handler.Shared.Types.Table (Ctx.Type_Info).Details = null); Handler.Shared.Types.Table (Ctx.Type_Info).Details := Element; when context_sequence => Append (Ctx.Seq.First_In_Seq, Element); when context_choice => Append (Ctx.Choice.First_In_Choice, Element); when context_all => Append (Ctx.All_Detail.First_In_All, Element); when context_group => if Ctx.Group.Details /= null then Free (Element); Validation_Error (Handler, "Invalid element in non group"); end if; Ctx.Group.Details := Element; when context_extension => if Ctx.Extension.Extension.Details /= null then Free (Element); Validation_Error (Handler, "Invalid element in non-empty extension"); end if; Ctx.Extension.Extension.Details := Element; when context_restriction => if Ctx.Restriction.Restriction.Details /= null then Free (Element); Validation_Error (Handler, "Invalid element in non-empty restriction"); end if; Ctx.Restriction.Restriction.Details := Element; when context_simple_restriction | context_simple_extension => Free (Element); when context_schema | context_attribute | context_element | context_union | context_list | context_redefine | context_attribute_group => Free (Element); Validation_Error (Handler, "Unsupported: """ & Element.Kind'img & """ in context " & Ctx.Typ'img, Except => XML_Not_Implemented'identity); end case; end Insert_In_Type; ------------------- -- Create_Choice -- ------------------- procedure Create_Choice (Handler : access schema_reader'class; Atts : sax_attribute_list) is Min_Occurs, Max_Occurs : occurrences := (False, 1); Choice : type_details_access; begin Get_Occurs (Handler, Atts, Min_Occurs, Max_Occurs); Choice := new type_details' (Kind => type_choice, Min_Occurs => Min_Occurs, Max_Occurs => Max_Occurs, Loc => Handler.Current_Location, In_Process => False, Next => null, First_In_Choice => null); Insert_In_Type (Handler, Choice); Push_Context (Handler, (Typ => context_choice, Choice => Choice)); end Create_Choice; --------------------- -- Create_Sequence -- --------------------- procedure Create_Sequence (Handler : access schema_reader'class; Atts : sax_attribute_list) is Min_Occurs, Max_Occurs : occurrences := (False, 1); Seq : type_details_access; begin Get_Occurs (Handler, Atts, Min_Occurs, Max_Occurs); Seq := new type_details' (Kind => type_sequence, Min_Occurs => Min_Occurs, Max_Occurs => Max_Occurs, Loc => Handler.Current_Location, In_Process => False, Next => null, First_In_Seq => null); Insert_In_Type (Handler, Seq); Push_Context (Handler, (Typ => context_sequence, Seq => Seq)); end Create_Sequence; ---------------------- -- Create_Attribute -- ---------------------- procedure Create_Attribute (Handler : access schema_reader'class; Atts : sax_attribute_list) is Name : qualified_name; Att : attr_descr (Kind => kind_attribute); Ctx : constant context_access := Handler.Contexts (Handler.Contexts_Last)'access; Has_Form : Boolean := False; begin Att.Attr.Descr.Form := Handler.Attribute_Form_Default; Att.Loc := Handler.Current_Location; for J in 1 .. Get_Length (Atts) loop Name := Get_Name (Atts, J); if Name.NS = Empty_String then if Name.Local = Handler.Name then Att.Attr.Descr.Name := (NS => Handler.Target_NS, Local => Get_Value (Atts, J)); elsif Name.Local = Handler.Typ then Att.Attr.Typ := Resolve_QName (Handler, Get_Value (Atts, J), Loc => Get_Location (Atts, J)); if Att.Attr.Typ = (NS => Handler.XML_Schema_URI, Local => Handler.IDREF) or else Att.Attr.Typ = (NS => Handler.XML_Schema_URI, Local => Handler.IDREFS) then Validation_Error (Handler, "Unsupported type IDREF and IDREFS", Get_Location (Atts, J), Except => XML_Not_Implemented'identity); end if; elsif Name.Local = Handler.S_Use then if Get_Value (Atts, J) = Handler.Required then Att.Attr.Descr.Use_Type := required; elsif Get_Value (Atts, J) = Handler.Prohibited then Att.Attr.Descr.Use_Type := prohibited; else Att.Attr.Descr.Use_Type := optional; end if; elsif Name.Local = Handler.Fixed then Att.Attr.Descr.Fixed := Get_Value (Atts, J); elsif Name.Local = Handler.Ref then Att.Attr.Ref := Resolve_QName (Handler, Get_Value (Atts, J), Handler.Target_NS, Loc => Get_Location (Atts, J)); elsif Name.Local = Handler.Form then Att.Attr.Descr.Form := form_type'value (Get (Get_Value (Atts, J)).all); Has_Form := True; elsif Name.Local = Handler.Default then Att.Attr.Descr.Default := Get_Value (Atts, J); elsif Name.Local = Handler.Namespace_Target then Att.Attr.Descr.Target_NS := Get_Value (Atts, J); end if; end if; end loop; -- See section 3.2.3 for valid attributes combination if Att.Attr.Descr.Target_NS /= No_Symbol then if Att.Attr.Descr.Name /= No_Qualified_Name then Validation_Error (Handler, "name must be specified when targetNamespace is specified"); end if; if Has_Form then Validation_Error (Handler, "Cannot specify ""form"" when targetNamespace is given"); end if; Validation_Error (Handler, "targetNamespace not supported in attribute declaration", Except => XML_Not_Implemented'identity); end if; if Has_Form and then Att.Attr.Ref /= No_Qualified_Name then Validation_Error (Handler, "Attributes ""form"" and ""ref"" cannot be both specified"); end if; if Att.Attr.Typ /= No_Qualified_Name then if Att.Attr.Ref /= No_Qualified_Name then Validation_Error (Handler, "Attributes ""type"" and ""ref"" cannot be both specified"); end if; end if; if Att.Attr.Descr.Fixed /= No_Symbol and then Att.Attr.Descr.Default /= No_Symbol then Validation_Error (Handler, "Attributes ""fixed"" and ""default"" cannot be both specified"); end if; if Att.Attr.Descr.Default /= No_Symbol and then Att.Attr.Descr.Use_Type /= optional then Validation_Error (Handler, "Use must be ""optional"" when a default value is specified"); end if; if Get_XSD_Version (Handler.Grammar) = xsd_1_1 and then Att.Attr.Descr.Fixed /= No_Symbol and then Att.Attr.Descr.Use_Type = prohibited then Validation_Error (Handler, """prohibited"" is forbidden when" & " a fixed value is specified"); end if; if Att.Attr.Descr.Name /= No_Qualified_Name then case Ctx.Typ is when context_attribute_group | context_type_def => null; when others => if Handler.Target_NS = Handler.XML_Instance_URI then Validation_Error (Handler, "Invalid target namespace for attribute declaration: """ & Get (Handler.Target_NS).all & """"); end if; end case; end if; Att.Attr.Descr.Is_Local := Att.Attr.Ref = No_Qualified_Name; Push_Context (Handler, (Typ => context_attribute, Attribute => Att)); end Create_Attribute; ---------------------- -- Insert_Attribute -- ---------------------- procedure Insert_Attribute (Handler : access schema_reader'class; In_Context : Natural; Attribute : attr_descr) is Ctx : context renames Handler.Contexts (In_Context); Index : Natural; Ctx2 : context_access; begin case Ctx.Typ is when context_type_def => Append (Handler.Shared.Types.Table (Ctx.Type_Info).Attributes, Attribute); when context_schema | context_redefine => Set (Handler.Shared.Global_Attributes, Attribute.Attr.Descr.Name, Attribute.Attr); when context_extension | context_restriction => Index := Handler.Contexts_Last; while Index >= Handler.Contexts'first loop Ctx2 := Handler.Contexts (Index)'access; if Ctx2.Typ = context_type_def then Append (Handler.Shared.Types.Table (Ctx2.Type_Info).Attributes, Attribute); exit; end if; Index := Index - 1; end loop; when context_simple_extension | context_simple_restriction => pragma assert (Handler.Contexts (In_Context - 1).Typ = context_type_def); pragma assert -- a cannot have attributes (not Handler.Shared.Types.Table (Handler.Contexts (In_Context - 1).Type_Info) .Is_Simple); Append (Handler.Shared.Types.Table (Handler.Contexts (In_Context - 1).Type_Info) .Attributes, Attribute); when context_attribute_group => Append (Ctx.Attr_Group.Attributes, Attribute); when context_element | context_sequence | context_choice | context_attribute | context_all | context_union | context_list | context_group => Validation_Error (Handler, "Unsupported: ""attribute"" in this context", Except => XML_Not_Implemented'identity); end case; end Insert_Attribute; ---------------------- -- Finish_Attribute -- ---------------------- procedure Finish_Attribute (Handler : access schema_reader'class) is Ctx : constant context_access := Handler.Contexts (Handler.Contexts_Last)'access; begin Insert_Attribute (Handler, Handler.Contexts_Last - 1, Ctx.Attribute); end Finish_Attribute; ------------------- -- Create_Schema -- ------------------- procedure Create_Schema (Handler : access schema_reader'class; Atts : sax_attribute_list) is Info : schema_descr; Is_Set : Boolean := False; Name : qualified_name; begin Info.Element_Form_Default := unqualified; Info.Attribute_Form_Default := unqualified; for J in 1 .. Get_Length (Atts) loop Name := Get_Name (Atts, J); if Name.NS = Empty_String then if Name.Local = Handler.S_Element_Form_Default then Info.Element_Form_Default := Compute_Form (Atts, Handler, J); elsif Name.Local = Handler.S_Attribute_Form_Default then Info.Attribute_Form_Default := Compute_Form (Atts, Handler, J); elsif Name.Local = Handler.Block_Default then Compute_Blocks (Atts, Handler, Info.Block, Is_Set, J); elsif Name.Local = Handler.Namespace_Target then Info.Target_NS := Get_Value (Atts, J); end if; elsif Name.NS = Handler.XML_Instance_URI then if Name.Local = Handler.No_Namespace_Schema_Location then -- Already handled through Hook_Start_Element when validating -- the grammar itself, but needed if we do not validate the -- grammar Parse_Grammar (Handler, URI => Empty_String, Xsd_File => Get_Value (Atts, J), Do_Create_NFA => False); elsif Name.Local = Handler.Schema_Location then -- Already handled through Hook_Start_Element when validating -- the grammar itself Parse_Grammars (Handler, Get_Value (Atts, J), Do_Create_NFA => False); end if; end if; end loop; if Info.Target_NS /= No_Symbol then if Debug then Output_Action ("Get_NS (Handler.Created_Grammar, """ & Get (Info.Target_NS).all & """, Handler.Target_NS)"); end if; Handler.Target_NS := Info.Target_NS; end if; Handler.Element_Form_Default := Info.Element_Form_Default; Handler.Attribute_Form_Default := Info.Attribute_Form_Default; if Is_Set then Handler.Target_Block_Default := Info.Block; end if; Push_Context (Handler, (Typ => context_schema)); end Create_Schema; -------------------------------- -- Process_Contents_From_Atts -- -------------------------------- function Process_Contents_From_Atts (Handler : access schema_reader'class; Atts : sax_attribute_list; Index : Integer) return process_contents_type is begin if Get_Value (Atts, Index) = Handler.Lax then return process_lax; elsif Get_Value (Atts, Index) = Handler.Strict then return process_strict; else return process_skip; end if; end Process_Contents_From_Atts; ---------------- -- Create_Any -- ---------------- procedure Create_Any (Handler : access schema_reader'class; Atts : sax_attribute_list) is Details : type_details_access; Any : internal_any_descr; Name : qualified_name; Min_Occurs, Max_Occurs : occurrences := (False, 1); begin Any.Target_NS := Handler.Target_NS; Any.Namespaces := Handler.Any_Namespace; for J in 1 .. Get_Length (Atts) loop Name := Get_Name (Atts, J); if Name.NS = Empty_String then if Name.Local = Handler.Namespace then Any.Namespaces := Get_Value (Atts, J); elsif Name.Local = Handler.Process_Contents then Any.Process_Contents := Process_Contents_From_Atts (Handler, Atts, J); end if; end if; end loop; Get_Occurs (Handler, Atts, Min_Occurs, Max_Occurs); Details := new type_details' (Kind => type_any, Min_Occurs => Min_Occurs, Max_Occurs => Max_Occurs, Loc => Handler.Current_Location, In_Process => False, Next => null, Any => Any); Insert_In_Type (Handler, Details); end Create_Any; ---------------- -- Create_All -- ---------------- procedure Create_All (Handler : access schema_reader'class; Atts : sax_attribute_list) is Min_Occurs, Max_Occurs : occurrences := (False, 1); Details : type_details_access; begin Get_Occurs (Handler, Atts, Min_Occurs, Max_Occurs); Details := new type_details' (Kind => type_all, Min_Occurs => Min_Occurs, Max_Occurs => Max_Occurs, Loc => Handler.Current_Location, In_Process => False, Next => null, First_In_All => null); Insert_In_Type (Handler, Details); Push_Context (Handler, (Typ => context_all, All_Detail => Details)); end Create_All; ------------------- -- Start_Element -- ------------------- overriding procedure Start_Element (Handler : in out schema_reader; NS : Sax.Utils.xml_ns; Local_Name : Sax.Symbols.symbol; Atts : Sax.Readers.sax_attribute_list) is H : constant schema_reader_access := Handler'unchecked_access; Ctx : context_access; begin if Debug then Output_Seen ("Start " & Get (Local_Name).all & " at " & To_String (Handler.Current_Location)); end if; -- Check the grammar Start_Element (validating_reader (Handler), NS, Local_Name, Atts); -- Process the element if Handler.Contexts = null then if Local_Name /= Handler.S_Schema then Validation_Error (H, "Root element must be "); end if; Create_Schema (H, Atts); elsif Local_Name = Handler.Annotation then Handler.In_Annotation := True; elsif Local_Name = Handler.Notation then Create_Notation (H, Atts); elsif Local_Name = Handler.Element then Create_Element (H, Atts); elsif Local_Name = Handler.Complex_Type then Create_Complex_Type (H, Atts); elsif Local_Name = Handler.Simple_Type then Create_Simple_Type (H, Atts); elsif Local_Name = Handler.Restriction then Create_Restriction (H, Atts); elsif Local_Name = Handler.Extension then Create_Extension (H, Atts); elsif Local_Name = Handler.Any_Attribute then Create_Any_Attribute (H, Atts); elsif Local_Name = Handler.Pattern then Ctx := Handler.Contexts (Handler.Contexts_Last)'access; pragma assert (Ctx.Typ = context_simple_restriction); pragma assert (Ctx.Simple.Kind = simple_type_restriction); -- Use the non-normalized value for Add_Facet (Grammar => Handler.Grammar, Facets => Ctx.Simple.Facets, Facet_Name => Local_Name, Value => Get_Non_Normalized_Value (Atts, Get_Index (Atts, Empty_String, Handler.Value)), Loc => Handler.Current_Location); elsif Local_Name = Handler.Maxlength or else Local_Name = Handler.Minlength or else Local_Name = Handler.Length or else Local_Name = Handler.Enumeration or else Local_Name = Handler.Whitespace or else Local_Name = Handler.Total_Digits or else Local_Name = Handler.Fraction_Digits or else Local_Name = Handler.MaxInclusive or else Local_Name = Handler.MaxExclusive or else Local_Name = Handler.MinInclusive or else Local_Name = Handler.MinExclusive then Ctx := Handler.Contexts (Handler.Contexts_Last)'access; pragma assert (Ctx.Typ = context_simple_restriction); pragma assert (Ctx.Simple.Kind = simple_type_restriction); Add_Facet (Grammar => Handler.Grammar, Facets => Ctx.Simple.Facets, Facet_Name => Local_Name, Value => Get_Value (Atts, Get_Index (Atts, Empty_String, Handler.Value)), Loc => Handler.Current_Location); elsif Local_Name = Handler.S_All then Create_All (H, Atts); elsif Local_Name = Handler.Sequence then Create_Sequence (H, Atts); elsif Local_Name = Handler.Choice then Create_Choice (H, Atts); elsif Local_Name = Handler.List then Create_List (H, Atts); elsif Local_Name = Handler.Union then Create_Union (H, Atts); elsif Local_Name = Handler.Attribute then Create_Attribute (H, Atts); elsif Local_Name = Handler.Group then Create_Group (H, Atts); elsif Local_Name = Handler.Simple_Content then Ctx := Handler.Contexts (Handler.Contexts_Last)'access; pragma assert (Ctx.Typ = context_type_def); Handler.Shared.Types.Table (Ctx.Type_Info).Simple := (Kind => simple_type, In_Process => False, Loc => Handler.Current_Location); Handler.Shared.Types.Table (Ctx.Type_Info).Properties.Mixed := True; elsif Local_Name = Handler.Complex_Content then Ctx := Handler.Contexts (Handler.Contexts_Last)'access; pragma assert (Ctx.Typ = context_type_def); -- Do not reset Properties.Mixed here, since it might have been set -- to "true" on the parent node. elsif Local_Name = Handler.Attribute_Group then Create_Attribute_Group (H, Atts); elsif Local_Name = Handler.Any then Create_Any (H, Atts); elsif Local_Name = Handler.Redefine then Validation_Error (Handler'access, "Unsupported ", Except => XML_Not_Implemented'identity); Create_Redefine (H, Atts); elsif Local_Name = Handler.Include then Create_Include (H, Atts); elsif Local_Name = Handler.Import then Create_Import (H, Atts); elsif Handler.In_Annotation then null; -- ignore all tags elsif Handler.Feature_Ignore_Unsupported_XSD_Elements and then (Local_Name = Handler.Keyref or else Local_Name = Handler.Key or else Local_Name = Handler.Selector or else Local_Name = Handler.Unique or else Local_Name = Handler.Field) then Warning (Handler, Create (Message => "Unsupported element in the schema: " & Get (Local_Name).all, Loc => Handler.Current_Location)); else Validation_Error (Handler'access, "Unsupported element in the schema: " & Get (Local_Name).all, Except => XML_Not_Implemented'identity); end if; end Start_Element; ----------------- -- End_Element -- ----------------- overriding procedure End_Element (Handler : in out schema_reader; NS : Sax.Utils.xml_ns; Local_Name : Sax.Symbols.symbol) is H : constant schema_reader_access := Handler'unchecked_access; Handled : Boolean := True; begin -- Check the grammar End_Element (validating_reader (Handler), NS, Local_Name); -- Process the tag if Local_Name = Handler.Element then Finish_Element (H); elsif Local_Name = Handler.S_Schema then null; elsif Local_Name = Handler.Complex_Type then Finish_Complex_Type (H); elsif Local_Name = Handler.Simple_Type then Finish_Simple_Type (H); elsif Local_Name = Handler.S_All then null; elsif Local_Name = Handler.Sequence then null; elsif Local_Name = Handler.Any_Attribute then Handled := False; elsif Local_Name = Handler.Choice then null; elsif Local_Name = Handler.Restriction then Finish_Restriction (H); elsif Local_Name = Handler.Extension then Finish_Extension (H); elsif Local_Name = Handler.Attribute then Finish_Attribute (H); elsif Local_Name = Handler.Union then Finish_Union (H); elsif Local_Name = Handler.List then Finish_List (H); elsif Local_Name = Handler.Maxlength or else Local_Name = Handler.Pattern or else Local_Name = Handler.Minlength or else Local_Name = Handler.Enumeration or else Local_Name = Handler.Whitespace or else Local_Name = Handler.Total_Digits or else Local_Name = Handler.Fraction_Digits or else Local_Name = Handler.MaxInclusive or else Local_Name = Handler.MaxExclusive or else Local_Name = Handler.MinInclusive or else Local_Name = Handler.MinExclusive then Handled := False; elsif Local_Name = Handler.Attribute_Group then Finish_Attribute_Group (H); elsif Local_Name = Handler.Redefine then null; elsif Local_Name = Handler.Group then Finish_Group (H); elsif Local_Name = Handler.Any or else Local_Name = Handler.Include or else Local_Name = Handler.Import or else Local_Name = Handler.Simple_Content or else Local_Name = Handler.Complex_Content then Handled := False; elsif Local_Name = Handler.Annotation then Handler.In_Annotation := False; Handled := False; else if Debug then Output_Action ("Close tag not handled yet: " & Get (Local_Name).all); end if; Handled := False; end if; -- Release the context if Handled then Handler.Contexts_Last := Handler.Contexts_Last - 1; end if; end End_Element; ---------------- -- Characters -- ---------------- procedure Characters (Handler : in out schema_reader; Ch : Unicode.CES.byte_sequence) is begin Characters (validating_reader (Handler), Ch); end Characters; ---------- -- Free -- ---------- procedure Free (Self : in out type_details_access) is procedure Unchecked_Free is new Ada.Unchecked_Deallocation (type_details, type_details_access); Next : type_details_access; begin while Self /= null loop Next := Self.Next; case Self.Kind is when type_empty | type_element | type_any => null; when type_sequence => Free (Self.First_In_Seq); when type_choice => Free (Self.First_In_Choice); when type_all => Free (Self.First_In_All); when type_group => Free (Self.Group.Details); when type_extension => Free (Self.Extension.Details); when type_restriction => Free (Self.Restriction.Details); end case; Unchecked_Free (Self); Self := Next; end loop; end Free; ----------------- -- Set_Feature -- ----------------- overriding procedure Set_Feature (Parser : in out schema_reader; Name : String; Value : Boolean) is begin if Name = Feature_Ignore_Unsupported_XSD_Elements then Parser.Feature_Ignore_Unsupported_XSD_Elements := Value; else Set_Feature (validating_reader (Parser), Name, Value); end if; end Set_Feature; ----------------- -- Get_Feature -- ----------------- overriding function Get_Feature (Parser : schema_reader; Name : String) return Boolean is begin if Name = Feature_Ignore_Unsupported_XSD_Elements then return Parser.Feature_Ignore_Unsupported_XSD_Elements; else return Get_Feature (validating_reader (Parser), Name); end if; end Get_Feature; end Schema.Schema_Readers;