------------------------------------------------------------------------------ -- XML/Ada - An XML suite for Ada95 -- -- -- -- Copyright (C) 2005-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 -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Handling; use Ada.Characters.Handling; package body Schema.Date_Time is procedure Parse (Symbols : symbol_table; Ch : String; Date : out date_nz_t; Eos : out Natural; Error : out symbol); procedure Parse (Symbols : symbol_table; Ch : String; Time : out time_nz_t; Eos : out Natural; Error : out symbol); procedure Parse (Symbols : symbol_table; Ch : String; TZ : out timezone_t; Error : out symbol); procedure Parse_Year (Symbols : symbol_table; Ch : String; Year : out Integer; Eos : out Natural; Error : out symbol); -- Parse the various components of dates. -- On exit, Eos is set to the first unused character in Ch, except for the -- timezone which must finish on the last character in Ch. -- The No_* parameter indicate that the corresponding part should not be -- found in Ch. function Image (Date : date_nz_t) return String; function Image (TZ : timezone_t) return String; function Image (Time : time_nz_t) return String; -- Return the string representation of the parameter. type compare_result is (less_than, equal, greater_than, uncomparable); function Compare (Time1, Time2 : date_time_t) return compare_result; function Compare (Date1, Date2 : date_nz_t) return compare_result; function Compare (Time1, Time2 : time_nz_t) return compare_result; function Compare (Duration1, Duration2 : duration_t) return compare_result; -- Compare the two parameters. The parameters must have been normalized -- prior to the call. Timezones are taken into account if present function To_Date_Time (Time : time_t) return date_time_t; function To_Date_Time (Date : date_t) return date_time_t; function To_Date_Time (Day : gday_t) return date_time_t; function To_Date_Time (Day : gmonth_day_t) return date_time_t; function To_Date_Time (Month : gmonth_t) return date_time_t; function To_Date_Time (Year : gyear_t) return date_time_t; function To_Date_Time (Month : gyear_month_t) return date_time_t; -- Convert the parameter to a Date_Time function Normalize (Date : date_time_t) return date_time_t; function Normalize (Duration : duration_t) return duration_t; -- Return a normalized version of Date, ie with a time zone of 0. There -- will be no time zone set for the result if Date has no timezone procedure Normalize (Date : in out date_nz_t); -- Make sure that the day is valid in the date. Otherwise, change the month -- and year until we end up on a valid day function Image (Value : Integer; Num_Digits : Natural := 2) return String; -- Return the image of Value, in a string of Num_Digits characters long function MS_Image (Sub_Second : day_range) return String; -- Return the image to use for milliseconds (nothing if 0, or the minimal -- number of digits) generic Field : Integer; Char : Character; function Component_Image return String; -- Return each component of the duration, in the format expected for -- durations. Nothing is returned if the matching component is -- null; function Max_Days_In_Month (Year, Month : Integer) return Integer; -- Return the maximum number of days in the given month. Month is -- allowed to be outside the range 1 .. 12 generic type t is private; with function Normalize (T1 : t) return t is <>; with function Compare (T1, T2 : t) return compare_result is <>; package Comparators is function "<" (T1, T2 : t) return Boolean; function "<=" (T1, T2 : t) return Boolean; function "=" (T1, T2 : t) return Boolean; function ">" (T1, T2 : t) return Boolean; function ">=" (T1, T2 : t) return Boolean; end Comparators; -- Generate the comparison functions for various types generic type t is private; with function To_Date_Time (T1 : t) return date_time_t is <>; package DT_Comparators is function "<" (T1, T2 : t) return Boolean; function "<=" (T1, T2 : t) return Boolean; function "=" (T1, T2 : t) return Boolean; function ">" (T1, T2 : t) return Boolean; function ">=" (T1, T2 : t) return Boolean; end DT_Comparators; ------------------ -- To_Date_Time -- ------------------ function To_Date_Time (Time : time_t) return date_time_t is begin return date_time_t'(No_Date_NZ, Time.Time, Time.TZ); end To_Date_Time; function To_Date_Time (Day : gday_t) return date_time_t is begin return date_time_t'((2001, 01, Day.Day), No_Time_NZ, Day.TZ); end To_Date_Time; function To_Date_Time (Day : gmonth_day_t) return date_time_t is begin return date_time_t'((2001, Day.Month, Day.Day), No_Time_NZ, Day.TZ); end To_Date_Time; function To_Date_Time (Month : gmonth_t) return date_time_t is begin return date_time_t'((2001, Month.Month, 1), No_Time_NZ, Month.TZ); end To_Date_Time; function To_Date_Time (Year : gyear_t) return date_time_t is begin return date_time_t'((Year.Year, 01, 15), No_Time_NZ, Year.TZ); end To_Date_Time; function To_Date_Time (Month : gyear_month_t) return date_time_t is begin return date_time_t'((Month.Year, Month.Month, 01), No_Time_NZ, Month.TZ); end To_Date_Time; function To_Date_Time (Date : date_t) return date_time_t is begin return date_time_t'(Date.Date, No_Time_NZ, Date.TZ); end To_Date_Time; ----------- -- Image -- ----------- function Image (Value : Integer; Num_Digits : Natural := 2) return String is Str : constant String := Integer'image (Value); Padding : constant String (1 .. Num_Digits) := (others => '0'); begin if Value < 0 then if Str'length - 1 > Num_Digits then -- No padding, return the whole string return Str; else return '-' & Padding (1 .. Num_Digits - Str'last + Str'first) & Str (Str'first + 1 .. Str'last); end if; else if Str'length - 1 > Num_Digits then return Str (Str'first + 1 .. Str'last); else return Padding (1 .. Num_Digits - Str'last + Str'first) & Str (Str'first + 1 .. Str'last); end if; end if; end Image; --------------------- -- Component_Image -- --------------------- function Component_Image return String is begin if Field = 0 then return ""; else return Image (abs (Field), 1) & Char; end if; end Component_Image; ----------- -- Image -- ----------- function Image (Date : date_nz_t) return String is begin return Image (Date.Year, 4) & '-' & Image (abs (Date.Month), 2) & '-' & Image (abs (Date.Day), 2); end Image; function Image (Day : gday_t) return String is begin return "---" & Image (Day.Day, 2) & Image (Day.TZ); end Image; function Image (Day : gmonth_day_t) return String is begin return "--" & Image (Day.Month, 2) & '-' & Image (Day.Day, 2) & Image (Day.TZ); end Image; function Image (Month : gmonth_t) return String is begin return "--" & Image (Month.Month, 2) & Image (Month.TZ); end Image; function Image (Year : gyear_t) return String is begin return Image (Year.Year, 4) & Image (Year.TZ); end Image; function Image (Month : gyear_month_t) return String is begin return Image (Month.Year, 4) & '-' & Image (Month.Month, 2) & Image (Month.TZ); end Image; function Image (Date : date_t) return String is begin return Image (Date.Date) & Image (Date.TZ); end Image; function Image (Date : date_time_t) return String is begin return Image (Date.Date) & 'T' & Image (Date.Time) & Image (Date.TZ); end Image; function Image (Time : time_t) return String is begin return Image (Time.Time) & Image (Time.TZ); end Image; -------------- -- MS_Image -- -------------- function MS_Image (Sub_Second : day_range) return String is Sub : constant String := day_range'image (Sub_Second); Last : Natural := Sub'last; begin if Sub_Second = 0.0 then return ""; else while Last >= Sub'first and Sub (Last) = '0' loop Last := Last - 1; end loop; -- Skip '0.' in the subseconds image return Sub (Sub'first + 2 .. Last); end if; end MS_Image; ----------- -- Image -- ----------- function Image (Time : time_nz_t) return String is Hour, Min, Secs : Natural; Sub_Second : time_nz_t; begin if Time = 0.0 then Secs := 0; else Secs := Natural (abs (Time) - 0.5); end if; Sub_Second := abs (Time) - time_nz_t (Secs); Hour := Integer (Secs / 3600); Secs := Secs mod 3600; Min := Integer (Secs / 60); Secs := Secs mod 60; return Image (Hour, 2) & ':' & Image (Min, 2) & ':' & Image (Secs, 2) & MS_Image (Sub_Second); end Image; ----------- -- Image -- ----------- function Image (Duration : duration_t) return String is Hour, Min, Secs : Natural; Sub_Second : time_nz_t; function Year_Image is new Component_Image (Duration.Year, 'Y'); function Month_Image is new Component_Image (Duration.Month, 'M'); function Day_Image is new Component_Image (Duration.Day, 'D'); function Secs_Image return String; function Secs_Image return String is Im : constant String := Image (Secs, 1) & MS_Image (Sub_Second) & 'S'; begin if Im /= "0S" then return Im; else return ""; end if; end Secs_Image; begin if Duration.Seconds = 0.0 then Secs := 0; else Secs := Natural (abs (Duration.Seconds) - 0.5); end if; Sub_Second := abs (Duration.Seconds) - time_nz_t (Secs); Hour := Integer (Secs / 3600); Secs := Secs mod 3600; Min := Integer (Secs / 60); Secs := Secs mod 60; declare function Hour_Image is new Component_Image (Hour, 'H'); function Min_Image is new Component_Image (Min, 'M'); Date_Img : constant String := Year_Image & Month_Image & Day_Image; Time_Img : constant String := Hour_Image & Min_Image & Secs_Image; begin if Duration.Sign < 0 then if Time_Img'length /= 0 then return "-P" & Date_Img & 'T' & Time_Img; else return "-P" & Date_Img; end if; else if Time_Img'length /= 0 then return 'P' & Date_Img & 'T' & Time_Img; else return 'P' & Date_Img; end if; end if; end; end Image; ----------- -- Image -- ----------- function Image (TZ : timezone_t) return String is begin if TZ = No_Timezone then return ""; elsif TZ = 0 then return "Z"; elsif TZ < 0 then return '-' & Image (abs (Integer (TZ)) / 60, 2) & ':' & Image (abs (Integer (TZ)) mod 60, 2); else return '+' & Image (abs (Integer (TZ)) / 60, 2) & ':' & Image (abs (Integer (TZ)) mod 60, 2); end if; end Image; ---------------- -- Parse_Year -- ---------------- procedure Parse_Year (Symbols : symbol_table; Ch : String; Year : out Integer; Eos : out Natural; Error : out symbol) is Pos : Integer := Ch'first; begin if Ch (Pos) = '-' then Pos := Pos + 1; end if; while Pos <= Ch'last and then Ch (Pos) /= '-' and then Ch (Pos) /= 'Z' loop Pos := Pos + 1; end loop; Year := Integer'value (Ch (Ch'first .. Pos - 1)); if Year = 0 then Error := Find (Symbols, "Year cannot be null in: """ & Ch & """"); Eos := Ch'last; return; elsif Pos - Ch'first < 4 then Error := Find (Symbols, "Year must include at least four digits"); return; end if; Eos := Pos; Error := No_Symbol; exception when Constraint_Error => Error := Find (Symbols, "Invalid year in """ & Ch & """"); Year := 0; Eos := Ch'last + 1; end Parse_Year; ----------- -- Parse -- ----------- procedure Parse (Symbols : symbol_table; Ch : String; Date : out date_nz_t; Eos : out Natural; Error : out symbol) is Max_Days : constant array (1 .. 12) of Natural := (31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31); Pos : Integer; Leap_Year : Boolean; begin Parse_Year (Symbols, Ch, Date.Year, Pos, Error); if Error /= No_Symbol then Eos := Ch'first; return; end if; if Ch (Pos) /= '-' or else Ch (Pos + 3) /= '-' or else (Pos + 6 <= Ch'last and then Ch (Pos + 6) /= 'T' and then Ch (Pos + 6) /= '-' and then Ch (Pos + 6) /= '+' and then Ch (Pos + 6) /= 'Z') then Error := Find (Symbols, "Invalid separator in date value """ & Ch & """"); Date := No_Date_NZ; Eos := Ch'first; return; end if; Date.Month := Integer'value (Ch (Pos + 1 .. Pos + 2)); if Date.Month < 1 or else Date.Month > 12 then Error := Find (Symbols, "Invalid month in """ & Ch & '"'); return; end if; Date.Day := Integer'value (Ch (Pos + 4 .. Pos + 5)); Eos := Pos + 6; -- Check that the date is correct. -- We cannot use Ada.Calendar, since its range of dates is much more -- limited than the one in XML. Leap_Year := Date.Year mod 4 = 0 and then (Date.Year mod 100 /= 0 or else Date.Year mod 400 = 0); if Date.Day > Max_Days (Date.Month) or else (Date.Month = 2 and then (Date.Day > 29 or else (Date.Day = 29 and then not Leap_Year))) then Error := Find (Symbols, "Invalid date """ & Ch & """"); -- & Date.Year'Image & Date.Month'Img & Date.Day'Img); Date := No_Date_NZ; Eos := Ch'last + 1; return; end if; Error := No_Symbol; exception when Constraint_Error => Error := Find (Symbols, "Invalid date """ & Ch & """"); Date := No_Date_NZ; Eos := Ch'last + 1; end Parse; ----------- -- Parse -- ----------- procedure Parse (Symbols : symbol_table; Ch : String; Time : out time_nz_t; Eos : out Natural; Error : out symbol) is -- Format is "hh:mm:ss.sss[+-]hh:mm" Pos : Integer; Hour, Min : Integer; Msec : day_range := 0.0; begin Hour := Integer'value (Ch (Ch'first .. Ch'first + 1)); if Ch (Ch'first + 2) /= ':' or else Ch (Ch'first + 5) /= ':' then Error := Find (Symbols, "Invalid separator in time: """ & Ch & """"); Time := No_Time_NZ; Eos := Ch'first; return; end if; Min := Integer'value (Ch (Ch'first + 3 .. Ch'first + 4)); if Min > 59 then Error := Find (Symbols, "Invalid minutes in time: """ & Ch & """"); Time := No_Time_NZ; return; end if; Pos := Ch'first + 8; if Pos = Ch'last and then Ch (Pos) = '.' then Error := Find (Symbols, "'.' must be followed by digits in """ & Ch & """"); return; end if; if Pos < Ch'last and then Ch (Pos) = '.' then Pos := Pos + 1; while Pos <= Ch'last and then Is_Decimal_Digit (Ch (Pos)) loop Pos := Pos + 1; end loop; Msec := day_range'value (Ch (Ch'first + 6 .. Pos - 1)); Eos := Pos; else Msec := day_range'value (Ch (Ch'first + 6 .. Ch'first + 7)); Eos := Ch'first + 8; end if; if Msec >= 60.0 then Error := Find (Symbols, "Invalid seconds in time: """ & Ch & """"); Time := No_Time_NZ; return; end if; if Hour > 24 or else (Hour = 24 and then (Min /= 0 or else Msec /= 0.0)) then Error := Find (Symbols, "Invalid hour in time: """ & Ch & """"); Time := No_Time_NZ; return; end if; Error := No_Symbol; Time := day_range (Hour) * 3600.0 + day_range (Min) * 60.0 + Msec; exception when Constraint_Error => Error := Find (Symbols, "Invalid time: """ & Ch & """"); Time := No_Time_NZ; Eos := Ch'last + 1; end Parse; ----------- -- Parse -- ----------- procedure Parse (Symbols : symbol_table; Ch : String; TZ : out timezone_t; Error : out symbol) is begin if Ch'length /= 0 then if Ch (Ch'first) = 'Z' then if Ch'length /= 1 then Error := Find (Symbols, "Invalid time zone in """ & Ch & """"); TZ := No_Timezone; return; else TZ := 0; end if; elsif Ch'length /= 6 then Error := Find (Symbols, "Invalid time zone in """ & Ch & """"); TZ := No_Timezone; return; else if (Ch (Ch'first) /= '-' and then Ch (Ch'first) /= '+') or else Ch (Ch'first + 3) /= ':' then Error := Find (Symbols, "Invalid time zone specification in """ & Ch & """"); TZ := No_Timezone; return; end if; TZ := timezone_t'value (Ch (Ch'first + 1 .. Ch'first + 2)) * 60 + timezone_t'value (Ch (Ch'first + 4 .. Ch'first + 5)); if abs (TZ) > 14 * 60 then Error := Find (Symbols, "Invalid time zone range in """ & Ch & """"); TZ := No_Timezone; return; end if; if Ch (Ch'first) = '-' then TZ := -TZ; end if; end if; else TZ := No_Timezone; end if; Error := No_Symbol; exception when Constraint_Error => Error := Find (Symbols, "Invalid time zone specification in """ & Ch & """"); TZ := No_Timezone; end Parse; ----------- -- Value -- ----------- procedure Value (Symbols : symbol_table; Ch : String; Val : out duration_t; Error : out symbol) is Pos : Integer := Ch'first; Tmp : Integer; Processing_Time : Boolean := False; Hour : Natural; begin Val := No_Duration; if Ch = "" then Error := Find (Symbols, "Empty string is not a valid value for duration"); return; end if; if Ch (Pos) = '-' then Val.Sign := -1; Pos := Pos + 1; else Val.Sign := 1; end if; if Ch (Pos) /= 'P' then Error := Find (Symbols, "Invalid prefix for duration in """ & Ch & """"); return; end if; Pos := Pos + 1; while Pos <= Ch'last loop Tmp := Pos; while Tmp <= Ch'last and then (Is_Decimal_Digit (Ch (Tmp)) or else Ch (Tmp) = '.') loop Tmp := Tmp + 1; end loop; if Tmp > Ch'last then Error := Find (Symbols, "Missing qualifier after last digit in duration """ & Ch & """"); return; end if; if Ch (Tmp) = 'T' then Processing_Time := True; if Tmp = Ch'last then Error := Find (Symbols, "Expecting time after T in """ & Ch & """"); return; end if; elsif Ch (Tmp) = 'Y' then if Processing_Time then Error := Find (Symbols, "Expecting time component in """ & Ch & """"); return; end if; begin Val.Year := Integer'value (Ch (Pos .. Tmp - 1)); exception when Constraint_Error => Error := Find (Symbols, "Expecting an integer for the year, found """ & Ch (Pos .. Tmp - 1) & """"); return; end; elsif Ch (Tmp) = 'M' then if Processing_Time then Val.Seconds := Val.Seconds + day_range (Integer'value (Ch (Pos .. Tmp - 1))) * 60.0; else Val.Month := Integer'value (Ch (Pos .. Tmp - 1)); end if; elsif Ch (Tmp) = 'D' then if Processing_Time then Error := Find (Symbols, "Expecting time component in """ & Ch & """"); return; end if; Val.Day := Integer'value (Ch (Pos .. Tmp - 1)); elsif Ch (Tmp) = 'S' then if not Processing_Time then Error := Find (Symbols, "Expecting date component in """ & Ch & """"); return; end if; Val.Seconds := Val.Seconds + day_range'value (Ch (Pos .. Tmp - 1)); elsif Ch (Tmp) = 'H' then if not Processing_Time then Error := Find (Symbols, "Expecting date component in """ & Ch & """"); return; end if; Hour := Integer'value (Ch (Pos .. Tmp - 1)); Val.Seconds := Val.Seconds + Duration (Hour) * 3600.0; else Error := Find (Symbols, "Invalid character '" & Ch (Tmp) & "' in duration: """ & Ch & """"); return; end if; Pos := Tmp + 1; end loop; Error := No_Symbol; end Value; ----------- -- Value -- ----------- procedure Value (Symbols : symbol_table; Ch : String; Val : out date_time_t; Error : out symbol) is Eos : Integer; begin Parse (Symbols, Ch, Val.Date, Eos, Error); if Error /= No_Symbol then return; end if; if Ch (Eos) /= 'T' then Error := Find (Symbols, "Invalid date/time separator in """ & Ch & """"); return; end if; Parse (Symbols, Ch (Eos + 1 .. Ch'last), Val.Time, Eos, Error); if Error /= No_Symbol then return; end if; Parse (Symbols, Ch (Eos .. Ch'last), Val.TZ, Error); end Value; ----------- -- Value -- ----------- procedure Value (Symbols : symbol_table; Ch : String; Val : out date_t; Error : out symbol) is Eos : Integer; begin Parse (Symbols, Ch, Val.Date, Eos, Error); if Error /= No_Symbol then return; end if; Parse (Symbols, Ch (Eos .. Ch'last), Val.TZ, Error); end Value; ----------- -- Value -- ----------- procedure Value (Symbols : symbol_table; Ch : String; Val : out gday_t; Error : out symbol) is begin if Ch (Ch'first) /= '-' or else Ch (Ch'first + 1) /= '-' or else Ch (Ch'first + 2) /= '-' then Error := Find (Symbols, "Invalid date """ & Ch & """"); return; end if; Val.Day := Integer'value (Ch (Ch'first + 3 .. Ch'first + 4)); Parse (Symbols, Ch (Ch'first + 5 .. Ch'last), Val.TZ, Error); exception when Constraint_Error => Error := Find (Symbols, "Invalid date """ & Ch & """"); end Value; ----------- -- Value -- ----------- procedure Value (Symbols : symbol_table; Ch : String; Val : out gmonth_day_t; Error : out symbol) is begin if Ch (Ch'first .. Ch'first + 1) /= "--" or else Ch (Ch'first + 4) /= '-' then Error := Find (Symbols, "Invalid gMonthDay: """ & Ch & """"); return; end if; Val.Month := Integer'value (Ch (Ch'first + 2 .. Ch'first + 3)); Val.Day := Integer'value (Ch (Ch'first + 5 .. Ch'first + 6)); Parse (Symbols, Ch (Ch'first + 7 .. Ch'last), Val.TZ, Error); exception when Constraint_Error => Error := Find (Symbols, "Invalid gMonthDay: """ & Ch & """"); end Value; ----------- -- Value -- ----------- procedure Value (Symbols : symbol_table; Ch : String; Val : out gmonth_t; Error : out symbol) is Index : Natural; begin if Ch (Ch'first .. Ch'first + 1) /= "--" then Error := Find (Symbols, "Invalid gMonth: """ & Ch & """"); return; end if; Val.Month := Integer'value (Ch (Ch'first + 2 .. Ch'first + 3)); if Val.Month > 12 then Error := Find (Symbols, "Invalid month:" & Val.Month'img); return; end if; Val.TZ := No_Timezone; if Ch'last > Ch'first + 3 then if Ch'last >= Ch'first + 5 and then Ch (Ch'first + 4 .. Ch'first + 5) = "--" then Index := Ch'first + 6; else Index := Ch'first + 4; end if; if Index < Ch'last then Parse (Symbols, Ch (Index .. Ch'last), Val.TZ, Error); end if; else Error := No_Symbol; end if; exception when Constraint_Error => Error := Find (Symbols, "Invalid gMonth: """ & Ch & """"); end Value; ----------- -- Value -- ----------- procedure Value (Symbols : symbol_table; Ch : String; Val : out gyear_t; Error : out symbol) is Eos : Integer; begin Parse_Year (Symbols, Ch, Val.Year, Eos, Error); if Error /= No_Symbol then return; end if; Parse (Symbols, Ch (Eos .. Ch'last), Val.TZ, Error); end Value; ----------- -- Value -- ----------- procedure Value (Symbols : symbol_table; Ch : String; Val : out gyear_month_t; Error : out symbol) is Eos : Integer; begin Parse_Year (Symbols, Ch, Val.Year, Eos, Error); if Error /= No_Symbol then return; end if; if Ch (Eos) /= '-' then Error := Find (Symbols, "Invalid gYearMonth: """ & Ch & """"); return; end if; Val.Month := Integer'value (Ch (Eos + 1 .. Eos + 2)); if Val.Month > 12 then Error := Find (Symbols, "Invalid month:" & Val.Month'img); return; end if; Parse (Symbols, Ch (Eos + 3 .. Ch'last), Val.TZ, Error); exception when Constraint_Error => Error := Find (Symbols, "Invalid gYearMonth: """ & Ch & """"); end Value; ----------- -- Value -- ----------- procedure Value (Symbols : symbol_table; Ch : String; Val : out time_t; Error : out symbol) is Eos : Integer; begin Parse (Symbols, Ch, Val.Time, Eos, Error); if Error /= No_Symbol then return; end if; Parse (Symbols, Ch (Eos .. Ch'last), Val.TZ, Error); end Value; ----------------------- -- Max_Days_In_Month -- ----------------------- function Max_Days_In_Month (Year, Month : Integer) return Integer is Days : constant array (1 .. 12) of Integer := (1 => 31, 2 => 28, 3 => 31, 4 => 30, 5 => 31, 6 => 30, 7 => 31, 8 => 31, 9 => 30, 10 => 31, 11 => 30, 12 => 31); Y : constant Integer := Year + Integer (Float'floor (Float (Month - 1) / 12.0)); M : constant Integer := 1 + (Month - 1) mod 12; begin if M = 2 then if Y mod 400 = 0 or else (Y mod 100 /= 0 and then Y mod 4 = 0) then return 29; else return 28; end if; else return Days (M); end if; end Max_Days_In_Month; --------- -- "+" -- --------- function "+" (Date : date_time_t; Duration : duration_t) return date_time_t is Result : date_time_t := Date; Tmp : Float; Tmp2 : Integer; begin Result.Date.Month := Date.Date.Month + Duration.Sign * Duration.Month; Result.Date.Year := Date.Date.Year + Duration.Sign * Duration.Year; Result.Date.Day := Date.Date.Day + Duration.Sign * Duration.Day; Result.TZ := Date.TZ; Tmp := Float (Date.Time) + Float (Duration.Sign) * Float (Duration.Seconds); if Tmp < 0.0 or else Tmp > 86_400.0 then Tmp2 := Integer (Float'floor (Tmp / 86_400.0)); Result.Time := day_range (Tmp - Float (Tmp2 * 86_400)); Result.Date.Day := Result.Date.Day + Tmp2; else -- Redo the computation based on the Duration type, to avoid -- rounding error. We know for sur the result will be in the range Result.Time := Date.Time + day_range (Duration.Sign) * day_range (Duration.Seconds); end if; Normalize (Result.Date); return Result; end "+"; --------------- -- Normalize -- --------------- procedure Normalize (Date : in out date_nz_t) is Carry : Integer; Max_Days : Integer; begin if Date.Month < 1 or else Date.Month > 12 then Date.Year := Date.Year + (Date.Month - 1) / 12; Date.Month := (Date.Month - 1) mod 12 + 1; end if; loop if Date.Day < 1 then Date.Day := Date.Day + Max_Days_In_Month (Date.Year, Date.Month - 1); Carry := -1; else Max_Days := Max_Days_In_Month (Date.Year, Date.Month); if Date.Day > Max_Days then Date.Day := Date.Day - Max_Days; Carry := 1; else exit; end if; end if; Date.Year := Date.Year + Integer (Float'floor (Float (Date.Month + Carry - 1) / 12.0)); Date.Month := 1 + (Date.Month + Carry - 1) mod 12; end loop; end Normalize; --------------- -- Normalize -- --------------- function Normalize (Date : date_time_t) return date_time_t is Result : date_time_t; begin if Date.TZ /= No_Timezone and then Date.TZ /= 0 then if Date.TZ > 0 then Result := Date + (-1, 0, 0, 0, day_range (Date.TZ * 60)); else Result := Date + (1, 0, 0, 0, day_range ((-Date.TZ) * 60)); end if; Result.TZ := 0; return Result; else return Date; end if; end Normalize; --------------- -- Normalize -- --------------- function Normalize (Duration : duration_t) return duration_t is begin return Duration; end Normalize; ---------- -- Sign -- ---------- function Sign (Duration : duration_t) return Integer is begin return Duration.Sign; end Sign; ---------- -- Year -- ---------- function Year (Duration : duration_t) return Natural is begin return Duration.Year; end Year; ----------- -- Month -- ----------- function Month (Duration : duration_t) return Natural is begin return Duration.Month; end Month; --------- -- Day -- --------- function Day (Duration : duration_t) return Natural is begin return Duration.Day; end Day; ------------- -- Seconds -- ------------- function Seconds (Duration : duration_t) return day_duration is begin return Duration.Seconds; end Seconds; ----------- -- Value -- ----------- function Year (Date : date_time_t) return Integer is D : date_time_t := Date; begin if D.TZ /= No_Timezone then D.Time := D.Time - time_nz_t (D.TZ) * 60.0; D := Normalize (D); end if; return D.Date.Year; end Year; function Month (Date : date_time_t) return Natural is D : date_time_t := Date; begin if D.TZ /= No_Timezone then D.Time := D.Time - time_nz_t (D.TZ) * 60.0; D := Normalize (D); end if; return D.Date.Month; end Month; function Day (Date : date_time_t) return Natural is D : date_time_t := Date; begin if D.TZ /= No_Timezone then D.Time := D.Time - time_nz_t (D.TZ) * 60.0; D := Normalize (D); end if; return D.Date.Day; end Day; ------------- -- Compare -- ------------- function Compare (Date1, Date2 : date_nz_t) return compare_result is begin if Date1.Year < Date2.Year then return less_than; elsif Date1.Year > Date2.Year then return greater_than; elsif Date1.Month < Date2.Month then return less_than; elsif Date1.Month > Date2.Month then return greater_than; elsif Date1.Day < Date2.Day then return less_than; elsif Date1.Day > Date2.Day then return greater_than; end if; return equal; end Compare; ------------- -- Compare -- ------------- function Compare (Time1, Time2 : time_nz_t) return compare_result is begin if Time1 < Time2 then return less_than; elsif Time1 > Time2 then return greater_than; else return equal; end if; end Compare; ------------- -- Compare -- ------------- function Compare (Duration1, Duration2 : duration_t) return compare_result is -- See 3.2.6.2 for more information on how to compare Durations Date1 : constant date_time_t := ((1696, 09, 01), 0.0, 0); Date2 : constant date_time_t := ((1697, 02, 01), 0.0, 0); Date3 : constant date_time_t := ((1903, 03, 01), 0.0, 0); Date4 : constant date_time_t := ((1903, 07, 01), 0.0, 0); T1 : constant compare_result := Compare (Normalize (Date1 + Duration1), Normalize (Date1 + Duration2)); T2 : constant compare_result := Compare (Normalize (Date2 + Duration1), Normalize (Date2 + Duration2)); T3 : constant compare_result := Compare (Normalize (Date3 + Duration1), Normalize (Date3 + Duration2)); T4 : constant compare_result := Compare (Normalize (Date4 + Duration1), Normalize (Date4 + Duration2)); begin if T1 = less_than and then T2 = less_than and then T3 = less_than and then T4 = less_than then return less_than; elsif T1 = greater_than and then T2 = greater_than and then T3 = greater_than and then T4 = greater_than then return greater_than; elsif T1 = equal and then T2 = equal and then T3 = equal and then T4 = equal then return equal; else return uncomparable; end if; end Compare; ------------- -- Compare -- ------------- function Compare (Time1, Time2 : date_time_t) return compare_result is T : date_time_t; Tmp : compare_result; begin if (Time1.TZ = No_Timezone and Time2.TZ = No_Timezone) or else (Time1.TZ /= No_Timezone and Time2.TZ /= No_Timezone) then Tmp := Compare (Time1.Date, Time2.Date); if Tmp /= equal then return Tmp; else return Compare (Time1.Time, Time2.Time); end if; elsif Time1.TZ /= No_Timezone then T := Time2; T.TZ := 14 * 60; if Compare (Time1, Normalize (T)) = less_than then return less_than; end if; T.TZ := -14 * 60; if Compare (Time1, Normalize (T)) = greater_than then return greater_than; end if; return uncomparable; else T := Time1; T.TZ := -14 * 60; if Compare (Normalize (T), Time2) = less_than then return less_than; end if; T.TZ := 14 * 60; if Compare (Normalize (T), Time2) = greater_than then return greater_than; end if; return uncomparable; end if; end Compare; ----------------- -- Comparators -- ----------------- package body Comparators is --------- -- "<" -- --------- function "<" (T1, T2 : t) return Boolean is Result : constant compare_result := Compare (Normalize (T1), Normalize (T2)); begin if Result = uncomparable then raise Not_Comparable; else return Result = less_than; end if; end "<"; ---------- -- "<=" -- ---------- function "<=" (T1, T2 : t) return Boolean is Result : constant compare_result := Compare (Normalize (T1), Normalize (T2)); begin if Result = uncomparable then raise Not_Comparable; else return Result = less_than or Result = equal; end if; end "<="; --------- -- "=" -- --------- function "=" (T1, T2 : t) return Boolean is Result : constant compare_result := Compare (Normalize (T1), Normalize (T2)); begin if Result = uncomparable then return False; else return Result = equal; end if; end "="; --------- -- ">" -- --------- function ">" (T1, T2 : t) return Boolean is Result : constant compare_result := Compare (Normalize (T1), Normalize (T2)); begin if Result = uncomparable then raise Not_Comparable; else return Result = greater_than; end if; end ">"; ---------- -- ">=" -- ---------- function ">=" (T1, T2 : t) return Boolean is Result : constant compare_result := Compare (Normalize (T1), Normalize (T2)); begin if Result = uncomparable then raise Not_Comparable; else return Result = greater_than or Result = equal; end if; end ">="; end Comparators; -------------------- -- DT_Comparators -- -------------------- package body DT_Comparators is --------- -- "<" -- --------- function "<" (T1, T2 : t) return Boolean is begin return To_Date_Time (T1) < To_Date_Time (T2); end "<"; ---------- -- "<=" -- ---------- function "<=" (T1, T2 : t) return Boolean is begin return To_Date_Time (T1) <= To_Date_Time (T2); end "<="; --------- -- "=" -- --------- function "=" (T1, T2 : t) return Boolean is begin return To_Date_Time (T1) = To_Date_Time (T2); end "="; --------- -- ">" -- --------- function ">" (T1, T2 : t) return Boolean is begin return To_Date_Time (T1) > To_Date_Time (T2); end ">"; ---------- -- ">=" -- ---------- function ">=" (T1, T2 : t) return Boolean is begin return To_Date_Time (T1) >= To_Date_Time (T2); end ">="; end DT_Comparators; package Date_Comp is new DT_Comparators (date_t); function "<" (Date1, Date2 : date_t) return Boolean renames Date_Comp."<"; function "<=" (Date1, Date2 : date_t) return Boolean renames Date_Comp."<="; function "=" (Date1, Date2 : date_t) return Boolean renames Date_Comp."="; function ">" (Date1, Date2 : date_t) return Boolean renames Date_Comp.">"; function ">=" (Date1, Date2 : date_t) return Boolean renames Date_Comp.">="; package Time_Comp is new DT_Comparators (time_t); function "<" (Time1, Time2 : time_t) return Boolean renames Time_Comp."<"; function "<=" (Time1, Time2 : time_t) return Boolean renames Time_Comp."<="; function "=" (Time1, Time2 : time_t) return Boolean renames Time_Comp."="; function ">" (Time1, Time2 : time_t) return Boolean renames Time_Comp.">"; function ">=" (Time1, Time2 : time_t) return Boolean renames Time_Comp.">="; package Day_T_Comp is new DT_Comparators (gday_t); function "<" (Day1, Day2 : gday_t) return Boolean renames Day_T_Comp."<"; function "<=" (Day1, Day2 : gday_t) return Boolean renames Day_T_Comp."<="; function "=" (Day1, Day2 : gday_t) return Boolean renames Day_T_Comp."="; function ">" (Day1, Day2 : gday_t) return Boolean renames Day_T_Comp.">"; function ">=" (Day1, Day2 : gday_t) return Boolean renames Day_T_Comp.">="; package Month_Day_T_Comp is new DT_Comparators (gmonth_day_t); function "<" (Day1, Day2 : gmonth_day_t) return Boolean renames Month_Day_T_Comp."<"; function "<=" (Day1, Day2 : gmonth_day_t) return Boolean renames Month_Day_T_Comp."<="; function "=" (Day1, Day2 : gmonth_day_t) return Boolean renames Month_Day_T_Comp."="; function ">" (Day1, Day2 : gmonth_day_t) return Boolean renames Month_Day_T_Comp.">"; function ">=" (Day1, Day2 : gmonth_day_t) return Boolean renames Month_Day_T_Comp.">="; package Month_T_Comp is new DT_Comparators (gmonth_t); function "<" (Month1, Month2 : gmonth_t) return Boolean renames Month_T_Comp."<"; function "<=" (Month1, Month2 : gmonth_t) return Boolean renames Month_T_Comp."<="; function "=" (Month1, Month2 : gmonth_t) return Boolean renames Month_T_Comp."="; function ">" (Month1, Month2 : gmonth_t) return Boolean renames Month_T_Comp.">"; function ">=" (Month1, Month2 : gmonth_t) return Boolean renames Month_T_Comp.">="; package Year_Month_T_Comp is new DT_Comparators (gyear_month_t); function "<" (Month1, Month2 : gyear_month_t) return Boolean renames Year_Month_T_Comp."<"; function "<=" (Month1, Month2 : gyear_month_t) return Boolean renames Year_Month_T_Comp."<="; function "=" (Month1, Month2 : gyear_month_t) return Boolean renames Year_Month_T_Comp."="; function ">" (Month1, Month2 : gyear_month_t) return Boolean renames Year_Month_T_Comp.">"; function ">=" (Month1, Month2 : gyear_month_t) return Boolean renames Year_Month_T_Comp.">="; package Year_T_Comp is new DT_Comparators (gyear_t); function "<" (Year1, Year2 : gyear_t) return Boolean renames Year_T_Comp."<"; function "<=" (Year1, Year2 : gyear_t) return Boolean renames Year_T_Comp."<="; function "=" (Year1, Year2 : gyear_t) return Boolean renames Year_T_Comp."="; function ">" (Year1, Year2 : gyear_t) return Boolean renames Year_T_Comp.">"; function ">=" (Year1, Year2 : gyear_t) return Boolean renames Year_T_Comp.">="; package Date_Time_T_Comp is new Comparators (date_time_t); function "<" (Time1, Time2 : date_time_t) return Boolean renames Date_Time_T_Comp."<"; function "<=" (Time1, Time2 : date_time_t) return Boolean renames Date_Time_T_Comp."<="; function "=" (Time1, Time2 : date_time_t) return Boolean renames Date_Time_T_Comp."="; function ">" (Time1, Time2 : date_time_t) return Boolean renames Date_Time_T_Comp.">"; function ">=" (Time1, Time2 : date_time_t) return Boolean renames Date_Time_T_Comp.">="; package Duration_T_Comp is new Comparators (duration_t); function "<" (Duration1, Duration2 : duration_t) return Boolean renames Duration_T_Comp."<"; function "<=" (Duration1, Duration2 : duration_t) return Boolean renames Duration_T_Comp."<="; function "=" (Duration1, Duration2 : duration_t) return Boolean renames Duration_T_Comp."="; function ">" (Duration1, Duration2 : duration_t) return Boolean renames Duration_T_Comp.">"; function ">=" (Duration1, Duration2 : duration_t) return Boolean renames Duration_T_Comp.">="; end Schema.Date_Time;