with Unicode; use Unicode; with Unicode.CES; use Unicode.CES; with Sax.Attributes; use Sax.Attributes; with Sax.Encodings; use Sax.Encodings; with Sax.Readers; with Sax.Utils; use Sax.Utils; with Schema.Validators; use Schema.Validators; with Schema.Readers; use Schema.Readers; with Schema.Schema_Grammar; use Schema.Schema_Grammar; with GNAT.IO; use GNAT.IO; with Ada.Unchecked_Deallocation; package body Schema.Schema_Readers is Debug : Boolean := False; procedure Free (C : in out Context_Access); -- Free the memory occupied by C procedure Get_Grammar_For_Namespace (Handler : in out Schema_Reader'Class; Prefix : Byte_Sequence; Grammar : out XML_Grammar_NS); -- Return the grammar matching a given prefix procedure Output (Str : String); -- Output a debug string procedure Lookup_With_NS (Handler : in out Schema_Reader'Class; QName : Byte_Sequence; Result : out XML_Type); procedure Lookup_With_NS (Handler : in out Schema_Reader'Class; QName : Byte_Sequence; Result : out XML_Element); procedure Lookup_With_NS (Handler : in out Schema_Reader'Class; QName : Byte_Sequence; Result : out XML_Group); -- Lookup a type or element with a possible namespace specification function Create_Repeat (Validator : access XML_Validator_Record'Class; Min_Occurs, Max_Occurs : Integer) return XML_Validator; -- Repeat Validator a number of times, by including it in a sequence if -- needed procedure Ensure_Type (Handler : in out Schema_Reader; C : Context_Access); -- Make sure the context (of type Context_Type_Def) has a proper -- type validator defined function Ada_Name (Element : XML_Element) return String; function Ada_Name (Typ : XML_Type) return String; function Ada_Name (C : Context_Access) return String; -- Return the name of an Ada variable suitable to represent Element function XML_To_Ada (Str : Byte_Sequence) return Byte_Sequence; -- Return a string suitable as an Ada identifier function In_Redefine_Context (Handler : Schema_Reader) return Boolean; -- Whether we are currently processing a tag procedure Insert_Attribute (Handler : in out Schema_Reader; In_Context : Context_Access; Attribute : Attribute_Validator; Attribute_Name : Byte_Sequence); -- Insert attribute at the right location in In_Context. -- Attribute_Name is only for debugging purposes function Process_Contents_From_Atts (Atts : Sax.Attributes.Attributes'Class) return Process_Contents_Type; -- Get the value of processContents from the attributes procedure Create_Element (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class); procedure Create_Complex_Type (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class); procedure Create_Simple_Type (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class); procedure Create_Restriction (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class); procedure Create_All (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class); procedure Create_Sequence (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class); procedure Create_Attribute (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class); procedure Create_Schema (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class); procedure Create_Extension (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class); procedure Create_List (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class); procedure Create_Union (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class); procedure Create_Choice (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class); procedure Create_Redefine (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class); procedure Create_Include (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class); procedure Create_Group (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class); procedure Create_Attribute_Group (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class); procedure Create_Any (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class); procedure Create_Import (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class); procedure Create_Any_Attribute (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class); -- Create a new context for a specific tag: -- resp. , , , , , -- , , , , , , -- , , , , , procedure Finish_Element (Handler : in out Schema_Reader); procedure Finish_Complex_Type (Handler : in out Schema_Reader); procedure Finish_Simple_Type (Handler : in out Schema_Reader); procedure Finish_Restriction (Handler : in out Schema_Reader); procedure Finish_All (Handler : in out Schema_Reader); procedure Finish_Sequence (Handler : in out Schema_Reader); procedure Finish_Attribute (Handler : in out Schema_Reader); procedure Finish_Extension (Handler : in out Schema_Reader); procedure Finish_Union (Handler : in out Schema_Reader); procedure Finish_List (Handler : in out Schema_Reader); procedure Finish_Choice (Handler : in out Schema_Reader); procedure Finish_Group (Handler : in out Schema_Reader); -- Finish the handling of various tags: -- resp. , , , , , -- , , , , function Max_Occurs_From_Value (Value : Byte_Sequence) return Integer; -- Return the value of maxOccurs from the attributes'value. This properly -- takes into account the "unbounded" case procedure Create_Restricted (Handler : in out Schema_Reader; Ctx : Context_Access); -- Applies to a Context_Restriction, ensures that the restriction has been -- created appropriately. ------------------------- -- In_Redefine_Context -- ------------------------- function In_Redefine_Context (Handler : Schema_Reader) return Boolean is Tmp : Context_Access := Handler.Contexts; begin while Tmp /= null loop if Tmp.Typ = Context_Redefine then return True; end if; Tmp := Tmp.Next; end loop; return False; end In_Redefine_Context; --------------------------- -- Max_Occurs_From_Value -- --------------------------- function Max_Occurs_From_Value (Value : Byte_Sequence) return Integer is begin if Value = "unbounded" then return Unbounded; else return Integer'Value (Value); end if; end Max_Occurs_From_Value; ---------------- -- XML_To_Ada -- ---------------- function XML_To_Ada (Str : Byte_Sequence) return Byte_Sequence is Str2 : Byte_Sequence (Str'Range); begin for S in Str'Range loop if Str (S) = '-' then Str2 (S) := '_'; else Str2 (S) := Str (S); end if; end loop; return Str2; end XML_To_Ada; -------------- -- Ada_Name -- -------------- function Ada_Name (Element : XML_Element) return String is begin return "E_" & XML_To_Ada (Get_Local_Name (Element)); end Ada_Name; -------------- -- Ada_Name -- -------------- function Ada_Name (Typ : XML_Type) return String is begin return "T_" & XML_To_Ada (Get_Local_Name (Typ)); end Ada_Name; ------------------------- -- Get_Created_Grammar -- ------------------------- function Get_Created_Grammar (Reader : Schema_Reader) return Schema.Validators.XML_Grammar is begin return Reader.Created_Grammar; end Get_Created_Grammar; ------------------------- -- Set_Created_Grammar -- ------------------------- procedure Set_Created_Grammar (Reader : in out Schema_Reader; Grammar : Schema.Validators.XML_Grammar) is begin Reader.Created_Grammar := Grammar; Reader.Check_Undefined := False; end Set_Created_Grammar; -------------------- -- Start_Document -- -------------------- procedure Start_Document (Handler : in out Schema_Reader) is begin if Handler.Created_Grammar = No_Grammar then Handler.Created_Grammar := Create_Schema_For_Schema; Handler.Check_Undefined := True; end if; Handler.Target_NS := null; Get_NS (Handler.Created_Grammar, XML_Schema_URI, Handler.Schema_NS); end Start_Document; ------------------ -- End_Document -- ------------------ procedure End_Document (Handler : in out Schema_Reader) is begin if Handler.Check_Undefined then Global_Check (Handler.Created_Grammar); end if; end End_Document; ----------- -- Parse -- ----------- procedure Parse (Parser : in out Schema_Reader; Input : in out Input_Sources.Input_Source'Class) is begin Set_Feature (Parser, Sax.Readers.Schema_Validation_Feature, True); Parse (Validating_Reader (Parser), Input); end Parse; ---------------------- -- Set_Debug_Output -- ---------------------- procedure Set_Debug_Output (Output : Boolean) is begin Debug := Output; end Set_Debug_Output; ------------ -- Output -- ------------ procedure Output (Str : String) is begin if Debug then Put_Line (ASCII.ESC & "[34m" & Str & ASCII.ESC & "[39m"); end if; end Output; -------------------- -- Lookup_With_NS -- -------------------- procedure Lookup_With_NS (Handler : in out Schema_Reader'Class; QName : Byte_Sequence; Result : out XML_Type) is Separator : constant Integer := Split_Qname (QName); G : XML_Grammar_NS; begin Get_Grammar_For_Namespace (Handler, QName (QName'First .. Separator - 1), G); Result := Lookup (G, QName (Separator + 1 .. QName'Last)); Output (Ada_Name (Result) & " := Lookup (G, """ & QName (Separator + 1 .. QName'Last) & """);"); end Lookup_With_NS; -------------------- -- Lookup_With_NS -- -------------------- procedure Lookup_With_NS (Handler : in out Schema_Reader'Class; QName : Byte_Sequence; Result : out XML_Element) is Separator : constant Integer := Split_Qname (QName); G : XML_Grammar_NS; begin Get_Grammar_For_Namespace (Handler, QName (QName'First .. Separator - 1), G); Result := Lookup_Element (G, QName (Separator + 1 .. QName'Last)); Output (Ada_Name (Result) & " := Lookup_Element (G, """ & QName (Separator + 1 .. QName'Last) & """);"); end Lookup_With_NS; -------------------- -- Lookup_With_NS -- -------------------- procedure Lookup_With_NS (Handler : in out Schema_Reader'Class; QName : Byte_Sequence; Result : out XML_Group) is Separator : constant Integer := Split_Qname (QName); G : XML_Grammar_NS; begin Get_Grammar_For_Namespace (Handler, QName (QName'First .. Separator - 1), G); Result := Lookup_Group (G, QName (Separator + 1 .. QName'Last)); Output ("Group := Lookup_Group (G, """ & QName (Separator + 1 .. QName'Last) & """);"); end Lookup_With_NS; ------------------ -- Create_Group -- ------------------ procedure Create_Group (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class) is Name_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "name"); Ref_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "ref"); Min_Occurs_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "minOccurs"); Max_Occurs_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "maxOccurs"); Tmp : Context_Access; Min_Occurs, Max_Occurs : Integer := 1; begin if Min_Occurs_Index /= -1 then Min_Occurs := Integer'Value (Get_Value (Atts, Min_Occurs_Index)); end if; if Max_Occurs_Index /= -1 then Max_Occurs := Max_Occurs_From_Value (Get_Value (Atts, Max_Occurs_Index)); end if; Handler.Contexts := new Context' (Typ => Context_Group, Group => No_XML_Group, Redefined_Group => No_XML_Group, Level => Handler.Contexts.Level + 1, Next => Handler.Contexts); -- Do not use In_Redefine_Context, since this only applies for types -- that are redefined if Handler.Contexts.Next.Typ = Context_Redefine then Handler.Contexts.Redefined_Group := Redefine_Group (Handler.Target_NS, Get_Value (Atts, Name_Index)); Output (Ada_Name (Handler.Contexts) & " := Redefine_Group (Handler.Target_NS, """ & Get_Value (Atts, Name_Index) & """);"); end if; if Name_Index /= -1 then Handler.Contexts.Group := Create_Global_Group (Handler.Target_NS, Get_Value (Atts, Name_Index)); Output (Ada_Name (Handler.Contexts) & " := Create_Global_Group (Handler.Target_NS, """ & Get_Value (Atts, Name_Index) & """);"); elsif Ref_Index /= -1 then if In_Redefine_Context (Handler) then Tmp := Handler.Contexts; while Tmp /= null loop if Tmp.Typ = Context_Group and then Tmp.Next.Typ = Context_Redefine and then Get_Local_Name (Tmp.Group) = Get_Value (Atts, Ref_Index) then Handler.Contexts.Group := Tmp.Redefined_Group; Output (Ada_Name (Handler.Contexts) & " := ;"); exit; end if; Tmp := Tmp.Next; end loop; end if; if Handler.Contexts.Group = No_XML_Group then Lookup_With_NS (Handler, Get_Value (Atts, Ref_Index), Handler.Contexts.Group); Output (Ada_Name (Handler.Contexts) & " := Group;"); end if; end if; case Handler.Contexts.Next.Typ is when Context_Schema | Context_Redefine => null; when Context_Type_Def => Handler.Contexts.Next.Type_Validator := Extension_Of (Lookup (Handler.Schema_NS, "anyType"), Handler.Contexts.Group, Min_Occurs, Max_Occurs); Output ("Validator := Extension_Of (Lookup (Handler.Schema.NS," & """anytype""), " & Ada_Name (Handler.Contexts) & "," & Min_Occurs'Img & "," & Max_Occurs'Img& ");"); when Context_Sequence => Add_Particle (Handler.Contexts.Next.Seq, Handler.Contexts.Group, Min_Occurs, Max_Occurs); Output ("Add_Particle (" & Ada_Name (Handler.Contexts.Next) & ", " & Ada_Name (Handler.Contexts) & Min_Occurs'Img & "," & Max_Occurs'Img& ");"); when Context_Choice => Add_Particle (Handler.Contexts.Next.C, Handler.Contexts.Group, Min_Occurs, Max_Occurs); Output ("Add_Particle (" & Ada_Name (Handler.Contexts.Next) & ", " & Ada_Name (Handler.Contexts) & Min_Occurs'Img & "," & Max_Occurs'Img& ");"); when others => Output ("Can't handle nested group decl"); end case; end Create_Group; ------------------ -- Finish_Group -- ------------------ procedure Finish_Group (Handler : in out Schema_Reader) is pragma Unreferenced (Handler); begin null; end Finish_Group; ---------------------------- -- Create_Attribute_Group -- ---------------------------- procedure Create_Attribute_Group (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class) is Name_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "name"); Ref_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "ref"); In_Redefine : constant Boolean := In_Redefine_Context (Handler); begin Handler.Contexts := new Context' (Typ => Context_Attribute_Group, Attr_Group => Empty_Attribute_Group, Level => Handler.Contexts.Level + 1, Next => Handler.Contexts); if In_Redefine then -- -- -- -- if Handler.Contexts.Next.Typ = Context_Attribute_Group then -- Ignore, this is just to indicate which group we are redefining, -- but this was already taken into account for the enclosing tag return; end if; Handler.Contexts.Attr_Group := Lookup_Attribute_Group (Handler.Target_NS, Get_Value (Atts, Name_Index)); Output (Ada_Name (Handler.Contexts) & " := Lookup_Attribute_Group (Handler.Target_NS, """ & Get_Value (Atts, Name_Index) & """);"); elsif Name_Index /= -1 then Handler.Contexts.Attr_Group := Create_Global_Attribute_Group (Handler.Target_NS, Get_Value (Atts, Name_Index)); Output (Ada_Name (Handler.Contexts) & " := Create_Global_Attribute_Group (Handler.Target_NS, """ & Get_Value (Atts, Name_Index) & """);"); elsif Ref_Index /= -1 then Handler.Contexts.Attr_Group := Lookup_Attribute_Group (Handler.Target_NS, Get_Value (Atts, Ref_Index)); Output (Ada_Name (Handler.Contexts) & " := Lookup_Attribute_Group (Handler.Target_NS, """ & Get_Value (Atts, Ref_Index) & """);"); end if; if not In_Redefine then case Handler.Contexts.Next.Typ is when Context_Schema | Context_Redefine => null; when Context_Type_Def => Ensure_Type (Handler, Handler.Contexts.Next); Add_Attribute_Group (Handler.Contexts.Next.Type_Validator, Handler.Contexts.Attr_Group); Output ("Add_Attribute_Group (" & Ada_Name (Handler.Contexts.Next) & ", " & Ada_Name (Handler.Contexts) & ");"); when Context_Extension => if Handler.Contexts.Next.Extension = null then Handler.Contexts.Next.Extension := Extension_Of (Handler.Contexts.Next.Extension_Base, null); Output (Ada_Name (Handler.Contexts.Next) & " := Extension_Of (" & Ada_Name (Handler.Contexts.Next.Extension_Base) & ", null);"); Handler.Contexts.Next.Extension_Base := No_Type; end if; Add_Attribute_Group (Handler.Contexts.Next.Extension, Handler.Contexts.Attr_Group); Output ("Add_Attribute_Group (" & Ada_Name (Handler.Contexts.Next) & ", " & Ada_Name (Handler.Contexts) & ");"); when others => Output ("Context is " & Handler.Contexts.Next.Typ'Img); Validation_Error ("Can't handle attributeGroup in this context"); end case; end if; end Create_Attribute_Group; -------------------- -- Create_Include -- -------------------- procedure Create_Include (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class) is Schema_Location_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "schemaLocation"); begin Parse_Grammar (Handler, Get_Value (Atts, Schema_Location_Index), Handler.Created_Grammar); end Create_Include; --------------------- -- Create_Redefine -- --------------------- procedure Create_Redefine (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class) is Location_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "schemaLocation"); begin Parse_Grammar (Handler, Get_Value (Atts, Location_Index), Handler.Created_Grammar); Handler.Contexts := new Context' (Typ => Context_Redefine, Level => Handler.Contexts.Level + 1, Next => Handler.Contexts); end Create_Redefine; ------------------- -- Create_Import -- ------------------- procedure Create_Import (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class) is Location_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "schemaLocation"); Location : constant Byte_Sequence := Get_Value (Atts, Location_Index); Absolute : constant Byte_Sequence := To_Absolute_URI (Handler, Location); -- Namespace_Index : constant Integer := -- Get_Index (Atts, URI => "", Local_Name => "namespace"); begin if not URI_Was_Parsed (Handler.Created_Grammar, Absolute) then Set_Parsed_URI (Handler.Created_Grammar, Absolute); Parse_Grammar (Handler, Location, Handler.Created_Grammar); end if; end Create_Import; -------------------------- -- Create_Any_Attribute -- -------------------------- procedure Create_Any_Attribute (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class) is Namespace_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "namespace"); Process_Contents : constant Process_Contents_Type := Process_Contents_From_Atts (Atts); Kind : Namespace_Kind; NS : XML_Grammar_NS := Handler.Target_NS; begin if Namespace_Index = -1 then Kind := Namespace_Any; elsif Get_Value (Atts, Namespace_Index) = "##other" then Kind := Namespace_Other; elsif Get_Value (Atts, Namespace_Index) = "##any" then Kind := Namespace_Any; elsif Get_Value (Atts, Namespace_Index) = "##local" then Kind := Namespace_Local; elsif Get_Value (Atts, Namespace_Index) = "##targetNamespace" then Kind := Namespace_List; else Kind := Namespace_List; Get_NS (Handler.Created_Grammar, Get_Value (Atts, Namespace_Index), NS); end if; Insert_Attribute (Handler, Handler.Contexts, Create_Any_Attribute (Process_Contents, Kind, NS), "Create_Any_Attribute (" & Process_Contents'Img & ", " & Kind'Img & ", """ & Get_Namespace_URI (NS) & """);"); end Create_Any_Attribute; -------------------- -- Create_Element -- -------------------- procedure Create_Element (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class) is -- ??? Could be more efficient by traversing the list of attributes -- only once Type_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "type"); Name_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "name"); Ref_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "ref"); Subst_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "substitutionGroup"); Default_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "default"); Fixed_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "fixed"); Min_Occurs_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "minOccurs"); Max_Occurs_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "maxOccurs"); Abstract_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "abstract"); Nillable_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "nillable"); Final_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "final"); Block_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "block"); Form_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "form"); Min_Occurs, Max_Occurs : Integer := 1; Element : XML_Element; Typ : XML_Type := No_Type; Group : XML_Element; Form : Form_Type; Is_Ref : Boolean; begin if Form_Index /= -1 then if Get_Value (Atts, Form_Index) = "qualified" then Form := Qualified; else Form := Unqualified; end if; else Form := Handler.Element_Form_Default; end if; if Name_Index /= -1 then if Type_Index /= -1 then Lookup_With_NS (Handler, Get_Value (Atts, Type_Index), Result => Typ); end if; case Handler.Contexts.Typ is when Context_Schema | Context_Redefine => Element := Create_Global_Element (Handler.Target_NS, Get_Value (Atts, Name_Index), Form => Form); Is_Ref := False; Output (Ada_Name (Element) & " := Register (Handler.Target_NS, """ & Get_Value (Atts, Name_Index) & """, " & Form'Img & ");"); if Typ /= No_Type then Set_Type (Element, Typ); Output ("Set_Type (" & Ada_Name (Element) & ", " & Ada_Name (Typ) & ");"); end if; when others => Element := Create_Local_Element (Get_Value (Atts, Name_Index), Handler.Target_NS, Typ, Form => Form); Is_Ref := False; Output (Ada_Name (Element) & " := Create_Local_Element (""" & Get_Value (Atts, Name_Index) & """, Handler.Target_NS, " & Ada_Name (Typ) & ", " & Form'Img & ");"); end case; if Ref_Index /= -1 and then Get_Value (Atts, Name_Index) = Get_Value (Atts, Ref_Index) and then not In_Redefine_Context (Handler) then Validation_Error ("""ref"" attribute cannot be self-referencing"); end if; elsif Ref_Index = -1 then Validation_Error ("Either ""name"" or ""ref"" attribute must be present"); else Lookup_With_NS (Handler, Get_Value (Atts, Ref_Index), Result => Element); Is_Ref := True; -- Section 3.3.2, validity constraints 3.3.3 if Type_Index /= -1 then Validation_Error ("""type"" attribute cannot be specified along with ""ref"""); end if; end if; if Subst_Index /= -1 then Lookup_With_NS (Handler, Get_Value (Atts, Subst_Index), Result => Group); Set_Substitution_Group (Element, Group); Output ("Set_Substitution_Group (" & Ada_Name (Element) & ", " & Ada_Name (Group) & ");"); end if; if Default_Index /= -1 then Set_Default (Element, Get_Value (Atts, Default_Index)); Output ("Set_Default (" & Ada_Name (Element) & ", """ & Get_Value (Atts, Default_Index) & """);"); end if; if Fixed_Index /= -1 then Set_Fixed (Element, Get_Value (Atts, Fixed_Index)); Output ("Set_Fixed (" & Ada_Name (Element) & ", """ & Get_Value (Atts, Fixed_Index) & """);"); end if; if Abstract_Index /= -1 then Set_Abstract (Element, Get_Value_As_Boolean (Atts, Abstract_Index)); Output ("Set_Abstract (" & Ada_Name (Element) & ", " & Boolean'Image (Get_Value_As_Boolean (Atts, Abstract_Index)) & ");"); end if; if Nillable_Index /= -1 then Set_Nillable (Element, Get_Value_As_Boolean (Atts, Nillable_Index)); Output ("Set_Nillable (" & Ada_Name (Element) & ", " & Boolean'Image (Get_Value_As_Boolean (Atts, Nillable_Index)) & ");"); end if; if Final_Index /= -1 then declare Final : constant Byte_Sequence := Get_Value (Atts, Final_Index); On_Restriction : constant Boolean := Final = "restriction" or else Final = "#all"; On_Extension : constant Boolean := Final = "extension" or else Final = "#all"; begin Set_Final (Element, On_Restriction => On_Restriction, On_Extension => On_Extension); Output ("Set_Final (" & Ada_Name (Element) & ", " & Boolean'Image (On_Restriction) & ", " & Boolean'Image (On_Extension) & ");"); end; end if; if Block_Index /= -1 then declare Block : constant Byte_Sequence := Get_Value (Atts, Block_Index); On_Restriction : constant Boolean := Block = "restriction" or else Block = "#all"; On_Extension : constant Boolean := Block = "extension" or else Block = "#all"; begin Set_Block (Element, On_Restriction => On_Restriction, On_Extension => On_Extension); Output ("Set_Block (" & Ada_Name (Element) & ", " & Boolean'Image (On_Restriction) & ", " & Boolean'Image (On_Extension) & ");"); end; end if; if Min_Occurs_Index /= -1 then Min_Occurs := Integer'Value (Get_Value (Atts, Min_Occurs_Index)); end if; if Max_Occurs_Index /= -1 then Max_Occurs := Max_Occurs_From_Value (Get_Value (Atts, Max_Occurs_Index)); end if; case Handler.Contexts.Typ is when Context_Schema | Context_Redefine => null; when Context_Sequence => Add_Particle (Handler.Contexts.Seq, Element, Min_Occurs, Max_Occurs); Output ("Add_Particle (" & Ada_Name (Handler.Contexts) & ", " & Ada_Name (Element) & ',' & Min_Occurs'Img & ',' & Max_Occurs'Img & ");"); when Context_Choice => Add_Particle (Handler.Contexts.C, Element, Min_Occurs, Max_Occurs); Output ("Add_Particle (" & Ada_Name (Handler.Contexts) & ", " & Ada_Name (Element) & ',' & Min_Occurs'Img & ',' & Max_Occurs'Img & ");"); when Context_All => Add_Particle (Handler.Contexts.All_Validator, Element, Min_Occurs, Max_Occurs); Output ("Add_Particle (" & Ada_Name (Handler.Contexts) & ", " & Ada_Name (Element) & ',' & Min_Occurs'Img & ',' & Max_Occurs'Img & ");"); when others => Output ("Can't handle nested element decl"); end case; Handler.Contexts := new Context' (Typ => Context_Element, Element => Element, Is_Ref => Is_Ref, Level => Handler.Contexts.Level + 1, Next => Handler.Contexts); end Create_Element; -------------------- -- Finish_Element -- -------------------- procedure Finish_Element (Handler : in out Schema_Reader) is begin if not Handler.Contexts.Is_Ref and then Get_Type (Handler.Contexts.Element) = No_Type then Set_Type (Handler.Contexts.Element, Lookup (Handler.Schema_NS, "ur-Type")); Output ("Set_Type (" & Ada_Name (Handler.Contexts) & ", Lookup (Handler.Schema_NS, ""ur-Type"");"); end if; end Finish_Element; ------------------------ -- Create_Simple_Type -- ------------------------ procedure Create_Simple_Type (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class) is begin if Handler.Contexts.Typ = Context_Restriction and then Handler.Contexts.Restriction_Base = No_Type then Handler.Contexts := new Context' (Typ => Context_Type_Def, Type_Name => null, Type_Validator => null, Redefined_Type => No_Type, Mixed_Content => False, Simple_Content => False, Block_Restriction => False, Block_Extension => False, Level => Handler.Contexts.Level + 1, Next => Handler.Contexts); else Create_Complex_Type (Handler, Atts); end if; end Create_Simple_Type; ------------------------ -- Finish_Simple_Type -- ------------------------ procedure Finish_Simple_Type (Handler : in out Schema_Reader) is C : constant Context_Access := Handler.Contexts; Typ : XML_Type; begin if C.Next.Typ = Context_Restriction and then C.Next.Restriction_Base = No_Type then Ensure_Type (Handler, C); Typ := Create_Local_Type (C.Type_Validator); Output (Ada_Name (C) & " := Create_Local_Type (Validator);"); C.Next.Restriction_Base := Typ; Output ("Setting base type for restriction"); else Handler.Contexts.Mixed_Content := True; Finish_Complex_Type (Handler); end if; end Finish_Simple_Type; ------------------------- -- Create_Complex_Type -- ------------------------- procedure Create_Complex_Type (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class) is Name_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "name"); Mixed_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "mixed"); Block_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "block"); Name : Byte_Sequence_Access; Mixed : Boolean; begin if Name_Index /= -1 then Name := new Byte_Sequence'(Get_Value (Atts, Name_Index)); end if; Mixed := Mixed_Index /= -1 and then Get_Value_As_Boolean (Atts, Mixed_Index); Handler.Contexts := new Context' (Typ => Context_Type_Def, Type_Name => Name, Type_Validator => null, Redefined_Type => No_Type, Mixed_Content => Mixed, Simple_Content => False, Block_Restriction => False, Block_Extension => False, Level => Handler.Contexts.Level + 1, Next => Handler.Contexts); if Block_Index /= -1 then declare Block : constant Byte_Sequence := Get_Value (Atts, Block_Index); begin Handler.Contexts.Block_Restriction := Block = "restriction" or else Block = "#all"; Handler.Contexts.Block_Extension := Block = "extension" or else Block = "#all"; end; end if; -- Do not use In_Redefine_Context, since this only applies for types -- that are redefined if Handler.Contexts.Next.Typ = Context_Redefine then Handler.Contexts.Redefined_Type := Redefine_Type (Handler.Target_NS, Name.all); Output ("Validator := Redefine_Type (Handler.Target_NS, """ & Name.all & """);"); end if; end Create_Complex_Type; ----------------- -- Ensure_Type -- ----------------- procedure Ensure_Type (Handler : in out Schema_Reader; C : Context_Access) is XML_G : XML_Grammar_NS; begin if C.Type_Validator = null then -- Create an extension, instead of a simple ur-Type, so that we can -- add attributes to it without impacting ur-Type itself Get_NS (Handler.Created_Grammar, XML_Schema_URI, XML_G); C.Type_Validator := Extension_Of (Lookup (XML_G, "anyType")); Output ("Validator := Extension_Of (Lookup (G, ""anyType""));"); end if; end Ensure_Type; ------------------------- -- Finish_Complex_Type -- ------------------------- procedure Finish_Complex_Type (Handler : in out Schema_Reader) is C : constant Context_Access := Handler.Contexts; Typ : XML_Type; begin Ensure_Type (Handler, C); if C.Type_Name = null then Typ := Create_Local_Type (C.Type_Validator); Output (Ada_Name (C) & " := Create_Local_Type (Validator);"); else Typ := Create_Global_Type (Handler.Target_NS, C.Type_Name.all, C.Type_Validator); Set_Debug_Name (C.Type_Validator, C.Type_Name.all); Output (Ada_Name (C) & " := Register (Handler.Target_NS, """ & C.Type_Name.all & """, Validator);"); end if; if Handler.Contexts.Block_Restriction or else Handler.Contexts.Block_Extension then Set_Block (Typ, On_Restriction => Handler.Contexts.Block_Restriction, On_Extension => Handler.Contexts.Block_Extension); Output ("Set_Block (" & Ada_Name (Typ) & ", " & Boolean'Image (Handler.Contexts.Block_Restriction) & ", " & Boolean'Image (Handler.Contexts.Block_Extension) & ");"); end if; Set_Mixed_Content (Get_Validator (Typ), Handler.Contexts.Mixed_Content); Output ("Set_Mixed_Content (" & Ada_Name (C) & ", " & Boolean'Image (Handler.Contexts.Mixed_Content) & ");"); case Handler.Contexts.Next.Typ is when Context_Schema | Context_Redefine => null; when Context_Element => Set_Type (Handler.Contexts.Next.Element, Typ); Output ("Set_Type (" & Ada_Name (Handler.Contexts.Next) & ", " & Ada_Name (C) & ");"); when Context_Attribute => Set_Type (Handler.Contexts.Next.Attribute, Typ); Output ("Set_Type (" & Ada_Name (Handler.Contexts.Next) & ", " & Ada_Name (Typ) & ");"); when Context_List => Handler.Contexts.Next.List_Items := Typ; Output ("Validator := " & Ada_Name (C) & ";"); when others => Output ("Can't handle nested type decl"); end case; end Finish_Complex_Type; ------------------------ -- Create_Restriction -- ------------------------ procedure Create_Restriction (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class) is Base_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "base"); Base : XML_Type; begin if Handler.Contexts.Type_Name /= null and then Base_Index /= -1 and then Get_Value (Atts, Base_Index) = Handler.Contexts.Type_Name.all then if In_Redefine_Context (Handler) then Base := Handler.Contexts.Redefined_Type; else Validation_Error ("Self-referencing restriction not allowed"); end if; elsif Base_Index /= -1 then Lookup_With_NS (Handler, Get_Value (Atts, Base_Index), Result => Base); else Base := No_Type; end if; if Handler.Contexts.Simple_Content then Check_Content_Type (Base, Should_Be_Simple => True); end if; Handler.Contexts := new Context' (Typ => Context_Restriction, Restriction_Base => Base, Restricted => null, Restriction => null, Level => Handler.Contexts.Level + 1, Next => Handler.Contexts); end Create_Restriction; ----------------------- -- Create_Restricted -- ----------------------- procedure Create_Restricted (Handler : in out Schema_Reader; Ctx : Context_Access) is G : XML_Grammar_NS; begin if Ctx.Restricted = null then if Ctx.Restriction_Base = No_Type then Get_NS (Handler.Created_Grammar, XML_Schema_URI, G); Ctx.Restriction_Base := Lookup (G, "ur-Type"); Output ("Restriction has no base type set"); end if; Ctx.Restricted := Restriction_Of (Ctx.Restriction_Base, Ctx.Restriction); Output (Ada_Name (Ctx) & " := Restriction_Of (" & Ada_Name (Ctx.Restriction_Base) & ", " & "Validator" & ");"); end if; end Create_Restricted; ------------------------ -- Finish_Restriction -- ------------------------ procedure Finish_Restriction (Handler : in out Schema_Reader) is begin Create_Restricted (Handler, Handler.Contexts); case Handler.Contexts.Next.Typ is when Context_Type_Def => Handler.Contexts.Next.Type_Validator := Handler.Contexts.Restricted; Set_Debug_Name (Handler.Contexts.Next.Type_Validator, Ada_Name (Handler.Contexts)); Output ("Validator := " & Ada_Name (Handler.Contexts) & ";"); when others => Output ("Can't handler nested restrictions"); end case; end Finish_Restriction; ------------------ -- Create_Union -- ------------------ procedure Create_Union (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class) is Member_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "memberTypes"); begin Handler.Contexts := new Context' (Typ => Context_Union, Union => Create_Union, Level => Handler.Contexts.Level + 1, Next => Handler.Contexts); Output (Ada_Name (Handler.Contexts) & " := Create_Union;"); if Member_Index /= -1 then declare Members : constant Byte_Sequence := Get_Value (Atts, Member_Index); Index : Integer := Members'First; Start, Last : Integer; C : Unicode_Char; Typ : XML_Type; begin while Index <= Members'Last loop while Index <= Members'Last loop Start := Index; Encoding.Read (Members, Index, C); exit when not Is_White_Space (C); end loop; while Index <= Members'Last loop Last := Index; Encoding.Read (Members, Index, C); exit when Is_White_Space (C); end loop; if Index > Members'Last then Last := Members'Last + 1; end if; Lookup_With_NS (Handler, Members (Start .. Last - 1), Typ); Add_Union (Handler.Contexts.Union, Typ); Output ("Add_Union (" & Ada_Name (Handler.Contexts) & ", """ & Members (Start .. Last - 1) & """)"); end loop; end; end if; end Create_Union; ------------------ -- Finish_Union -- ------------------ procedure Finish_Union (Handler : in out Schema_Reader) is begin case Handler.Contexts.Next.Typ is when Context_Type_Def => Handler.Contexts.Next.Type_Validator := XML_Validator (Handler.Contexts.Union); Output ("Validator := " & Ada_Name (Handler.Contexts) & ";"); when others => Output ("Can't handle nested unions"); end case; end Finish_Union; ---------------------- -- Create_Extension -- ---------------------- procedure Create_Extension (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class) is Base_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "base"); Base : XML_Type; begin if Handler.Contexts.Type_Name /= null and then Get_Value (Atts, Base_Index) = Handler.Contexts.Type_Name.all then if In_Redefine_Context (Handler) then Base := Handler.Contexts.Redefined_Type; else Validation_Error ("Self-referencing extension not allowed"); end if; else Lookup_With_NS (Handler, Get_Value (Atts, Base_Index), Result => Base); end if; Handler.Contexts := new Context' (Typ => Context_Extension, Extension_Base => Base, Extension => null, Level => Handler.Contexts.Level + 1, Next => Handler.Contexts); end Create_Extension; ---------------------- -- Finish_Extension -- ---------------------- procedure Finish_Extension (Handler : in out Schema_Reader) is begin case Handler.Contexts.Next.Typ is when Context_Type_Def => if Handler.Contexts.Extension_Base /= No_Type then Handler.Contexts.Next.Type_Validator := Extension_Of (Handler.Contexts.Extension_Base, Handler.Contexts.Extension); Set_Debug_Name (Handler.Contexts.Next.Type_Validator, Ada_Name (Handler.Contexts)); if Handler.Contexts.Extension /= null then Set_Debug_Name (Handler.Contexts.Extension, "extension_of_" & Get_Local_Name (Handler.Contexts.Extension_Base)); end if; Output (Ada_Name (Handler.Contexts) & " := Extension_Of (" & Ada_Name (Handler.Contexts.Extension_Base) & ", Validator);"); else Handler.Contexts.Next.Type_Validator := Handler.Contexts.Extension; Output (Ada_Name (Handler.Contexts) & " := Validator;"); end if; when others => Output ("Can't handle nested extensions"); end case; end Finish_Extension; ----------------- -- Create_List -- ----------------- procedure Create_List (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class) is Item_Type_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "itemType"); Items : XML_Type; begin if Item_Type_Index /= -1 then Lookup_With_NS (Handler, Get_Value (Atts, Item_Type_Index), Result => Items); end if; Handler.Contexts := new Context' (Typ => Context_List, List_Items => Items, Level => Handler.Contexts.Level + 1, Next => Handler.Contexts); end Create_List; ----------------- -- Finish_List -- ----------------- procedure Finish_List (Handler : in out Schema_Reader) is begin case Handler.Contexts.Next.Typ is when Context_Type_Def => Handler.Contexts.Next.Type_Validator := Get_Validator (List_Of (Handler.Contexts.List_Items)); Output ("Validator := List_Of (Validator);"); when others => Output ("Can't handle nested list"); end case; end Finish_List; ------------------- -- Create_Repeat -- ------------------- function Create_Repeat (Validator : access XML_Validator_Record'Class; Min_Occurs, Max_Occurs : Integer) return XML_Validator is Seq : Sequence; begin if Min_Occurs = 1 and then Max_Occurs = 1 then return XML_Validator (Validator); else Seq := Create_Sequence; Set_Debug_Name (Seq, "repeat_seq"); if Validator.all in Sequence_Record'Class then Add_Particle (Seq, Sequence (Validator), Min_Occurs => Min_Occurs, Max_Occurs => Max_Occurs); else Add_Particle (Seq, Choice (Validator), Min_Occurs => Min_Occurs, Max_Occurs => Max_Occurs); end if; Output ("Seq := Create_Sequence;"); Output ("Add_Particle (Seq, Validator," & Min_Occurs'Img & Max_Occurs'Img & ")"); return XML_Validator (Seq); end if; end Create_Repeat; ------------------- -- Create_Choice -- ------------------- procedure Create_Choice (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class) is Min_Occurs_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "minOccurs"); Max_Occurs_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "maxOccurs"); Min_Occurs, Max_Occurs : Integer := 1; begin if Min_Occurs_Index /= -1 then Min_Occurs := Integer'Value (Get_Value (Atts, Min_Occurs_Index)); end if; if Max_Occurs_Index /= -1 then Max_Occurs := Max_Occurs_From_Value (Get_Value (Atts, Max_Occurs_Index)); end if; Handler.Contexts := new Context' (Typ => Context_Choice, C => Create_Choice, Level => Handler.Contexts.Level + 1, Next => Handler.Contexts); Output (Ada_Name (Handler.Contexts) & " := Create_Choice;"); case Handler.Contexts.Next.Typ is when Context_Type_Def => Output ("Validator := " & Ada_Name (Handler.Contexts) & ";"); Handler.Contexts.Next.Type_Validator := Create_Repeat (Handler.Contexts.C, Min_Occurs, Max_Occurs); when Context_Sequence => Add_Particle (Handler.Contexts.Next.Seq, Handler.Contexts.C, Min_Occurs, Max_Occurs); Output ("Add_Particle (" & Ada_Name (Handler.Contexts.Next) & ", " & Ada_Name (Handler.Contexts) & ");"); when Context_Choice => Add_Particle (Handler.Contexts.Next.C, Handler.Contexts.C, Min_Occurs, Max_Occurs); Output ("Add_Particle (" & Ada_Name (Handler.Contexts.Next) & ", " & Ada_Name (Handler.Contexts) & ");"); when Context_Extension => Output ("Validator := " & Ada_Name (Handler.Contexts)); Handler.Contexts.Next.Extension := Create_Repeat (Handler.Contexts.C, Min_Occurs, Max_Occurs); when Context_Group => Add_Particle (Handler.Contexts.Next.Group, Handler.Contexts.C, Min_Occurs, Max_Occurs); Output ("Add_Particle (" & Ada_Name (Handler.Contexts.Next) & ", " & Ada_Name (Handler.Contexts) & ");"); when Context_Schema | Context_Attribute | Context_Element | Context_Restriction | Context_All | Context_Union | Context_List | Context_Redefine | Context_Attribute_Group => Output ("Can't handle nested sequence"); end case; end Create_Choice; ------------------- -- Finish_Choice -- ------------------- procedure Finish_Choice (Handler : in out Schema_Reader) is pragma Unreferenced (Handler); begin null; end Finish_Choice; --------------------- -- Create_Sequence -- --------------------- procedure Create_Sequence (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class) is Min_Occurs_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "minOccurs"); Max_Occurs_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "maxOccurs"); Min_Occurs, Max_Occurs : Integer := 1; begin if Min_Occurs_Index /= -1 then Min_Occurs := Integer'Value (Get_Value (Atts, Min_Occurs_Index)); end if; if Max_Occurs_Index /= -1 then Max_Occurs := Max_Occurs_From_Value (Get_Value (Atts, Max_Occurs_Index)); end if; Handler.Contexts := new Context' (Typ => Context_Sequence, Seq => Create_Sequence, Level => Handler.Contexts.Level + 1, Next => Handler.Contexts); Output (Ada_Name (Handler.Contexts) & " := Create_Sequence;"); case Handler.Contexts.Next.Typ is when Context_Type_Def => Output ("Validator := " & Ada_Name (Handler.Contexts) & ";"); Handler.Contexts.Next.Type_Validator := Create_Repeat (Handler.Contexts.Seq, Min_Occurs, Max_Occurs); when Context_Sequence => Add_Particle (Handler.Contexts.Next.Seq, Handler.Contexts.Seq, Min_Occurs, Max_Occurs); Output ("Add_Particle (" & Ada_Name (Handler.Contexts.Next) & ", " & Ada_Name (Handler.Contexts) & "," & Min_Occurs'Img & "," & Max_Occurs'Img & ");"); when Context_Choice => Add_Particle (Handler.Contexts.Next.C, Handler.Contexts.Seq, Min_Occurs, Max_Occurs); Output ("Add_Particle (" & Ada_Name (Handler.Contexts.Next) & ", " & Ada_Name (Handler.Contexts) & "," & Min_Occurs'Img & "," & Max_Occurs'Img & ");"); when Context_Extension => Output ("Validator := " & Ada_Name (Handler.Contexts) & ";"); Handler.Contexts.Next.Extension := Create_Repeat (Handler.Contexts.Seq, Min_Occurs, Max_Occurs); when Context_Restriction => Output ("Validator := " & Ada_Name (Handler.Contexts) & ";"); Handler.Contexts.Next.Restriction := Create_Repeat (Handler.Contexts.Seq, Min_Occurs, Max_Occurs); when Context_Group => Add_Particle (Handler.Contexts.Next.Group, Handler.Contexts.Seq, Min_Occurs, Max_Occurs); Output ("Add_Particle (" & Ada_Name (Handler.Contexts.Next) & ", " & Ada_Name (Handler.Contexts) & ");"); Set_Debug_Name (Handler.Contexts.Seq, "seq_in_group__" & Get_Local_Name (Handler.Contexts.Next.Group)); when Context_Schema | Context_Attribute | Context_Element | Context_All | Context_Union | Context_List | Context_Redefine | Context_Attribute_Group => Output ("Can't handle nested sequence"); end case; end Create_Sequence; --------------------- -- Finish_Sequence -- --------------------- procedure Finish_Sequence (Handler : in out Schema_Reader) is pragma Unreferenced (Handler); begin null; end Finish_Sequence; ---------------------- -- Create_Attribute -- ---------------------- procedure Create_Attribute (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class) is Name_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "name"); Type_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "type"); Use_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "use"); Ref_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "ref"); Att : Attribute_Validator; Typ : XML_Type := No_Type; Use_Type : Attribute_Use_Type := Optional; begin if Type_Index /= -1 then Lookup_With_NS (Handler, Get_Value (Atts, Type_Index), Result => Typ); end if; if Use_Index /= -1 then Use_Type := Optional; end if; Handler.Contexts := new Context' (Typ => Context_Attribute, Attribute => null, Attribute_Is_Ref => Name_Index = -1, Level => Handler.Contexts.Level + 1, Next => Handler.Contexts); if Name_Index /= -1 then case Handler.Contexts.Next.Typ is when Context_Schema | Context_Redefine => Att := Create_Global_Attribute (Local_Name => Get_Value (Atts, Name_Index), NS => Handler.Target_NS, Attribute_Type => Typ); Output (Ada_Name (Handler.Contexts) & " := Create_Global_Attribute (""" & Get_Value (Atts, Name_Index) & """, Handler.Target_NS, " & Ada_Name (Typ) & ");"); when others => Att := Create_Local_Attribute (Local_Name => Get_Value (Atts, Name_Index), NS => Handler.Target_NS, Attribute_Type => Typ, Attribute_Use => Use_Type, Attribute_Form => Qualified, Value => ""); Output (Ada_Name (Handler.Contexts) & " := Create_Local_Attribute (""" & Get_Value (Atts, Name_Index) & """, Handler.Target_NS, " & Ada_Name (Typ) & ", " & Use_Type'Img & ", Qualified);"); end case; else Att := Lookup_Attribute (Handler.Target_NS, Get_Value (Atts, Ref_Index)); Output (Ada_Name (Handler.Contexts) & " := Lookup_Attribute (Handler.Target_NS, """ & Get_Value (Atts, Ref_Index) & """);"); end if; Handler.Contexts.Attribute := Att; Insert_Attribute (Handler, Handler.Contexts.Next, Handler.Contexts.Attribute, Ada_Name (Handler.Contexts)); end Create_Attribute; ---------------------- -- Insert_Attribute -- ---------------------- procedure Insert_Attribute (Handler : in out Schema_Reader; In_Context : Context_Access; Attribute : Attribute_Validator; Attribute_Name : Byte_Sequence) is begin case In_Context.Typ is when Context_Type_Def => Ensure_Type (Handler, In_Context); Add_Attribute (In_Context.Type_Validator, Attribute); Output ("Add_Attribute (Validator, " & Attribute_Name & ");"); when Context_Schema | Context_Redefine => null; when Context_Extension => -- If there is no extension at this point, there won't be any as -- per the XML schema, since the attributes come last if In_Context.Extension = null then In_Context.Extension := Extension_Of (In_Context.Extension_Base, null); Output (Ada_Name (In_Context) & " := Extension_Of (" & Ada_Name (In_Context.Extension_Base) & ", null);"); In_Context.Extension_Base := No_Type; end if; Add_Attribute (In_Context.Extension, Attribute); Output ("Add_Attribute (" & Ada_Name (In_Context) & ", " & Attribute_Name & ");"); when Context_Restriction => Create_Restricted (Handler, In_Context); Add_Attribute (In_Context.Restricted, Attribute); Output ("Add_Attribute (" & Ada_Name (In_Context) & ", " & Attribute_Name & ");"); when Context_Attribute_Group => Add_Attribute (In_Context.Attr_Group, Attribute); Output ("Add_Attribute (" & Ada_Name (In_Context) & ", " & Attribute_Name & ");"); when Context_Element | Context_Sequence | Context_Choice | Context_Attribute | Context_All | Context_Union | Context_List | Context_Group => Output ("Can't handle attribute decl in this context"); end case; end Insert_Attribute; ---------------------- -- Finish_Attribute -- ---------------------- procedure Finish_Attribute (Handler : in out Schema_Reader) is begin if not Handler.Contexts.Attribute_Is_Ref and then Get_Type (Handler.Contexts.Attribute) = No_Type then Set_Type (Handler.Contexts.Attribute, Lookup (Handler.Schema_NS, "ur-Type")); Output ("Set_Type (" & Ada_Name (Handler.Contexts) & ", Lookup (Handler.Schema_NS, ""ur-Type"");"); end if; end Finish_Attribute; ------------------- -- Create_Schema -- ------------------- procedure Create_Schema (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class) is Target_NS_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "targetNamespace"); Form_Default_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "elementFormDefault"); Block_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "blockDefault"); begin if Target_NS_Index /= -1 then Get_NS (Handler.Created_Grammar, Get_Value (Atts, Target_NS_Index), Handler.Target_NS); if Debug then Output ("Get_NS (Handler.Created_Grammar, """ & Get_Value (Atts, Target_NS_Index) & """, Handler.Target_NS)"); end if; Set_Target_NS (Handler.Created_Grammar, Handler.Target_NS); else Get_NS (Handler.Created_Grammar, "", Handler.Target_NS); if Debug then Output ("Get_NS (Handler.Created_Grammar, """", Handler.Target_NS)"); end if; Set_Target_NS (Handler.Created_Grammar, null); end if; if Form_Default_Index /= -1 then if Get_Value (Atts, Form_Default_Index) = "qualified" then Handler.Element_Form_Default := Qualified; Output ("Set_Element_Form_Default (Handler.Target_NS, Qualified);"); else Handler.Element_Form_Default := Unqualified; Output ("Set_Element_Form_Default (Handler.Target_NS, Unqualified);"); end if; end if; if Block_Index /= -1 then declare Block : constant Byte_Sequence := Get_Value (Atts, Block_Index); begin Set_Block_Default (Handler.Target_NS, On_Restriction => Block = "restriction" or else Block = "#all", On_Extension => Block = "extension" or else Block = "#all"); Output ("Set_Block (Handler.Target_NS, " & Boolean'Image (Block = "restriction" or else Block = "#all") & ", " & Boolean'Image (Block = "extension" or else Block = "#all")); end; end if; Handler.Contexts := new Context' (Typ => Context_Schema, Level => 0, Next => null); end Create_Schema; -------------------------------- -- Process_Contents_From_Atts -- -------------------------------- function Process_Contents_From_Atts (Atts : Sax.Attributes.Attributes'Class) return Process_Contents_Type is Process_Contents_Index : constant Integer := Get_Index (Atts, "processContents"); begin if Process_Contents_Index = -1 then return Process_Strict; elsif Get_Value (Atts, Process_Contents_Index) = "lax" then return Process_Lax; elsif Get_Value (Atts, Process_Contents_Index) = "strict" then return Process_Strict; else return Process_Skip; end if; end Process_Contents_From_Atts; ---------------- -- Create_Any -- ---------------- procedure Create_Any (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class) is Namespace_Index : constant Integer := Get_Index (Atts, "namespace"); Min_Occurs_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "minOccurs"); Max_Occurs_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "maxOccurs"); Min_Occurs, Max_Occurs : Integer := 1; Process_Contents : Process_Contents_Type; Any : XML_Any; begin if Min_Occurs_Index /= -1 then Min_Occurs := Integer'Value (Get_Value (Atts, Min_Occurs_Index)); end if; if Max_Occurs_Index /= -1 then Max_Occurs := Max_Occurs_From_Value (Get_Value (Atts, Max_Occurs_Index)); end if; Process_Contents := Process_Contents_From_Atts (Atts); if Namespace_Index /= -1 then Any := Create_Any (Process_Contents => Process_Contents, Namespace => Get_Value (Atts, Namespace_Index), Target_NS => Handler.Target_NS); Output ("Validator := Create_Any (" & Process_Contents'Img & ", " & Get_Value (Atts, Namespace_Index) & ", Handler.Target_NS);"); else Any := Create_Any (Process_Contents => Process_Contents, Namespace => "##any", Target_NS => Handler.Target_NS); Output ("Validator := Create_Any (" & Process_Contents'Img & ", ""##any"", Handler.Target_NS);"); end if; case Handler.Contexts.Typ is when Context_Sequence => Add_Particle (Handler.Contexts.Seq, Any, Min_Occurs, Max_Occurs); Output ("Add_Particle (" & Ada_Name (Handler.Contexts) & ", Validator," & Min_Occurs'Img & "," & Max_Occurs'Img & ");"); when Context_Choice => Add_Particle (Handler.Contexts.C, Any, Min_Occurs, Max_Occurs); Output ("Add_Particle (" & Ada_Name (Handler.Contexts) & ", Validator," & Min_Occurs'Img & "," & Max_Occurs'Img & ");"); when others => Output ("Can't handled nested "); end case; end Create_Any; ---------------- -- Create_All -- ---------------- procedure Create_All (Handler : in out Schema_Reader; Atts : Sax.Attributes.Attributes'Class) is Min_Occurs_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "minOccurs"); Max_Occurs_Index : constant Integer := Get_Index (Atts, URI => "", Local_Name => "maxOccurs"); Min_Occurs, Max_Occurs : Integer := 1; begin if Min_Occurs_Index /= -1 then Min_Occurs := Integer'Value (Get_Value (Atts, Min_Occurs_Index)); end if; if Max_Occurs_Index /= -1 then Max_Occurs := Max_Occurs_From_Value (Get_Value (Atts, Max_Occurs_Index)); end if; Handler.Contexts := new Context' (Typ => Context_All, All_Validator => Create_All (Min_Occurs, Max_Occurs), Level => Handler.Contexts.Level + 1, Next => Handler.Contexts); Output (Ada_Name (Handler.Contexts) & " := Create_All (" & Min_Occurs'Img & "," & Max_Occurs'Img & ");"); end Create_All; ---------------- -- Finish_All -- ---------------- procedure Finish_All (Handler : in out Schema_Reader) is begin case Handler.Contexts.Next.Typ is when Context_Type_Def => Handler.Contexts.Next.Type_Validator := XML_Validator (Handler.Contexts.All_Validator); Output ("Validator := XML_Validator (" & Ada_Name (Handler.Contexts) & ");"); when Context_Group => Add_Particle (Handler.Contexts.Next.Group, Handler.Contexts.All_Validator); Output ("Add_Particle (" & Ada_Name (Handler.Contexts.Next) & ", " & Ada_Name (Handler.Contexts) & ");"); when others => Output ("Can't handled nested all"); end case; end Finish_All; -------------- -- Ada_Name -- -------------- function Ada_Name (C : Context_Access) return String is L : constant String := Integer'Image (C.Level); begin case C.Typ is when Context_Schema | Context_Redefine => return ""; when Context_Choice => return "Choice" & L (L'First + 1 .. L'Last); when Context_Sequence => return "Seq" & L (L'First + 1 .. L'Last); when Context_All => return "All" & L (L'First + 1 .. L'Last); when Context_Element => return Ada_Name (C.Element); when Context_Type_Def => if C.Type_Name = null then return "T_" & L (L'First + 1 .. L'Last); else return "T_" & XML_To_Ada (C.Type_Name.all); end if; when Context_Attribute => return "A_" & L (L'First + 1 .. L'Last); when Context_Restriction => return "R_" & L (L'First + 1 .. L'Last); when Context_Extension => return "E_" & L (L'First + 1 .. L'Last); when Context_Union => return "U_" & L (L'First + 1 .. L'Last); when Context_List => return "L_" & L (L'First + 1 .. L'Last); when Context_Group => return "G_" & L (L'First + 1 .. L'Last); when Context_Attribute_Group => return "AG_" & L (L'First + 1 .. L'Last); end case; end Ada_Name; ------------------- -- Start_Element -- ------------------- procedure Start_Element (Handler : in out Schema_Reader; Namespace_URI : Unicode.CES.Byte_Sequence := ""; Local_Name : Unicode.CES.Byte_Sequence := ""; Qname : Unicode.CES.Byte_Sequence := ""; Atts : Sax.Attributes.Attributes'Class) is begin -- Check the grammar Start_Element (Validating_Reader (Handler), Namespace_URI, Local_Name, Qname, Atts); -- Process the element if Handler.Contexts = null then if Local_Name /= "schema" then Validation_Error ("Root element must be "); end if; Create_Schema (Handler, Atts); elsif Local_Name = "annotation" then null; elsif Local_Name = "element" then Create_Element (Handler, Atts); elsif Local_Name = "complexType" then Create_Complex_Type (Handler, Atts); elsif Local_Name = "simpleType" then Create_Simple_Type (Handler, Atts); elsif Local_Name = "restriction" then Create_Restriction (Handler, Atts); elsif Local_Name = "extension" then Create_Extension (Handler, Atts); elsif Local_Name = "anyAttribute" then Create_Any_Attribute (Handler, Atts); elsif Local_Name = "maxLength" or else Local_Name = "pattern" or else Local_Name = "minLength" or else Local_Name = "enumeration" or else Local_Name = "whiteSpace" or else Local_Name = "totalDigits" or else Local_Name = "fractionDigits" or else Local_Name = "maxInclusive" or else Local_Name = "maxExclusive" or else Local_Name = "minInclusive" or else Local_Name = "minExclusive" then Create_Restricted (Handler, Handler.Contexts); Add_Facet (Handler.Contexts.Restricted, Local_Name, Get_Value (Atts, URI => "", Local_Name => "value")); Output ("Add_Facet (" & Ada_Name (Handler.Contexts) & ", """ & Local_Name & """, """ & Get_Value (Atts, URI => "", Local_Name => "value") & """);"); elsif Local_Name = "all" then Create_All (Handler, Atts); elsif Local_Name = "sequence" then Create_Sequence (Handler, Atts); elsif Local_Name = "choice" then Create_Choice (Handler, Atts); elsif Local_Name = "list" then Create_List (Handler, Atts); elsif Local_Name = "union" then Create_Union (Handler, Atts); elsif Local_Name = "attribute" then Create_Attribute (Handler, Atts); elsif Local_Name = "group" then Create_Group (Handler, Atts); elsif Local_Name = "simpleContent" then Handler.Contexts.Simple_Content := True; elsif Local_Name = "complexContent" then Handler.Contexts.Simple_Content := False; elsif Local_Name = "attributeGroup" then Create_Attribute_Group (Handler, Atts); elsif Local_Name = "any" then Create_Any (Handler, Atts); elsif Local_Name = "redefine" then Create_Redefine (Handler, Atts); elsif Local_Name = "include" then Create_Include (Handler, Atts); elsif Local_Name = "import" then Create_Import (Handler, Atts); else Output ("Tag not handled yet: " & Local_Name); end if; end Start_Element; ----------------- -- End_Element -- ----------------- procedure End_Element (Handler : in out Schema_Reader; Namespace_URI : Unicode.CES.Byte_Sequence := ""; Local_Name : Unicode.CES.Byte_Sequence := ""; Qname : Unicode.CES.Byte_Sequence := "") is C : Context_Access := Handler.Contexts; Handled : Boolean := True; begin -- Check the grammar End_Element (Validating_Reader (Handler), Namespace_URI, Local_Name, Qname); -- Process the tag if Local_Name = "element" then Finish_Element (Handler); elsif Local_Name = "schema" then -- ??? Check there remains no undefined forward declaration null; elsif Local_Name = "complexType" then Finish_Complex_Type (Handler); elsif Local_Name = "simpleType" then Finish_Simple_Type (Handler); elsif Local_Name = "all" then Finish_All (Handler); elsif Local_Name = "sequence" then Finish_Sequence (Handler); elsif Local_Name = "anyAttribute" then Handled := False; elsif Local_Name = "choice" then Finish_Choice (Handler); elsif Local_Name = "restriction" then Finish_Restriction (Handler); elsif Local_Name = "extension" then Finish_Extension (Handler); elsif Local_Name = "attribute" then Finish_Attribute (Handler); elsif Local_Name = "union" then Finish_Union (Handler); elsif Local_Name = "list" then Finish_List (Handler); elsif Local_Name = "maxLength" or else Local_Name = "pattern" or else Local_Name = "minLength" or else Local_Name = "enumeration" or else Local_Name = "whiteSpace" or else Local_Name = "totalDigits" or else Local_Name = "fractionDigits" or else Local_Name = "maxInclusive" or else Local_Name = "maxExclusive" or else Local_Name = "minInclusive" or else Local_Name = "minExclusive" then Handled := False; elsif Local_Name = "redefine" then null; elsif Local_Name = "include" then Handled := False; elsif Local_Name = "group" then Finish_Group (Handler); elsif Local_Name = "attributeGroup" then null; elsif Local_Name = "any" then Handled := False; elsif Local_Name = "import" or else Local_Name = "simpleContent" or else Local_Name = "complexContent" then Handled := False; else Output ("Close tag not handled yet: " & Local_Name); Handled := False; end if; -- Free the context if Handled then Handler.Contexts := Handler.Contexts.Next; Free (C); end if; end End_Element; ---------- -- Free -- ---------- procedure Free (C : in out Context_Access) is procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Context, Context_Access); begin if C /= null then case C.Typ is when Context_Type_Def => Free (C.Type_Name); when others => null; end case; Unchecked_Free (C); end if; end Free; ---------------- -- Characters -- ---------------- procedure Characters (Handler : in out Schema_Reader; Ch : Unicode.CES.Byte_Sequence) is begin Characters (Validating_Reader (Handler), Ch); end Characters; ------------------------------- -- Get_Grammar_For_Namespace -- ------------------------------- procedure Get_Grammar_For_Namespace (Handler : in out Schema_Reader'Class; Prefix : Byte_Sequence; Grammar : out XML_Grammar_NS) is Namespace : constant Byte_Sequence_Access := Get_Namespace_From_Prefix (Handler, Prefix); begin if Namespace = null then Output ("G := Handler.Target_NS;"); Grammar := Handler.Target_NS; else Output ("Get_NS (Handler.Created_Grammar, """ & Namespace.all & """, G);"); Get_NS (Handler.Created_Grammar, Namespace.all, Grammar); end if; end Get_Grammar_For_Namespace; end Schema.Schema_Readers;