------------------------------------------------------------------------------ -- XML/Ada - An XML suite for Ada95 -- -- -- -- Copyright (C) 2010-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.Unchecked_Deallocation; with Ada.Exceptions; use Ada.Exceptions; with Ada.Strings.Fixed; use Ada.Strings.Fixed; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with Sax.Encodings; use Sax.Encodings; with Unicode; use Unicode; with Unicode.Names.Basic_Latin; use Unicode.Names.Basic_Latin; package body Schema.Simple_Types is use Simple_Type_Tables, Enumeration_Tables; procedure Unchecked_Free is new Ada.Unchecked_Deallocation (pattern_matcher_array, pattern_matcher_array_access); procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Pattern_Matcher, pattern_matcher_access); generic with function Get_Length (Ch : byte_sequence) return Natural; function Validate_Length_Facets (Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence; Mask : facets_mask; Length, Min_Length, Max_Length : Integer) return symbol; -- Validate length facets generic type t is private; with procedure Value (Symbols : symbol_table; Ch : byte_sequence; Val : out t; Error : out symbol) is <>; with function Image (Val : t) return byte_sequence is <>; with function "<" (T1, T2 : t) return Boolean is <>; with function "<=" (T1, T2 : t) return Boolean is <>; procedure Validate_Range (Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence; Mask : facets_mask; Min_Inclusive : t; Min_Exclusive : t; Max_Inclusive : t; Max_Exclusive : t; Error : out symbol; Val : out t); generic type t is private; with procedure Value (Symbols : symbol_table; Ch : byte_sequence; Val : out t; Error : out symbol) is <>; procedure Override_Single_Range_Facet (Symbols : Sax.Utils.symbol_table; Facets : all_facets; Facet : facet_enum; Mask : in out facets_mask; Val : in out t; Error : in out symbol; Error_Loc : in out location); generic type t is private; with procedure Value (Symbols : symbol_table; Ch : byte_sequence; Val : out t; Error : out symbol) is <>; procedure Override_Range_Facets (Symbols : Sax.Utils.symbol_table; Facets : all_facets; Mask : in out facets_mask; Min_Inclusive : in out t; Min_Exclusive : in out t; Max_Inclusive : in out t; Max_Exclusive : in out t; Error : out symbol; Error_Loc : out location); -- Override some range facets procedure Override_Length_Facets (Symbols : Sax.Utils.symbol_table; Facets : all_facets; Mask : in out facets_mask; Length : in out Integer; Min_Length : in out Integer; Max_Length : in out Integer; Error : out symbol; Error_Loc : out location); -- Override some length facets generic type t is private; with procedure Value (Symbols : symbol_table; Ch : byte_sequence; Val : out t; Error : out symbol) is <>; with function "=" (T1, T2 : t) return Boolean is <>; with function Image (T1 : t) return String is <>; function Generic_Equal (Symbols : symbol_table; Val1 : symbol; Val2 : byte_sequence) return Boolean; -- Compare two values, after possibly normalizing them given the type -- definition (whitespaces, remove left-most 0 when appropriate,...). -- This assumes [Val1] and [Val2] are valid values for the type (ie they -- have already been validated). function Validate_List_Facets (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence; Length, Min_Length, Max_Length : Integer) return symbol; -- Validate the facets for a list procedure Check_Id (Symbols : symbol_table; Id_Table : in out symbol_htable_access; Value : Unicode.CES.byte_sequence; Error : in out symbol); -- Check whether Value is a unique ID in the document. -- If yes, store it in Id_Table to ensure its future uniqueness. -- Return the error message or [No_Symbol] ------------------- -- Generic_Equal -- ------------------- function Generic_Equal (Symbols : symbol_table; Val1 : symbol; Val2 : byte_sequence) return Boolean is V1, V2 : t; Error : symbol; begin Value (Symbols, Get (Val1).all, V1, Error); if Error /= No_Symbol then if Debug then Debug_Output ("Generic_Equal, could not convert Val1 " & Get (Val1).all & " => " & Get (Error).all); end if; return False; end if; Value (Symbols, Val2, V2, Error); if Error /= No_Symbol then if Debug then Debug_Output ("Generic_Equal, could not convert Val2 " & Val2 & " => " & Get (Error).all); end if; return False; end if; if Debug then Debug_Output ("Comparing " & Image (V1) & " != " & Image (V2)); end if; return V1 = V2; end Generic_Equal; ---------------------------- -- Validate_Length_Facets -- ---------------------------- function Validate_Length_Facets (Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence; Mask : facets_mask; Length, Min_Length, Max_Length : Integer) return symbol is L : Integer := -1; begin -- Characters are always a string, nothing to check here but the facets if Mask (facet_length) or else Mask (facet_min_length) or else Mask (facet_max_length) then L := Get_Length (Ch); else return No_Symbol; end if; if Mask (facet_length) then if L /= Length then return Find (Symbols, "Invalid length, must be" & Integer'image (Length) & " characters"); end if; end if; if Mask (facet_min_length) then if L < Min_Length then return Find (Symbols, "String is too short, minimum length is" & Integer'image (Min_Length) & " characters"); end if; end if; if Mask (facet_max_length) then if L > Max_Length then return Find (Symbols, "String is too long, maximum length is" & Integer'image (Max_Length) & " characters"); end if; end if; return No_Symbol; end Validate_Length_Facets; --------------------- -- Instantiations -- --------------------- function HexBinary_Get_Length (Value : Unicode.CES.byte_sequence) return Natural; function Base64Binary_Get_Length (Value : Unicode.CES.byte_sequence) return Natural; -- Return the length of a string procedure Value (Symbols : symbol_table; Ch : byte_sequence; Val : out xml_float; Error : out symbol); -- Converts [Ch] into [Val] function Validate_String (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol; function Validate_HexBinary_Facets is new Validate_Length_Facets (HexBinary_Get_Length); function Validate_Base64Binary_Facets is new Validate_Length_Facets (Base64Binary_Get_Length); function Validate_NMTOKEN (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence; XML_Version : xml_versions) return symbol; function Validate_NMTOKENS (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence; XML_Version : xml_versions) return symbol; function Validate_Name (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence; XML_Version : xml_versions) return symbol; function Validate_NCName (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence; XML_Version : xml_versions) return symbol; function Validate_NCNames (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence; XML_Version : xml_versions) return symbol; function Validate_Language (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol; function Validate_URI (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol; function Validate_HexBinary (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol; function Validate_Notation (Notations : Symbol_Htable.htable; Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol; function Validate_Base64Binary (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol; function Validate_QName (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence; XML_Version : xml_versions) return symbol; function Validate_Boolean (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol; function Validate_Double (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol; function Validate_Decimal (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol; function Validate_Duration (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol; function Validate_Date_Time (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol; function Validate_Date (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol; function Validate_Time (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol; function Validate_GDay (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol; function Validate_GMonth_Day (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol; function Validate_GMonth (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol; function Validate_GYear (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol; function Validate_GYear_Month (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol; -- Check [Ch] for one of the primitive types, including facets function Anchor (Str : String) return String; -- Return an anchored version of Str ("^...$"). -- In XML, regexps are always anchored, as per the beginning of [G] function Missing_End_Anchor (Str : String) return Boolean; function Missing_Start_Anchor (Str : String) return Boolean; -- Whether the regexp is missing the "^" or "$" anchors procedure Boolean_Value (Symbols : symbol_table; Ch : byte_sequence; Val : out Boolean; Error : out symbol); -- Converts [Ch] to a boolean, and returns an error message if needed function Equal_Boolean is new Generic_Equal (Boolean, Boolean_Value, Image => Boolean'image); function Equal_Float is new Generic_Equal (xml_float, Value); function Equal_Decimal is new Generic_Equal (arbitrary_precision_number); function Equal_Duration is new Generic_Equal (duration_t); function Equal_Date_Time is new Generic_Equal (date_time_t); function Equal_Date is new Generic_Equal (date_t); function Equal_Time is new Generic_Equal (time_t); function Equal_GDay is new Generic_Equal (gday_t); function Equal_GMonth_Day is new Generic_Equal (gmonth_day_t); function Equal_GMonth is new Generic_Equal (gmonth_t); function Equal_GYear is new Generic_Equal (gyear_t); function Equal_GYear_Month is new Generic_Equal (gyear_month_t); ------------------------------- -- Register_Predefined_Types -- ------------------------------- procedure Register_Predefined_Types (Symbols : Sax.Utils.symbol_table) is Zero : constant arbitrary_precision_number := Value (Find (Symbols, "0")); One : constant arbitrary_precision_number := Value (Find (Symbols, "1")); Minus_One : constant arbitrary_precision_number := Value (Find (Symbols, "-1")); Max_Unsigned_Long : constant arbitrary_precision_number := Value (Find (Symbols, "+18446744073709551615")); Max_Long : constant arbitrary_precision_number := Value (Find (Symbols, "+9223372036854775807")); Min_Long : constant arbitrary_precision_number := Value (Find (Symbols, "-9223372036854775808")); Max_Int : constant arbitrary_precision_number := Value (Find (Symbols, "+2147483647")); Min_Int : constant arbitrary_precision_number := Value (Find (Symbols, "-2147483648")); Max_Short : constant arbitrary_precision_number := Value (Find (Symbols, "+32767")); Min_Short : constant arbitrary_precision_number := Value (Find (Symbols, "-32768")); Max_Byte : constant arbitrary_precision_number := Value (Find (Symbols, "+127")); Min_Byte : constant arbitrary_precision_number := Value (Find (Symbols, "-128")); Max_Unsigned_Int : constant arbitrary_precision_number := Value (Find (Symbols, "+4294967295")); Max_Unsigned_Short : constant arbitrary_precision_number := Value (Find (Symbols, "+65535")); Max_Unsigned_Byte : constant arbitrary_precision_number := Value (Find (Symbols, "+255")); Whitespace_Mask : constant facets_mask := (facet_whitespace => True, others => False); Fraction_Min_Mask : constant facets_mask := (facet_fraction_digits => True, facet_min_inclusive => True, others => False); Fraction_Max_Mask : constant facets_mask := (facet_fraction_digits => True, facet_max_inclusive => True, others => False); Fraction_Min_Max_Mask : constant facets_mask := (facet_fraction_digits => True, facet_min_inclusive => True, facet_max_inclusive => True, others => False); Any_Simple_Type, Decimal, Integer, Long, Int, Short : type_index; Non_Positive_Int, Non_Negative_Int : type_index; Unsigned_Long, Unsigned_Int, Unsigned_Short : type_index; Str, Normalized_Str, Token : type_index; Name, NCName : type_index; T : type_index; pragma unreferenced (T); begin Any_Simple_Type := Register ("anySimpleType", (Kind => primitive_string, Mask => (facet_whitespace => True, others => False), Whitespace => preserve, others => <>), No_Type_Index); Str := Register ("string", (Kind => primitive_string, Mask => Whitespace_Mask, Whitespace => preserve, others => <>), Any_Simple_Type); Normalized_Str := Register ("normalizedString", (Kind => primitive_string, Mask => Whitespace_Mask, Whitespace => replace, others => <>), Str); Token := Register ("token", (Kind => primitive_string, Mask => Whitespace_Mask, Whitespace => collapse, others => <>), Normalized_Str); T := Register ("language", (Kind => primitive_language, Mask => Whitespace_Mask, Whitespace => collapse, others => <>), Token); T := Register ("boolean", (Kind => primitive_boolean, others => <>), Any_Simple_Type); T := Register ("QName", (Kind => primitive_qname, Mask => Whitespace_Mask, others => <>), Any_Simple_Type); T := Register ("NOTATION", (Kind => primitive_notation, others => <>), Any_Simple_Type); T := Register ("float", (Kind => primitive_float, others => <>), Any_Simple_Type); T := Register ("NMTOKEN", (Kind => primitive_nmtoken, others => <>), Token); T := Register ("NMTOKENS", (Kind => primitive_nmtokens, Mask => Whitespace_Mask, others => <>), Any_Simple_Type); Name := Register ("Name", (Kind => primitive_name, Mask => Whitespace_Mask, Whitespace => collapse, others => <>), Token); NCName := Register ("NCName", (Kind => primitive_ncname, Mask => Whitespace_Mask, Whitespace => collapse, others => <>), Name); T := Register ("ID", (Kind => primitive_id, Mask => Whitespace_Mask, Whitespace => preserve, others => <>), NCName); T := Register ("IDREF", (Kind => primitive_ncname, Mask => Whitespace_Mask, Whitespace => preserve, others => <>), NCName); T := Register ("IDREFS", (Kind => primitive_ncnames, Mask => Whitespace_Mask, Whitespace => preserve, others => <>), Any_Simple_Type); T := Register ("ENTITY", (Kind => primitive_ncname, Mask => Whitespace_Mask, Whitespace => preserve, others => <>), NCName); T := Register ("ENTITIES", (Kind => primitive_ncnames, Mask => Whitespace_Mask, Whitespace => preserve, others => <>), Any_Simple_Type); T := Register ("anyURI", (Kind => primitive_any_uri, Mask => Whitespace_Mask, others => <>), Any_Simple_Type); T := Register ("hexBinary", (Kind => primitive_hexbinary, others => <>), Any_Simple_Type); T := Register ("base64Binary", (Kind => primitive_base64binary, others => <>), Any_Simple_Type); Decimal := Register ("decimal", (Kind => primitive_decimal, others => <>), Any_Simple_Type); Integer := Register ("integer", (Kind => primitive_decimal, Fraction_Digits => 0, Mask => (facet_fraction_digits => True, others => False), others => <>), Decimal); Non_Negative_Int := Register ("nonNegativeInteger", (Kind => primitive_decimal, Fraction_Digits => 0, Decimal_Min_Inclusive => Zero, Mask => Fraction_Min_Mask, others => <>), Integer); Unsigned_Long := Register ("unsignedLong", (Kind => primitive_decimal, Mask => Fraction_Min_Max_Mask, Fraction_Digits => 0, Decimal_Min_Inclusive => Zero, Decimal_Max_Inclusive => Max_Unsigned_Long, others => <>), Non_Negative_Int); T := Register ("positiveInteger", (Kind => primitive_decimal, Fraction_Digits => 0, Decimal_Min_Inclusive => One, Mask => Fraction_Min_Mask, others => <>), Non_Negative_Int); Non_Positive_Int := Register ("nonPositiveInteger", (Kind => primitive_decimal, Fraction_Digits => 0, Decimal_Max_Inclusive => Zero, Mask => Fraction_Max_Mask, others => <>), Integer); T := Register ("negativeInteger", (Kind => primitive_decimal, Fraction_Digits => 0, Decimal_Max_Inclusive => Minus_One, Mask => Fraction_Max_Mask, others => <>), Non_Positive_Int); Long := Register ("long", (Kind => primitive_decimal, Mask => Fraction_Min_Max_Mask, Fraction_Digits => 0, Decimal_Max_Inclusive => Max_Long, Decimal_Min_Inclusive => Min_Long, others => <>), Integer); Int := Register ("int", (Kind => primitive_decimal, Mask => Fraction_Min_Max_Mask, Fraction_Digits => 0, Decimal_Max_Inclusive => Max_Int, Decimal_Min_Inclusive => Min_Int, others => <>), Long); Short := Register ("short", (Kind => primitive_decimal, Mask => Fraction_Min_Max_Mask, Fraction_Digits => 0, Decimal_Max_Inclusive => Max_Short, Decimal_Min_Inclusive => Min_Short, others => <>), Int); T := Register ("byte", (Kind => primitive_decimal, Mask => Fraction_Min_Max_Mask, Fraction_Digits => 0, Decimal_Max_Inclusive => Max_Byte, Decimal_Min_Inclusive => Min_Byte, others => <>), Short); Unsigned_Int := Register ("unsignedInt", (Kind => primitive_decimal, Mask => Fraction_Min_Max_Mask, Fraction_Digits => 0, Decimal_Max_Inclusive => Max_Unsigned_Int, Decimal_Min_Inclusive => Zero, others => <>), Unsigned_Long); Unsigned_Short := Register ("unsignedShort", (Kind => primitive_decimal, Mask => Fraction_Min_Max_Mask, Fraction_Digits => 0, Decimal_Max_Inclusive => Max_Unsigned_Short, Decimal_Min_Inclusive => Zero, others => <>), Unsigned_Int); T := Register ("unsignedByte", (Kind => primitive_decimal, Mask => Fraction_Min_Max_Mask, Fraction_Digits => 0, Decimal_Max_Inclusive => Max_Unsigned_Byte, Decimal_Min_Inclusive => Zero, others => <>), Unsigned_Short); T := Register ("float", (Kind => primitive_float, others => <>), Any_Simple_Type); T := Register ("double", (Kind => primitive_double, others => <>), Any_Simple_Type); T := Register ("time", (Kind => primitive_time, others => <>), Any_Simple_Type); T := Register ("dateTime", (Kind => primitive_datetime, others => <>), Any_Simple_Type); T := Register ("gDay", (Kind => primitive_gday, others => <>), Any_Simple_Type); T := Register ("gMonthDay", (Kind => primitive_gmonthday, others => <>), Any_Simple_Type); T := Register ("gMonth", (Kind => primitive_gmonth, others => <>), Any_Simple_Type); T := Register ("gYearMonth", (Kind => primitive_gyearmonth, others => <>), Any_Simple_Type); T := Register ("gYear", (Kind => primitive_gyear, others => <>), Any_Simple_Type); T := Register ("date", (Kind => primitive_date, others => <>), Any_Simple_Type); T := Register ("duration", (Kind => primitive_duration, others => <>), Any_Simple_Type); -- Missing attribute "xml:lang" of type "language" end Register_Predefined_Types; ----------- -- Equal -- ----------- procedure Equal (Simple_Types : simple_type_table; Enumerations : Enumeration_Tables.instance; Notations : Symbol_Htable.htable; Symbols : symbol_table; Id_Table : in out symbol_htable_access; Simple_Type : simple_type_index; Ch1 : Sax.Symbols.symbol; Ch2 : Unicode.CES.byte_sequence; Is_Equal : out Boolean; XML_Version : xml_versions) is Descr : simple_type_descr renames Simple_Types.Table (Simple_Type); Error : symbol; begin case Descr.Kind is when primitive_string .. primitive_hexbinary => Is_Equal := Get (Ch1).all = Ch2; when primitive_boolean => Is_Equal := Equal_Boolean (Symbols, Ch1, Ch2); when primitive_float | primitive_double => Is_Equal := Equal_Float (Symbols, Ch1, Ch2); when primitive_decimal => Is_Equal := Equal_Decimal (Symbols, Ch1, Ch2); when primitive_time => Is_Equal := Equal_Time (Symbols, Ch1, Ch2); when primitive_datetime => Is_Equal := Equal_Date_Time (Symbols, Ch1, Ch2); when primitive_gday => Is_Equal := Equal_GDay (Symbols, Ch1, Ch2); when primitive_gmonth => Is_Equal := Equal_GMonth (Symbols, Ch1, Ch2); when primitive_gyear => Is_Equal := Equal_GYear (Symbols, Ch1, Ch2); when primitive_date => Is_Equal := Equal_Date (Symbols, Ch1, Ch2); when primitive_duration => Is_Equal := Equal_Duration (Symbols, Ch1, Ch2); when primitive_gmonthday => Is_Equal := Equal_GMonth_Day (Symbols, Ch1, Ch2); when primitive_gyearmonth => Is_Equal := Equal_GYear_Month (Symbols, Ch1, Ch2); when primitive_union => for S in Descr.Union'range loop if Descr.Union (S) /= No_Simple_Type_Index then -- We need to do space normalization here: when there is -- a single type (ie not a union), the normalization has -- already been done for the "fixed" value, but this isn't -- doable in the case of union where the normalization -- depends on which member is selected. -- We actually also need to validate the value since we -- don't know precisely for which members it is valid. declare Norm : byte_sequence := Get (Ch1).all; Last : Integer := Norm'last; begin Normalize_Whitespace (Whitespace => Simple_Types.Table (Descr.Union (S)).Whitespace, Val => Norm, Last => Last); if Debug then Debug_Output ("Equal for union, checking simpleType:" & Descr.Union (S)'img & " " & Simple_Types.Table (Descr.Union (S)).Whitespace' img & " Ch1=[" & Norm (Norm'first .. Last) & "]"); end if; Validate_Simple_Type (Simple_Types => Simple_Types, Enumerations => Enumerations, Notations => Notations, Symbols => Symbols, Id_Table => Id_Table, Insert_Id => False, Simple_Type => Descr.Union (S), Ch => Norm (Norm'first .. Last), Error => Error, XML_Version => XML_Version); if Debug and then Error /= No_Symbol then Debug_Output ("Equal: member doesn't apply: " & Get (Error).all); end if; if Error = No_Symbol then Equal (Simple_Types => Simple_Types, Enumerations => Enumerations, Notations => Notations, Id_Table => Id_Table, Symbols => Symbols, Simple_Type => Descr.Union (S), Ch1 => Find (Symbols, Norm (Norm'first .. Last)), Ch2 => Ch2, Is_Equal => Is_Equal, XML_Version => XML_Version); if Is_Equal then return; end if; end if; end; end if; end loop; Is_Equal := False; when primitive_list => Is_Equal := Get (Ch1).all = Ch2; end case; end Equal; ------------------------------------- -- Validate_Simple_Type_Characters -- ------------------------------------- procedure Validate_Simple_Type (Simple_Types : simple_type_table; Enumerations : Enumeration_Tables.instance; Notations : Symbol_Htable.htable; Symbols : symbol_table; Id_Table : in out symbol_htable_access; Insert_Id : Boolean := True; Simple_Type : simple_type_index; Ch : Unicode.CES.byte_sequence; Error : in out symbol; XML_Version : xml_versions) is Descr : simple_type_descr renames Simple_Types.Table (Simple_Type); Index : Integer; Char : unicode_char; Matched : Match_Array (0 .. 0); procedure Validate_List_Item (Str : byte_sequence); procedure Validate_List_Item (Str : byte_sequence) is begin if Error = No_Symbol then Validate_Simple_Type (Simple_Types, Enumerations, Notations, Symbols, Id_Table, Simple_Type => Descr.List_Item, Ch => Str, Error => Error, XML_Version => XML_Version); end if; end Validate_List_Item; procedure Validate_List_Items is new For_Each_Item (Validate_List_Item); begin Error := No_Symbol; -- Check common facets if Descr.Mask (facet_enumeration) then declare Enum : enumeration_index := Descr.Enumeration; Found : Boolean := False; begin while Enum /= No_Enumeration_Index loop Equal (Simple_Types, Enumerations, Notations, Symbols, Id_Table, Simple_Type, Ch1 => Enumerations.Table (Enum).Value, Ch2 => Ch, Is_Equal => Found, XML_Version => XML_Version); exit when Found; Enum := Enumerations.Table (Enum).Next; end loop; if not Found then Error := Find (Symbols, "Value not in the enumeration set"); return; end if; end; end if; if Descr.Mask (facet_pattern) and then Descr.Pattern /= null then -- Check whether we have unicode char outside of ASCII Index := Ch'first; while Index <= Ch'last loop Encoding.Read (Ch, Index, Char); if Char > 127 then -- Start with '#' because this is a non-implemented feature Error := Find (Symbols, "#Regexp matching with unicode not supported"); return; end if; end loop; for P in Descr.Pattern'range loop Match (Descr.Pattern (P).Pattern.all, String (Ch), Matched); if Matched (0).First /= Ch'first or else Matched (0).Last /= Ch'last then Error := Find (Symbols, "string pattern not matched: " & Get (Descr.Pattern (P).Str).all); return; end if; end loop; end if; if Descr.Mask (facet_whitespace) then case Descr.Whitespace is when preserve => null; -- Always valid when replace => for C in Ch'range loop if Ch (C) = ASCII.HT or else Ch (C) = ASCII.LF or else Ch (C) = ASCII.CR then Error := Find (Symbols, "HT, LF and CR characters not allowed"); return; end if; end loop; when collapse => for C in Ch'range loop if Ch (C) = ASCII.HT or else Ch (C) = ASCII.LF or else Ch (C) = ASCII.CR then Error := Find (Symbols, "HT, LF and CR characters not allowed"); return; elsif Ch (C) = ' ' and then C < Ch'last and then Ch (C + 1) = ' ' then Error := Find (Symbols, "Duplicate space characters not allowed"); return; end if; end loop; -- Leading or trailing white spaces are also forbidden if Ch'length /= 0 then if Ch (Ch'first) = ' ' then Error := Find (Symbols, "Leading whitespaces not allowed"); return; elsif Ch (Ch'last) = ' ' then Error := Find (Symbols, "Trailing whitespaces not allowed"); return; end if; end if; end case; end if; -- Type-specific facets case Descr.Kind is when primitive_string => Error := Validate_String (Descr, Symbols, Ch); when primitive_hexbinary => Error := Validate_HexBinary (Descr, Symbols, Ch); when primitive_notation => Error := Validate_Notation (Notations, Descr, Symbols, Ch); when primitive_base64binary => Error := Validate_Base64Binary (Descr, Symbols, Ch); when primitive_language => Error := Validate_Language (Descr, Symbols, Ch); when primitive_qname => Error := Validate_QName (Descr, Symbols, Ch, XML_Version); when primitive_ncname => Error := Validate_NCName (Descr, Symbols, Ch, XML_Version); when primitive_id => Error := Validate_NCName (Descr, Symbols, Ch, XML_Version); if Error = No_Symbol and then Insert_Id then Check_Id (Symbols, Id_Table, Ch, Error); end if; when primitive_ncnames => Error := Validate_NCNames (Descr, Symbols, Ch, XML_Version); when primitive_name => Error := Validate_Name (Descr, Symbols, Ch, XML_Version); when primitive_any_uri => Error := Validate_URI (Descr, Symbols, Ch); when primitive_nmtoken => Error := Validate_NMTOKEN (Descr, Symbols, Ch, XML_Version); when primitive_nmtokens => Error := Validate_NMTOKENS (Descr, Symbols, Ch, XML_Version); when primitive_boolean => Error := Validate_Boolean (Descr, Symbols, Ch); when primitive_decimal => Error := Validate_Decimal (Descr, Symbols, Ch); when primitive_float | primitive_double => Error := Validate_Double (Descr, Symbols, Ch); when primitive_time => Error := Validate_Time (Descr, Symbols, Ch); when primitive_datetime => Error := Validate_Date_Time (Descr, Symbols, Ch); when primitive_gday => Error := Validate_GDay (Descr, Symbols, Ch); when primitive_gmonthday => Error := Validate_GMonth_Day (Descr, Symbols, Ch); when primitive_gmonth => Error := Validate_GMonth (Descr, Symbols, Ch); when primitive_gyearmonth => Error := Validate_GYear_Month (Descr, Symbols, Ch); when primitive_gyear => Error := Validate_GYear (Descr, Symbols, Ch); when primitive_date => Error := Validate_Date (Descr, Symbols, Ch); when primitive_duration => Error := Validate_Duration (Descr, Symbols, Ch); when primitive_union => for S in Descr.Union'range loop if Descr.Union (S) /= No_Simple_Type_Index then Validate_Simple_Type (Simple_Types => Simple_Types, Enumerations => Enumerations, Symbols => Symbols, Notations => Notations, Id_Table => Id_Table, Simple_Type => Descr.Union (S), Ch => Ch, Error => Error, XML_Version => XML_Version); if Error = No_Symbol then return; else if Debug then Debug_Output ("Checking union at index" & S'img & " => " & Get (Error).all); end if; end if; end if; end loop; Error := Find (Symbols, "No matching type in the union"); when primitive_list => Validate_List_Items (Ch); if Error = No_Symbol then Error := Validate_List_Facets (Descr, Symbols, Ch, Descr.List_Length, Descr.List_Min_Length, Descr.List_Max_Length); end if; end case; end Validate_Simple_Type; -------------------------- -- HexBinary_Get_Length -- -------------------------- function HexBinary_Get_Length (Value : Unicode.CES.byte_sequence) return Natural is begin return Sax.Encodings.Encoding.Length (Value) / 2; end HexBinary_Get_Length; ----------------------------- -- Base64Binary_Get_Length -- ----------------------------- function Base64Binary_Get_Length (Value : Unicode.CES.byte_sequence) return Natural is Length : Natural := 0; C : unicode_char; Index : Positive := Value'first; begin while Index <= Value'last loop Sax.Encodings.Encoding.Read (Value, Index, C); if C /= 16#20# and then C /= 16#A# and then C /= Character'pos ('=') then Length := Length + 1; end if; end loop; return Length * 3 / 4; end Base64Binary_Get_Length; ---------------------- -- Validate_NMTOKEN -- ---------------------- function Validate_NMTOKEN (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence; XML_Version : xml_versions) return symbol is begin if not Is_Valid_Nmtoken (Ch, XML_Version) then return Find (Symbols, "Invalid NMTOKEN: """ & Ch & """"); end if; return Validate_String (Descr, Symbols, Ch); end Validate_NMTOKEN; ----------------------- -- Validate_NMTOKENS -- ----------------------- function Validate_NMTOKENS (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence; XML_Version : xml_versions) return symbol is begin if not Is_Valid_Nmtokens (Ch, XML_Version) then return Find (Symbols, "Invalid NMTOKENS: """ & Ch & """"); end if; return Validate_List_Facets (Descr, Symbols, Ch, Descr.String_Length, Descr.String_Min_Length, Descr.String_Max_Length); end Validate_NMTOKENS; ------------------- -- Validate_Name -- ------------------- function Validate_Name (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence; XML_Version : xml_versions) return symbol is begin if not Is_Valid_Name (Ch, XML_Version) then return Find (Symbols, "Invalid Name: """ & Ch & """"); end if; return Validate_String (Descr, Symbols, Ch); end Validate_Name; --------------------- -- Validate_NCName -- --------------------- function Validate_NCName (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence; XML_Version : xml_versions) return symbol is begin if not Is_Valid_NCname (Ch, XML_Version) then return Find (Symbols, "Invalid NCName: """ & Ch & """"); end if; return Validate_String (Descr, Symbols, Ch); end Validate_NCName; ---------------------- -- Validate_NCNames -- ---------------------- function Validate_NCNames (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence; XML_Version : xml_versions) return symbol is begin if not Is_Valid_NCnames (Ch, XML_Version) then return Find (Symbols, "Invalid NCName: """ & Ch & """"); end if; return Validate_List_Facets (Descr, Symbols, Ch, Descr.String_Length, Descr.String_Min_Length, Descr.String_Max_Length); end Validate_NCNames; ----------------------- -- Validate_Language -- ----------------------- function Validate_Language (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol is begin if not Is_Valid_Language_Name (Ch) then return Find (Symbols, "Invalid language: """ & Ch & """"); end if; return Validate_String (Descr, Symbols, Ch); end Validate_Language; -------------------- -- Validate_QName -- -------------------- function Validate_QName (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence; XML_Version : xml_versions) return symbol is begin if not Is_Valid_QName (Ch, XML_Version) then return Find (Symbols, "Invalid QName: """ & Ch & """"); end if; return Validate_String (Descr, Symbols, Ch); end Validate_QName; ------------------ -- Validate_URI -- ------------------ function Validate_URI (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol is begin if not Is_Valid_URI (Ch) then return Find (Symbols, "Invalid anyURI: """ & Ch & """"); end if; return Validate_String (Descr, Symbols, Ch); end Validate_URI; --------------------- -- Validate_String -- --------------------- function Validate_String (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol is function Internal_Facets is new Validate_Length_Facets (Encoding.Length.all); begin return Internal_Facets (Symbols, Ch, Descr.Mask, Descr.String_Length, Descr.String_Min_Length, Descr.String_Max_Length); end Validate_String; ----------------------- -- Validate_Notation -- ----------------------- function Validate_Notation (Notations : Symbol_Htable.htable; Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol is Error : symbol; begin Error := Validate_String (Descr, Symbols, Ch); if Error /= No_Symbol then return Error; end if; if Symbol_Htable.Get (Notations, Find (Symbols, Ch)) = No_Symbol then Error := Find (Symbols, "NOTATION """ & Ch & """ undefined in this document"); end if; return Error; end Validate_Notation; ------------------------ -- Validate_HexBinary -- ------------------------ function Validate_HexBinary (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol is begin if Encoding.Length (Ch) mod 2 /= 0 then return Find (Symbols, "HexBinary length must be an even number of characters"); end if; if not Is_Valid_HexBinary (Ch) then return Find (Symbols, "Invalid hexBinary: """ & Ch & """"); end if; return Validate_HexBinary_Facets (Symbols, Ch, Descr.Mask, Descr.String_Length, Descr.String_Min_Length, Descr.String_Max_Length); end Validate_HexBinary; --------------------------- -- Validate_Base64Binary -- --------------------------- function Validate_Base64Binary (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol is begin if not Is_Valid_Base64Binary (Ch) then return Find (Symbols, "Invalid base64Binary: """ & Ch & """"); end if; return Validate_Base64Binary_Facets (Symbols, Ch, Descr.Mask, Descr.String_Length, Descr.String_Min_Length, Descr.String_Max_Length); end Validate_Base64Binary; -------------------------- -- Validate_List_Facets -- -------------------------- function Validate_List_Facets (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence; Length, Min_Length, Max_Length : Integer) return symbol is function List_Get_Length (Value : Unicode.CES.byte_sequence) return Natural; function List_Get_Length (Value : Unicode.CES.byte_sequence) return Natural is Length : Natural := 0; C : unicode_char; Index : Natural := Value'first; begin if Value = "" then return 0; end if; while Index <= Value'last loop Encoding.Read (Value, Index, C); while C = Unicode.Names.Basic_Latin.Space loop Length := Length + 1; Encoding.Read (Value, Index, C); end loop; end loop; return Length + 1; end List_Get_Length; L : Natural; begin if Descr.Mask (facet_length) or else Descr.Mask (facet_min_length) or else Descr.Mask (facet_max_length) then L := List_Get_Length (Ch); else return No_Symbol; end if; if Descr.Mask (facet_length) then if L /= Length then return Find (Symbols, "Invalid size, must have" & Integer'image (Length) & " items"); end if; end if; if Descr.Mask (facet_min_length) then if L < Min_Length then return Find (Symbols, "Not enough items, minimum number is" & Integer'image (Min_Length)); end if; end if; if Descr.Mask (facet_max_length) then if L > Max_Length then return Find (Symbols, "Too many items, maximum number is" & Integer'image (Max_Length)); end if; end if; return No_Symbol; end Validate_List_Facets; ------------------- -- Boolean_Value -- ------------------- procedure Boolean_Value (Symbols : symbol_table; Ch : byte_sequence; Val : out Boolean; Error : out symbol) is First : Integer; Index : Integer; C : unicode_char; begin Val := False; if Ch = "" then Error := Find (Symbols, "Invalid value for boolean type: """""); return; end if; -- Check we do have a valid boolean representation (skip leading spaces) First := Ch'first; while First <= Ch'last loop Index := First; Encoding.Read (Ch, First, C); exit when not Is_White_Space (C); end loop; if C = Digit_Zero or C = Digit_One then Val := C = Digit_One; if First <= Ch'last then Encoding.Read (Ch, First, C); end if; elsif Index + True_Sequence'length - 1 <= Ch'last and then Ch (Index .. Index + True_Sequence'length - 1) = True_Sequence then First := Index + True_Sequence'length; Val := True; elsif Index + False_Sequence'length - 1 <= Ch'last and then Ch (Index .. Index + False_Sequence'length - 1) = False_Sequence then First := Index + False_Sequence'length; Val := False; else Error := Find (Symbols, "Invalid value for boolean type: """ & Ch & """"); return; end if; -- Skip trailing spaces while First <= Ch'last loop Encoding.Read (Ch, First, C); if not Is_White_Space (C) then Error := Find (Symbols, "Invalid value for boolean type: """ & Ch & """"); return; end if; end loop; Error := No_Symbol; end Boolean_Value; ---------------------- -- Validate_Boolean -- ---------------------- function Validate_Boolean (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol is pragma unreferenced (Descr); Val : Boolean; Error : symbol; begin Boolean_Value (Symbols, Ch, Val, Error); if Error /= No_Symbol then return Error; end if; return No_Symbol; end Validate_Boolean; ----------- -- Value -- ----------- procedure Value (Symbols : symbol_table; Ch : byte_sequence; Val : out xml_float; Error : out symbol) is begin begin Val := Value (Ch); exception when Constraint_Error => Error := Find (Symbols, "Invalid value: """ & Ch & """"); return; end; Error := No_Symbol; end Value; -------------------- -- Validate_Range -- -------------------- procedure Validate_Range (Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence; Mask : facets_mask; Min_Inclusive : t; Min_Exclusive : t; Max_Inclusive : t; Max_Exclusive : t; Error : out symbol; Val : out t) is begin Value (Symbols => Symbols, Ch => Ch, Val => Val, Error => Error); if Error /= No_Symbol then return; end if; if Mask (facet_min_inclusive) then if Val < Min_Inclusive then Error := Find (Symbols, Ch & " is smaller than minInclusive (" & Image (Min_Inclusive) & ")"); return; end if; end if; if Mask (facet_min_exclusive) then if Val <= Min_Exclusive then Error := Find (Symbols, Ch & " is smaller than minExclusive (" & Image (Min_Exclusive) & ")"); return; end if; end if; if Mask (facet_max_inclusive) then if Max_Inclusive < Val then Error := Find (Symbols, Ch & " is greater than maxInclusive (" & Image (Max_Inclusive) & ")"); return; end if; end if; if Mask (facet_max_exclusive) then if Max_Exclusive <= Val then Error := Find (Symbols, Ch & " is greater than maxExclusive (" & Image (Max_Exclusive) & ")"); return; end if; end if; end Validate_Range; procedure Validate_Double_Facets is new Validate_Range (xml_float); procedure Validate_Decimal_Facets is new Validate_Range (arbitrary_precision_number, Value => Value_No_Exponent); procedure Validate_Duration_Facets is new Validate_Range (duration_t); procedure Validate_Date_Time_Facets is new Validate_Range (date_time_t); procedure Validate_Date_Facets is new Validate_Range (date_t); procedure Validate_Time_Facets is new Validate_Range (time_t); procedure Validate_GDay_Facets is new Validate_Range (gday_t); procedure Validate_GMonth_Day_Facets is new Validate_Range (gmonth_day_t); procedure Validate_GMonth_Facets is new Validate_Range (gmonth_t); procedure Validate_GYear_Facets is new Validate_Range (gyear_t); procedure Validate_GYear_Month_Facets is new Validate_Range (gyear_month_t); --------------------- -- Validate_Double -- --------------------- function Validate_Double (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol is Val : xml_float; Error : symbol; begin Validate_Double_Facets (Symbols, Ch, Descr.Mask, Descr.Float_Min_Inclusive, Descr.Float_Min_Exclusive, Descr.Float_Max_Inclusive, Descr.Float_Max_Exclusive, Error, Val); return Error; end Validate_Double; ----------------------- -- Validate_Duration -- ----------------------- function Validate_Duration (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol is Val : duration_t; Error : symbol; begin Validate_Duration_Facets (Symbols, Ch, Descr.Mask, Descr.Duration_Min_Inclusive, Descr.Duration_Min_Exclusive, Descr.Duration_Max_Inclusive, Descr.Duration_Max_Exclusive, Error, Val); return Error; end Validate_Duration; ------------------------ -- Validate_Date_Time -- ------------------------ function Validate_Date_Time (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol is Val : date_time_t; Error : symbol; begin Validate_Date_Time_Facets (Symbols, Ch, Descr.Mask, Descr.DateTime_Min_Inclusive, Descr.DateTime_Min_Exclusive, Descr.DateTime_Max_Inclusive, Descr.DateTime_Max_Exclusive, Error, Val); return Error; end Validate_Date_Time; ------------------- -- Validate_Date -- ------------------- function Validate_Date (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol is Val : date_t; Error : symbol; begin Validate_Date_Facets (Symbols, Ch, Descr.Mask, Descr.Date_Min_Inclusive, Descr.Date_Min_Exclusive, Descr.Date_Max_Inclusive, Descr.Date_Max_Exclusive, Error, Val); return Error; end Validate_Date; ------------------- -- Validate_Time -- ------------------- function Validate_Time (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol is Val : time_t; Error : symbol; begin Validate_Time_Facets (Symbols, Ch, Descr.Mask, Descr.Time_Min_Inclusive, Descr.Time_Min_Exclusive, Descr.Time_Max_Inclusive, Descr.Time_Max_Exclusive, Error, Val); return Error; end Validate_Time; ------------------- -- Validate_GDay -- ------------------- function Validate_GDay (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol is Val : gday_t; Error : symbol; begin Validate_GDay_Facets (Symbols, Ch, Descr.Mask, Descr.GDay_Min_Inclusive, Descr.GDay_Min_Exclusive, Descr.GDay_Max_Inclusive, Descr.GDay_Max_Exclusive, Error, Val); return Error; end Validate_GDay; ------------------------- -- Validate_GMonth_Day -- ------------------------- function Validate_GMonth_Day (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol is Val : gmonth_day_t; Error : symbol; begin Validate_GMonth_Day_Facets (Symbols, Ch, Descr.Mask, Descr.GMonthDay_Min_Inclusive, Descr.GMonthDay_Min_Exclusive, Descr.GMonthDay_Max_Inclusive, Descr.GMonthDay_Max_Exclusive, Error, Val); return Error; end Validate_GMonth_Day; --------------------- -- Validate_GMonth -- --------------------- function Validate_GMonth (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol is Val : gmonth_t; Error : symbol; begin Validate_GMonth_Facets (Symbols, Ch, Descr.Mask, Descr.GMonth_Min_Inclusive, Descr.GMonth_Min_Exclusive, Descr.GMonth_Max_Inclusive, Descr.GMonth_Max_Exclusive, Error, Val); return Error; end Validate_GMonth; -------------------- -- Validate_GYear -- -------------------- function Validate_GYear (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol is Val : gyear_t; Error : symbol; begin Validate_GYear_Facets (Symbols, Ch, Descr.Mask, Descr.GYear_Min_Inclusive, Descr.GYear_Min_Exclusive, Descr.GYear_Max_Inclusive, Descr.GYear_Max_Exclusive, Error, Val); return Error; end Validate_GYear; -------------------------- -- Validate_GYear_Month -- -------------------------- function Validate_GYear_Month (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol is Val : gyear_month_t; Error : symbol; begin Validate_GYear_Month_Facets (Symbols, Ch, Descr.Mask, Descr.GYearMonth_Min_Inclusive, Descr.GYearMonth_Min_Exclusive, Descr.GYearMonth_Max_Inclusive, Descr.GYearMonth_Max_Exclusive, Error, Val); return Error; end Validate_GYear_Month; ---------------------- -- Validate_Decimal -- ---------------------- function Validate_Decimal (Descr : simple_type_descr; Symbols : Sax.Utils.symbol_table; Ch : Unicode.CES.byte_sequence) return symbol is Error : symbol; Val : arbitrary_precision_number; begin Validate_Decimal_Facets (Symbols, Ch, Descr.Mask, Descr.Decimal_Min_Inclusive, Descr.Decimal_Min_Exclusive, Descr.Decimal_Max_Inclusive, Descr.Decimal_Max_Exclusive, Error, Val); if Error /= No_Symbol then return Error; end if; return Check_Digits (Symbols => Symbols, Num => Val, Fraction_Digits => Descr.Fraction_Digits, Total_Digits => Descr.Total_Digits); end Validate_Decimal; -------------------- -- Convert_Regexp -- -------------------- function Convert_Regexp (Regexp : Unicode.CES.byte_sequence) return String is Result : Unbounded_String; Tmp : Unbounded_String; Pos : Integer := Regexp'first; C : Character; function Next_Char return Character; -- Read the next char from the regexp, and check it is ASCII function Next_Char return Character is Char : unicode_char; begin Encoding.Read (Regexp, Pos, Char); if Char > 127 then Raise_Exception (XML_Not_Implemented'identity, "Unicode regexps are not supported"); end if; return Character'val (Integer (Char)); end Next_Char; begin while Pos <= Regexp'last loop C := Next_Char; if C = '[' then Append (Result, C); Tmp := Null_Unbounded_String; while Pos <= Regexp'last loop C := Next_Char; if C = ']' then Append (Tmp, C); exit; elsif C = '\' and then Pos <= Regexp'last then C := Next_Char; case C is when 'i' => -- rule [99] in XMLSchema specifications Append (Tmp, "A-Za-z:_"); when 'c' => Append (Tmp, "a-z:A-Z0-9._-"); when 'w' => Append (Tmp, "a-zA-Z0-9`"); when 'I' | 'C' | '?' => Raise_Exception (XML_Not_Implemented'identity, "Unsupported regexp construct: \" & C); when 'P' | 'p' => if Pos <= Regexp'last and then Regexp (Pos) = '{' then Raise_Exception (XML_Not_Implemented'identity, "Unsupported regexp construct: \P{...}"); else Append (Tmp, '\' & C); end if; when others => Append (Tmp, '\' & C); end case; else if C = '-' and then Pos <= Regexp'last and then Regexp (Pos) = '[' then Raise_Exception (XML_Not_Implemented'identity, "Unsupported regexp construct: [...-[...]]"); end if; Append (Tmp, C); end if; end loop; Append (Result, Tmp); -- ??? Some tests in the old w3c testsuite seem to imply that -- \c and \i are valid even outside character classes. Not sure about -- this though elsif C = '\' and then Pos <= Regexp'last then C := Next_Char; case C is when 'i' => -- rule [99] in XMLSchema specifications Append (Result, "[A-Za-z:_]"); when 'c' => Append (Result, "[a-z:A-Z0-9._-]"); when 'w' => Append (Result, "[a-zA-Z0-9`]"); when 'I' | 'C' => Raise_Exception (XML_Not_Implemented'identity, "Unsupported regexp construct: \" & C); when 'P' | 'p' => if Pos <= Regexp'last and then Regexp (Pos) = '{' then Raise_Exception (XML_Not_Implemented'identity, "Unsupported regexp construct: \P{...}"); else Append (Result, '\' & C); end if; when others => Append (Result, '\' & C); end case; else Append (Result, C); end if; end loop; return Anchor (To_String (Result)); end Convert_Regexp; ------------------------ -- Missing_End_Anchor -- ------------------------ function Missing_End_Anchor (Str : String) return Boolean is begin -- Do not add '$' if Str ends with a single \, since it is -- invalid anyway return Str'length = 0 or else (Str (Str'last) /= '$' and then (Str (Str'last) /= '\' or else (Str'length /= 1 and then Str (Str'last - 1) = '\'))); end Missing_End_Anchor; -------------------------- -- Missing_Start_Anchor -- -------------------------- function Missing_Start_Anchor (Str : String) return Boolean is begin -- Do not add '^' if we start with an operator, since Str is invalid return Str'length = 0 or else not (Str (Str'first) = '^' or else Str (Str'first) = '*' or else Str (Str'first) = '+' or else Str (Str'first) = '?'); end Missing_Start_Anchor; ------------ -- Anchor -- ------------ function Anchor (Str : String) return String is Start : constant Boolean := Missing_Start_Anchor (Str); Last : constant Boolean := Missing_End_Anchor (Str); begin if Start and Last then return "^(" & Str & ")$"; elsif Start then return "^" & Str; elsif Last then return Str & "$"; else return Str; end if; end Anchor; --------------- -- Add_Facet -- --------------- procedure Add_Facet (Facets : in out all_facets; Symbols : Sax.Utils.symbol_table; Enumerations : in out Enumeration_Tables.instance; Facet_Name : Sax.Symbols.symbol; Value : Sax.Symbols.symbol; Loc : Sax.Locators.location) is Val : symbol; begin if Get (Facet_Name).all = "pattern" then -- Do not normalize the value if Facets (facet_pattern).Value /= No_Symbol then Facets (facet_pattern) := (Find (Symbols, '(' & Get (Facets (facet_pattern).Value).all & ")|(" & Get (Value).all & ')'), No_Enumeration_Index, Loc); else Facets (facet_pattern) := (Value, No_Enumeration_Index, Loc); end if; return; end if; Val := Find (Symbols, Trim (Get (Value).all, Ada.Strings.Both)); if Get (Facet_Name).all = "whiteSpace" then Facets (facet_whitespace) := (Val, No_Enumeration_Index, Loc); elsif Get (Facet_Name).all = "enumeration" then Append (Enumerations, (Value => Val, Next => Facets (facet_enumeration).Enum)); Facets (facet_enumeration) := (No_Symbol, Last (Enumerations), Loc); elsif Get (Facet_Name).all = "minInclusive" then Facets (facet_min_inclusive) := (Val, No_Enumeration_Index, Loc); elsif Get (Facet_Name).all = "maxInclusive" then Facets (facet_max_inclusive) := (Val, No_Enumeration_Index, Loc); elsif Get (Facet_Name).all = "minExclusive" then Facets (facet_min_exclusive) := (Val, No_Enumeration_Index, Loc); elsif Get (Facet_Name).all = "maxExclusive" then Facets (facet_max_exclusive) := (Val, No_Enumeration_Index, Loc); elsif Get (Facet_Name).all = "length" then Facets (facet_length) := (Val, No_Enumeration_Index, Loc); elsif Get (Facet_Name).all = "minLength" then Facets (facet_min_length) := (Val, No_Enumeration_Index, Loc); elsif Get (Facet_Name).all = "maxLength" then Facets (facet_max_length) := (Val, No_Enumeration_Index, Loc); elsif Get (Facet_Name).all = "totalDigits" then Facets (facet_total_digits) := (Val, No_Enumeration_Index, Loc); elsif Get (Facet_Name).all = "fractionDigits" then Facets (facet_fraction_digits) := (Val, No_Enumeration_Index, Loc); else pragma assert (False, "Invalid facet:"); null; end if; end Add_Facet; --------------------------------- -- Override_Single_Range_Facet -- --------------------------------- procedure Override_Single_Range_Facet (Symbols : Sax.Utils.symbol_table; Facets : all_facets; Facet : facet_enum; Mask : in out facets_mask; Val : in out t; Error : in out symbol; Error_Loc : in out location) is begin if Error = No_Symbol and then Facets (Facet) /= No_Facet_Value then Value (Symbols, Ch => Get (Facets (Facet).Value).all, Val => Val, Error => Error); if Error /= No_Symbol then Error_Loc := Facets (Facet).Loc; else Mask (Facet) := True; end if; end if; end Override_Single_Range_Facet; --------------------------- -- Override_Range_Facets -- --------------------------- procedure Override_Range_Facets (Symbols : Sax.Utils.symbol_table; Facets : all_facets; Mask : in out facets_mask; Min_Inclusive : in out t; Min_Exclusive : in out t; Max_Inclusive : in out t; Max_Exclusive : in out t; Error : out symbol; Error_Loc : out location) is procedure Do_Override is new Override_Single_Range_Facet (t, Value); begin Do_Override (Symbols, Facets, facet_max_inclusive, Mask, Max_Inclusive, Error, Error_Loc); Do_Override (Symbols, Facets, facet_max_exclusive, Mask, Max_Exclusive, Error, Error_Loc); Do_Override (Symbols, Facets, facet_min_inclusive, Mask, Min_Inclusive, Error, Error_Loc); Do_Override (Symbols, Facets, facet_min_exclusive, Mask, Min_Exclusive, Error, Error_Loc); end Override_Range_Facets; procedure Override_Decimal_Facets is new Override_Range_Facets (arbitrary_precision_number); procedure Override_Float_Facets is new Override_Range_Facets (xml_float); procedure Override_Duration_Facets is new Override_Range_Facets (duration_t); procedure Override_Date_Time_Facets is new Override_Range_Facets (date_time_t); procedure Override_Date_Facets is new Override_Range_Facets (date_t); procedure Override_Time_Facets is new Override_Range_Facets (time_t); procedure Override_GDay_Facets is new Override_Range_Facets (gday_t); procedure Override_GMonth_Day_Facets is new Override_Range_Facets (gmonth_day_t); procedure Override_GMonth_Facets is new Override_Range_Facets (gmonth_t); procedure Override_GYear_Facets is new Override_Range_Facets (gyear_t); procedure Override_GYear_Month_Facets is new Override_Range_Facets (gyear_month_t); ---------------------------- -- Override_Length_Facets -- ---------------------------- procedure Override_Length_Facets (Symbols : Sax.Utils.symbol_table; Facets : all_facets; Mask : in out facets_mask; Length : in out Integer; Min_Length : in out Integer; Max_Length : in out Integer; Error : out symbol; Error_Loc : out location) is begin if Facets (facet_length) /= No_Facet_Value then begin Length := Natural'value (Get (Facets (facet_length).Value).all); Mask (facet_length) := True; exception when Constraint_Error => Error := Find (Symbols, "Expecting integer for length facet"); Error_Loc := Facets (facet_length).Loc; end; end if; if Facets (facet_min_length) /= No_Facet_Value then begin Min_Length := Natural'value (Get (Facets (facet_min_length).Value).all); Mask (facet_min_length) := True; exception when Constraint_Error => Error := Find (Symbols, "Expecting integer for minLength facet"); Error_Loc := Facets (facet_min_length).Loc; end; end if; if Facets (facet_max_length) /= No_Facet_Value then begin Max_Length := Natural'value (Get (Facets (facet_max_length).Value).all); Mask (facet_max_length) := True; exception when Constraint_Error => Error := Find (Symbols, "Expecting integer for maxlength facet"); Error_Loc := Facets (facet_max_length).Loc; end; end if; end Override_Length_Facets; -------------- -- Override -- -------------- procedure Override (Simple : in out simple_type_descr; Facets : all_facets; Symbols : Sax.Utils.symbol_table; As_Restriction : Boolean; Error : out Sax.Symbols.symbol; Error_Loc : out Sax.Locators.location) is function Compile_Regexp (Str : symbol) return pattern_matcher_access; function Compile_Regexp (Str : symbol) return pattern_matcher_access is Convert : constant String := Convert_Regexp (Get (Str).all); begin if Debug then Debug_Output ("Compiling regexp as " & Convert); end if; return new Pattern_Matcher'(Compile (Convert)); exception when GNAT.Regpat.Expression_Error => Error_Loc := Facets (facet_pattern).Loc; Error := Find (Symbols, "Invalid regular expression " & Get (Str).all & " (converted to " & Convert & ")"); return null; end Compile_Regexp; Val : symbol; Tmp : pattern_matcher_array_access; begin if Facets (facet_whitespace) /= No_Facet_Value then Val := Facets (facet_whitespace).Value; if Get (Val).all = "preserve" then Simple.Whitespace := preserve; elsif Get (Val).all = "replace" then Simple.Whitespace := replace; elsif Get (Val).all = "collapse" then Simple.Whitespace := collapse; else Error_Loc := Facets (facet_whitespace).Loc; Error := Find (Symbols, "Invalid value for whiteSpace facet: " & Get (Val).all); return; end if; Simple.Mask (facet_whitespace) := True; end if; if Facets (facet_pattern) /= No_Facet_Value then Val := Facets (facet_pattern).Value; begin if As_Restriction then -- We must match all patterns (from base and from extension), -- and we cannot combine them. So we need to add one more -- pattern to the facets. -- [Simple] is a copy of the base type, and will be the new -- restriction on exit. if Simple.Pattern = null then Simple.Pattern := new pattern_matcher_array (1 .. 1); else Tmp := Simple.Pattern; Simple.Pattern := new pattern_matcher_array (Tmp'first .. Tmp'last + 1); Simple.Pattern (Tmp'range) := Tmp.all; Unchecked_Free (Tmp); end if; Simple.Pattern (Simple.Pattern'last) := (Str => Val, Pattern => Compile_Regexp (Val)); else -- We must combine the base's patterns with the extension's -- pattern, since the type must match either of those. -- The number of patterns does not change if Simple.Pattern = null then Simple.Pattern := new pattern_matcher_array' (1 => (Str => Val, Pattern => Compile_Regexp (Val))); else for P in Simple.Pattern'range loop Simple.Pattern (P).Str := Find (Symbols, '(' & Get (Simple.Pattern (P).Str).all & ")|(" & Get (Val).all & ')'); Unchecked_Free (Simple.Pattern (P).Pattern); Simple.Pattern (P).Pattern := Compile_Regexp (Simple.Pattern (P).Str); end loop; end if; end if; exception when E : XML_Not_Implemented => Error := Find (Symbols, '#' & Exception_Message (E)); Free (Simple.Pattern); end; if Error /= No_Symbol then Error_Loc := Facets (facet_pattern).Loc; return; end if; Simple.Mask (facet_pattern) := True; end if; if Facets (facet_enumeration) /= No_Facet_Value then Simple.Enumeration := Facets (facet_enumeration).Enum; Simple.Mask (facet_enumeration) := True; end if; Error := No_Symbol; case Simple.Kind is when primitive_union => null; when primitive_list => Override_Length_Facets (Symbols, Facets, Simple.Mask, Simple.List_Length, Simple.List_Min_Length, Simple.List_Max_Length, Error, Error_Loc); when primitive_string .. primitive_hexbinary => Override_Length_Facets (Symbols, Facets, Simple.Mask, Simple.String_Length, Simple.String_Min_Length, Simple.String_Max_Length, Error, Error_Loc); when primitive_boolean => null; when primitive_float | primitive_double => Override_Float_Facets (Symbols, Facets, Simple.Mask, Simple.Float_Min_Inclusive, Simple.Float_Min_Exclusive, Simple.Float_Max_Inclusive, Simple.Float_Max_Exclusive, Error, Error_Loc); when primitive_decimal => Override_Decimal_Facets (Symbols, Facets, Simple.Mask, Simple.Decimal_Min_Inclusive, Simple.Decimal_Min_Exclusive, Simple.Decimal_Max_Inclusive, Simple.Decimal_Max_Exclusive, Error, Error_Loc); if Error = No_Symbol then if Facets (facet_total_digits) /= No_Facet_Value then begin Simple.Total_Digits := Positive'value (Get (Facets (facet_total_digits).Value).all); Simple.Mask (facet_total_digits) := True; exception when Constraint_Error => Error := Find (Symbols, "Expecting integer for totalDigits facet"); Error_Loc := Facets (facet_total_digits).Loc; end; end if; if Facets (facet_fraction_digits) /= No_Facet_Value then begin Simple.Fraction_Digits := Natural'value (Get (Facets (facet_fraction_digits).Value).all); Simple.Mask (facet_fraction_digits) := True; exception when Constraint_Error => Error := Find (Symbols, "Expecting integer for fractionDigits facet"); Error_Loc := Facets (facet_fraction_digits).Loc; end; end if; if Simple.Fraction_Digits /= Natural'last and then Simple.Total_Digits /= Positive'last and then Simple.Fraction_Digits > Simple.Total_Digits then Error_Loc := Facets (facet_fraction_digits).Loc; Error := Find (Symbols, "fractionDigits cannot be greater than totalDigits"); end if; end if; when primitive_time => Override_Time_Facets (Symbols, Facets, Simple.Mask, Simple.Time_Min_Inclusive, Simple.Time_Min_Exclusive, Simple.Time_Max_Inclusive, Simple.Time_Max_Exclusive, Error, Error_Loc); when primitive_datetime => Override_Date_Time_Facets (Symbols, Facets, Simple.Mask, Simple.DateTime_Min_Inclusive, Simple.DateTime_Min_Exclusive, Simple.DateTime_Max_Inclusive, Simple.DateTime_Max_Exclusive, Error, Error_Loc); when primitive_gday => Override_GDay_Facets (Symbols, Facets, Simple.Mask, Simple.GDay_Min_Inclusive, Simple.GDay_Min_Exclusive, Simple.GDay_Max_Inclusive, Simple.GDay_Max_Exclusive, Error, Error_Loc); when primitive_gmonthday => Override_GMonth_Day_Facets (Symbols, Facets, Simple.Mask, Simple.GMonthDay_Min_Inclusive, Simple.GMonthDay_Min_Exclusive, Simple.GMonthDay_Max_Inclusive, Simple.GMonthDay_Max_Exclusive, Error, Error_Loc); when primitive_gmonth => Override_GMonth_Facets (Symbols, Facets, Simple.Mask, Simple.GMonth_Min_Inclusive, Simple.GMonth_Min_Exclusive, Simple.GMonth_Max_Inclusive, Simple.GMonth_Max_Exclusive, Error, Error_Loc); when primitive_gyearmonth => Override_GYear_Month_Facets (Symbols, Facets, Simple.Mask, Simple.GYearMonth_Min_Inclusive, Simple.GYearMonth_Min_Exclusive, Simple.GYearMonth_Max_Inclusive, Simple.GYearMonth_Max_Exclusive, Error, Error_Loc); when primitive_gyear => Override_GYear_Facets (Symbols, Facets, Simple.Mask, Simple.GYear_Min_Inclusive, Simple.GYear_Min_Exclusive, Simple.GYear_Max_Inclusive, Simple.GYear_Max_Exclusive, Error, Error_Loc); when primitive_date => Override_Date_Facets (Symbols, Facets, Simple.Mask, Simple.Date_Min_Inclusive, Simple.Date_Min_Exclusive, Simple.Date_Max_Inclusive, Simple.Date_Max_Exclusive, Error, Error_Loc); when primitive_duration => Override_Duration_Facets (Symbols, Facets, Simple.Mask, Simple.Duration_Min_Inclusive, Simple.Duration_Min_Exclusive, Simple.Duration_Max_Inclusive, Simple.Duration_Max_Exclusive, Error, Error_Loc); end case; -- ??? Should detect unused facets and report errors end Override; -------------------------- -- Normalize_Whitespace -- -------------------------- procedure Normalize_Whitespace (Whitespace : Schema.Simple_Types.whitespace_restriction; Val : in out Unicode.CES.byte_sequence; Last : in out Natural) is begin case Whitespace is when preserve => return; -- Nothing to do when replace => declare Idx : Natural := Val'first; First : Natural := Last + 1; C : unicode_char; begin while Idx <= Last loop First := Idx; Encoding.Read (Val, Idx, C); if Is_White_Space (C) then -- Assumes all characters we replace are encoded as -- single byte Val (First) := ' '; end if; end loop; -- Length of string does not change end; when collapse => if Val = "" then return; -- nothing to do end if; declare C : unicode_char; Idx, Idx_Output : Natural := Val'first; First : Natural := Last + 1; Tmp : Natural; Last_Space : Natural := Last + 1; Prev_Is_Whitespace : Boolean := False; begin -- Remove leading spaces. loop First := Idx; Encoding.Read (Val, Idx, C); exit when not Is_White_Space (C); if Idx > Last then Last := 0; return; -- Empty string end if; end loop; if First /= Val'first then Val (Val'first .. Last - First + Val'first) := Val (First .. Last); Last := Last - First + Val'first; end if; Idx := Val'first; Idx_Output := Val'first; -- Iterate and replace all whitespaces. Mark the spot of the -- last whitespace so that we can ignore trailing spaces. -- At the same time, we can copy to Idx_Output, since the -- output string will always be at least as short as Val. while Idx <= Last loop Tmp := Idx; Encoding.Read (Val, Idx, C); -- Copy, if needed, the character we just read if Is_White_Space (C) then if not Prev_Is_Whitespace then Val (Idx_Output) := ' '; Last_Space := Idx_Output; Idx_Output := Idx_Output + 1; Prev_Is_Whitespace := True; end if; else Val (Idx_Output .. Idx_Output + Idx - Tmp - 1) := Val (Tmp .. Idx - 1); Idx_Output := Idx_Output + Idx - Tmp; Last_Space := Idx_Output; -- after this char Prev_Is_Whitespace := False; end if; end loop; -- Now skip trailing whitespaces if any Last := Last_Space - 1; end; end case; end Normalize_Whitespace; ---------- -- Copy -- ---------- function Copy (Descr : simple_type_descr) return simple_type_descr is Result : simple_type_descr := Descr; begin if Descr.Pattern /= null then Result.Pattern := new pattern_matcher_array (Descr.Pattern'range); for P in Descr.Pattern'range loop Result.Pattern (P) := (Str => Descr.Pattern (P).Str, Pattern => new Pattern_Matcher'(Descr.Pattern (P).Pattern.all)); end loop; end if; return Result; end Copy; ---------- -- Free -- ---------- procedure Free (Arr : in out pattern_matcher_array_access) is begin if Arr /= null then for A in Arr'range loop Unchecked_Free (Arr (A).Pattern); end loop; Unchecked_Free (Arr); end if; end Free; ------------- -- Get_Key -- ------------- function Get_Key (Id : symbol) return symbol is begin return Id; end Get_Key; ---------- -- Free -- ---------- procedure Free (Symbol_Table : in out symbol_htable_access) is procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Symbol_Htable.htable, symbol_htable_access); begin if Symbol_Table /= null then Symbol_Htable.Reset (Symbol_Table.all); Unchecked_Free (Symbol_Table); end if; end Free; -------------- -- Check_Id -- -------------- procedure Check_Id (Symbols : symbol_table; Id_Table : in out symbol_htable_access; Value : Unicode.CES.byte_sequence; Error : in out symbol) is Val : constant symbol := Find (Symbols, Value); begin if Id_Table = null then Id_Table := new Symbol_Htable.htable (101); else if Symbol_Htable.Get (Id_Table.all, Val) /= No_Symbol then Error := Find (Symbols, "ID """ & Value & """ already defined"); return; end if; end if; Symbol_Htable.Set (Id_Table.all, Val); Error := No_Symbol; end Check_Id; end Schema.Simple_Types;