1------------------------------------------------------------------------------
2--                                                                          --
3--                            Matreshka Project                             --
4--                                                                          --
5--         Localization, Internationalization, Globalization for Ada        --
6--                                                                          --
7--                        Runtime Library Component                         --
8--                                                                          --
9------------------------------------------------------------------------------
10--                                                                          --
11-- Copyright © 2011-2013, Vadim Godunko <vgodunko@gmail.com>                --
12-- All rights reserved.                                                     --
13--                                                                          --
14-- Redistribution and use in source and binary forms, with or without       --
15-- modification, are permitted provided that the following conditions       --
16-- are met:                                                                 --
17--                                                                          --
18--  * Redistributions of source code must retain the above copyright        --
19--    notice, this list of conditions and the following disclaimer.         --
20--                                                                          --
21--  * Redistributions in binary form must reproduce the above copyright     --
22--    notice, this list of conditions and the following disclaimer in the   --
23--    documentation and/or other materials provided with the distribution.  --
24--                                                                          --
25--  * Neither the name of the Vadim Godunko, IE nor the names of its        --
26--    contributors may be used to endorse or promote products derived from  --
27--    this software without specific prior written permission.              --
28--                                                                          --
29-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS      --
30-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT        --
31-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR    --
32-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT     --
33-- HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,   --
34-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED --
35-- TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR   --
36-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF   --
37-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING     --
38-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS       --
39-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.             --
40--                                                                          --
41------------------------------------------------------------------------------
42--  $Revision: 3663 $ $Date: 2013-01-20 22:32:29 +0400 (Sun, 20 Jan 2013) $
43------------------------------------------------------------------------------
44
45package body Matreshka.Internals.Calendars.Times is
46
47   X_Open_Epoch : constant := 2_299_161;
48   --  Julian day number of start of X/Open representation
49   --  October, 15, 1582
50
51   Ticks_In_Day    : constant := 24 * 60 * 60 * 10_000_000;
52   Ticks_In_Hour   : constant :=      60 * 60 * 10_000_000;
53   Ticks_In_Minute : constant :=           60 * 10_000_000;
54   Ticks_In_Second : constant :=                10_000_000;
55
56   type Leap_Second_Information is record
57      Julian_Day : Julian_Day_Number;
58      Stamp      : Absolute_Time;
59      Correction : Absolute_Time;
60   end record;
61
62   Leaps : constant array (Positive range <>) of Leap_Second_Information
63     := ((2456109, 135603936240000000, 250000000),   --  2012-06-30
64         (2454832, 134500608230000000, 240000000),   --  2008-12-31
65         (2453736, 133553664220000000, 230000000),   --  2005-12-31
66         (2451179, 131344416210000000, 220000000),   --  1998-12-31
67         (2450630, 130870080200000000, 210000000),   --  1997-06-30
68         (2450083, 130397472190000000, 200000000),   --  1995-12-31
69         (2449534, 129923136180000000, 190000000),   --  1994-06-30
70         (2449169, 129607776170000000, 180000000),   --  1993-06-30
71         (2448804, 129292416160000000, 170000000),   --  1992-06-30
72         (2448257, 128819808150000000, 160000000),   --  1990-12-31
73         (2447892, 128504448140000000, 150000000),   --  1989-12-31
74         (2447161, 127872864130000000, 140000000),   --  1987-12-31
75         (2446247, 127083168120000000, 130000000),   --  1985-06-30
76         (2445516, 126451584110000000, 120000000),   --  1983-06-30
77         (2445151, 126136224100000000, 110000000),   --  1982-06-30
78         (2444786, 125820864090000000, 100000000),   --  1981-06-30
79         (2444239, 125348256080000000,  90000000),   --  1979-12-31
80         (2443874, 125032896070000000,  80000000),   --  1978-12-31
81         (2443509, 124717536060000000,  70000000),   --  1977-12-31
82         (2443144, 124402176050000000,  60000000),   --  1976-12-31
83         (2442778, 124085952040000000,  50000000),   --  1975-12-31
84         (2442413, 123770592030000000,  40000000),   --  1974-12-31
85         (2442048, 123455232020000000,  30000000),   --  1973-12-31
86         (2441683, 123139872010000000,  20000000),   --  1972-12-31
87         (2441499, 122980896000000000,  10000000));  --  1972-06-30
88
89   ------------
90   -- Create --
91   ------------
92
93   function Create
94    (Zone       : not null Time_Zone_Access;
95     Julian_Day : Julian_Day_Number;
96     Hour       : Hour_Number;
97     Minute     : Minute_Number;
98     Second     : Second_Number;
99     Nano_100   : Nano_Second_100_Number) return Absolute_Time
100   is
101      pragma Unreferenced (Zone);
102      --  XXX Time zone is not supported yet.
103
104      Stamp : Absolute_Time;
105      Row   : Natural := 0;
106      --  Number of row in correction table to obtain nearset next leap second
107      --  day.
108
109   begin
110      --  Construct absolute time from all components except second and its
111      --  fraction. Resulted absolute time will never be inside nearest next
112      --  leap second.
113
114      Stamp :=
115        Absolute_Time (Julian_Day - X_Open_Epoch) * Ticks_In_Day
116          + Absolute_Time (Hour) * Ticks_In_Hour
117          + Absolute_Time (Minute) * Ticks_In_Minute;
118
119      --  Looking for leap second correction and correct absolute time when
120      --  necessary.
121
122      for J in Leaps'Range loop
123         if Stamp > Leaps (J).Stamp - Leaps (J).Correction + 10_000_000 then
124            Stamp := Stamp + Leaps (J).Correction;
125            Row := J - 1;
126
127            exit;
128         end if;
129      end loop;
130
131      --  Check whether leap second can be used.
132
133      if Second = 60
134        and then (Row not in Leaps'Range
135                    or else Leaps (Row).Julian_Day /= Julian_Day)
136      then
137         raise Constraint_Error;
138      end if;
139
140      --  Add second and its fraction components.
141
142      return
143        Stamp
144          + Absolute_Time (Second) * Ticks_In_Second
145          + Absolute_Time (Nano_100);
146   end Create;
147
148   ----------
149   -- Hour --
150   ----------
151
152   function Hour
153    (Stamp : Absolute_Time;
154     Zone  : not null Time_Zone_Access) return Hour_Number
155   is
156      Julian_Day : Julian_Day_Number;
157      Time       : Relative_Time;
158      Leap       : Relative_Time;
159
160   begin
161      Split (Zone, Stamp, Julian_Day, Time, Leap);
162
163      return Hour_Number (Time / Ticks_In_Hour);
164   end Hour;
165
166   ----------
167   -- Hour --
168   ----------
169
170   function Hour (Time : Relative_Time) return Hour_Number is
171   begin
172      return Hour_Number (Time / Ticks_In_Hour);
173   end Hour;
174
175   ----------------
176   -- Julian_Day --
177   ----------------
178
179   function Julian_Day
180    (Stamp : Absolute_Time;
181     Zone  : not null Time_Zone_Access) return Julian_Day_Number
182   is
183      Julian_Day : Julian_Day_Number;
184      Time       : Relative_Time;
185      Leap       : Relative_Time;
186
187   begin
188      Split (Zone, Stamp, Julian_Day, Time, Leap);
189
190      return Julian_Day;
191   end Julian_Day;
192
193   ------------
194   -- Minute --
195   ------------
196
197   function Minute
198    (Stamp : Absolute_Time;
199     Zone  : not null Time_Zone_Access) return Minute_Number
200   is
201      Julian_Day : Julian_Day_Number;
202      Time       : Relative_Time;
203      Leap       : Relative_Time;
204
205   begin
206      Split (Zone, Stamp, Julian_Day, Time, Leap);
207
208      return Minute_Number ((Time mod Ticks_In_Hour) / Ticks_In_Minute);
209   end Minute;
210
211   ------------
212   -- Minute --
213   ------------
214
215   function Minute (Time : Relative_Time) return Minute_Number is
216   begin
217      return Minute_Number ((Time mod Ticks_In_Hour) / Ticks_In_Minute);
218   end Minute;
219
220   --------------------
221   -- Nanosecond_100 --
222   --------------------
223
224   function Nanosecond_100
225    (Stamp : Absolute_Time;
226     Zone  : not null Time_Zone_Access) return Nano_Second_100_Number
227   is
228      Julian_Day : Julian_Day_Number;
229      Time       : Relative_Time;
230      Leap       : Relative_Time;
231
232   begin
233      Split (Zone, Stamp, Julian_Day, Time, Leap);
234
235      return
236        Nano_Second_100_Number
237         ((Time mod Ticks_In_Minute + Leap mod Ticks_In_Minute)
238            mod Ticks_In_Second);
239   end Nanosecond_100;
240
241   --------------------
242   -- Nanosecond_100 --
243   --------------------
244
245   function Nanosecond_100
246    (Time : Relative_Time;
247     Leap : Relative_Time) return Nano_Second_100_Number is
248   begin
249      return
250        Nano_Second_100_Number
251         ((Time mod Ticks_In_Minute + Leap mod Ticks_In_Minute)
252            mod Ticks_In_Second);
253   end Nanosecond_100;
254
255   ------------
256   -- Second --
257   ------------
258
259   function Second
260    (Stamp : Absolute_Time;
261     Zone  : not null Time_Zone_Access) return Second_Number
262   is
263      Julian_Day : Julian_Day_Number;
264      Time       : Relative_Time;
265      Leap       : Relative_Time;
266
267   begin
268      Split (Zone, Stamp, Julian_Day, Time, Leap);
269
270      return
271        Second_Number
272         ((Time mod Ticks_In_Minute + Leap mod Ticks_In_Minute)
273            / Ticks_In_Second);
274   end Second;
275
276   ------------
277   -- Second --
278   ------------
279
280   function Second
281    (Time : Relative_Time; Leap : Relative_Time) return Second_Number is
282   begin
283      return
284        Second_Number
285         ((Time mod Ticks_In_Minute + Leap mod Ticks_In_Minute)
286            / Ticks_In_Second);
287   end Second;
288
289   -----------
290   -- Split --
291   -----------
292
293   procedure Split
294    (Zone       : not null Time_Zone_Access;
295     Stamp      : Absolute_Time;
296     Julian_Day : out Julian_Day_Number;
297     Time       : out Relative_Time;
298     Leap       : out Relative_Time)
299   is
300      pragma Unreferenced (Zone);
301      --  XXX Timezone is not supported.
302
303      Corrected_Stamp : Absolute_Time := Stamp;
304
305   begin
306      --  Compensate leap seconds and extract leap second duration when
307      --  necessary.
308
309      Leap := 0;
310
311      --  Going through list of leap seconds.
312
313      for J in Leaps'Range loop
314         if Stamp >= Leaps (J).Stamp + 10_000_000 then
315            --  Stamp is larger than current leap second and outside of leap
316            --  second range.
317
318            Corrected_Stamp := Stamp - Leaps (J).Correction;
319
320            exit;
321
322         elsif Stamp >= Leaps (J).Stamp then
323            --  Stamp is inside leap second range.
324
325            Corrected_Stamp :=
326              Leaps (J).Stamp - Leaps (J).Correction + 10_000_000 - 1;
327            Leap := Relative_Time (Stamp - Leaps (J).Stamp + 1);
328
329            exit;
330         end if;
331      end loop;
332
333      --  Compute julian day number and relative time.
334
335      Julian_Day :=
336        Julian_Day_Number (Corrected_Stamp / (Ticks_In_Day)) + X_Open_Epoch;
337      Time := Relative_Time (Corrected_Stamp mod (Ticks_In_Day));
338   end Split;
339
340   -----------
341   -- Split --
342   -----------
343
344   procedure Split
345    (Zone           : not null Time_Zone_Access;
346     Stamp          : Absolute_Time;
347     Julian_Day     : out Julian_Day_Number;
348     Hour           : out Hour_Number;
349     Minute         : out Minute_Number;
350     Second         : out Second_Number;
351     Nanosecond_100 : out Nano_Second_100_Number)
352   is
353      Leap            : Relative_Time;
354      Time            : Relative_Time;
355      Corrected_Stamp : Absolute_Time := Stamp;
356
357   begin
358      --  Compensate leap seconds and extract leap second duration when
359      --  necessary.
360
361      Leap := 0;
362
363      --  Going through list of leap seconds.
364
365      for J in Leaps'Range loop
366         if Stamp >= Leaps (J).Stamp + 10_000_000 then
367            --  Stamp is larger than current leap second and outside of leap
368            --  second range.
369
370            Corrected_Stamp := Stamp - Leaps (J).Correction;
371
372            exit;
373
374         elsif Stamp >= Leaps (J).Stamp then
375            --  Stamp is inside leap second range.
376
377            Corrected_Stamp :=
378              Leaps (J).Stamp - Leaps (J).Correction + 10_000_000 - 1;
379            Leap := Relative_Time (Stamp - Leaps (J).Stamp + 1);
380
381            exit;
382         end if;
383      end loop;
384
385      --  Apply timezone offset.
386
387      for J in Zone.Data'Range loop
388         if Corrected_Stamp >= Zone.Data (J).From then
389            Corrected_Stamp :=
390              Corrected_Stamp + Absolute_Time (Zone.Data (J).Offset);
391
392            exit;
393         end if;
394      end loop;
395
396      --  Compute julian day number and relative time.
397
398      Julian_Day :=
399        Julian_Day_Number (Corrected_Stamp / (Ticks_In_Day)) + X_Open_Epoch;
400      Time := Relative_Time (Corrected_Stamp mod (Ticks_In_Day));
401
402      Hour := Hour_Number (Time / Ticks_In_Hour);
403      Minute := Minute_Number ((Time mod Ticks_In_Hour) / Ticks_In_Minute);
404      Second :=
405        Second_Number
406         ((Time mod Ticks_In_Minute + Leap mod Ticks_In_Minute)
407            / Ticks_In_Second);
408      Nanosecond_100 :=
409        Nano_Second_100_Number
410         ((Time mod Ticks_In_Minute + Leap mod Ticks_In_Minute)
411            mod Ticks_In_Second);
412   end Split;
413
414end Matreshka.Internals.Calendars.Times;
415