File : g-catiio.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME COMPONENTS --
4 -- --
5 -- G N A T . C A L E N D A R . T I M E _ I O --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1999-2014, AdaCore --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 with Ada.Calendar; use Ada.Calendar;
33 with Ada.Characters.Handling;
34 with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
35 with Ada.Text_IO;
36
37 with GNAT.Case_Util;
38
39 package body GNAT.Calendar.Time_IO is
40
41 type Month_Name is
42 (January,
43 February,
44 March,
45 April,
46 May,
47 June,
48 July,
49 August,
50 September,
51 October,
52 November,
53 December);
54
55 function Month_Name_To_Number
56 (Str : String) return Ada.Calendar.Month_Number;
57 -- Converts a string that contains an abbreviated month name to a month
58 -- number. Constraint_Error is raised if Str is not a valid month name.
59 -- Comparison is case insensitive
60
61 type Padding_Mode is (None, Zero, Space);
62
63 type Sec_Number is mod 2 ** 64;
64 -- Type used to compute the number of seconds since 01/01/1970. A 32 bit
65 -- number will cover only a period of 136 years. This means that for date
66 -- past 2106 the computation is not possible. A 64 bits number should be
67 -- enough for a very large period of time.
68
69 -----------------------
70 -- Local Subprograms --
71 -----------------------
72
73 function Am_Pm (H : Natural) return String;
74 -- Return AM or PM depending on the hour H
75
76 function Hour_12 (H : Natural) return Positive;
77 -- Convert a 1-24h format to a 0-12 hour format
78
79 function Image (Str : String; Length : Natural := 0) return String;
80 -- Return Str capitalized and cut to length number of characters. If
81 -- length is 0, then no cut operation is performed.
82
83 function Image
84 (N : Sec_Number;
85 Padding : Padding_Mode := Zero;
86 Length : Natural := 0) return String;
87 -- Return image of N. This number is eventually padded with zeros or spaces
88 -- depending of the length required. If length is 0 then no padding occurs.
89
90 function Image
91 (N : Natural;
92 Padding : Padding_Mode := Zero;
93 Length : Natural := 0) return String;
94 -- As above with N provided in Integer format
95
96 -----------
97 -- Am_Pm --
98 -----------
99
100 function Am_Pm (H : Natural) return String is
101 begin
102 if H = 0 or else H > 12 then
103 return "PM";
104 else
105 return "AM";
106 end if;
107 end Am_Pm;
108
109 -------------
110 -- Hour_12 --
111 -------------
112
113 function Hour_12 (H : Natural) return Positive is
114 begin
115 if H = 0 then
116 return 12;
117 elsif H <= 12 then
118 return H;
119 else -- H > 12
120 return H - 12;
121 end if;
122 end Hour_12;
123
124 -----------
125 -- Image --
126 -----------
127
128 function Image
129 (Str : String;
130 Length : Natural := 0) return String
131 is
132 use Ada.Characters.Handling;
133 Local : constant String :=
134 To_Upper (Str (Str'First)) &
135 To_Lower (Str (Str'First + 1 .. Str'Last));
136 begin
137 if Length = 0 then
138 return Local;
139 else
140 return Local (1 .. Length);
141 end if;
142 end Image;
143
144 -----------
145 -- Image --
146 -----------
147
148 function Image
149 (N : Natural;
150 Padding : Padding_Mode := Zero;
151 Length : Natural := 0) return String
152 is
153 begin
154 return Image (Sec_Number (N), Padding, Length);
155 end Image;
156
157 function Image
158 (N : Sec_Number;
159 Padding : Padding_Mode := Zero;
160 Length : Natural := 0) return String
161 is
162 function Pad_Char return String;
163
164 --------------
165 -- Pad_Char --
166 --------------
167
168 function Pad_Char return String is
169 begin
170 case Padding is
171 when None => return "";
172 when Zero => return "00";
173 when Space => return " ";
174 end case;
175 end Pad_Char;
176
177 -- Local Declarations
178
179 NI : constant String := Sec_Number'Image (N);
180 NIP : constant String := Pad_Char & NI (2 .. NI'Last);
181
182 -- Start of processing for Image
183
184 begin
185 if Length = 0 or else Padding = None then
186 return NI (2 .. NI'Last);
187 else
188 return NIP (NIP'Last - Length + 1 .. NIP'Last);
189 end if;
190 end Image;
191
192 -----------
193 -- Image --
194 -----------
195
196 function Image
197 (Date : Ada.Calendar.Time;
198 Picture : Picture_String) return String
199 is
200 Padding : Padding_Mode := Zero;
201 -- Padding is set for one directive
202
203 Result : Unbounded_String;
204
205 Year : Year_Number;
206 Month : Month_Number;
207 Day : Day_Number;
208 Hour : Hour_Number;
209 Minute : Minute_Number;
210 Second : Second_Number;
211 Sub_Second : Second_Duration;
212
213 P : Positive;
214
215 begin
216 -- Get current time in split format
217
218 Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
219
220 -- Null picture string is error
221
222 if Picture = "" then
223 raise Picture_Error with "null picture string";
224 end if;
225
226 -- Loop through characters of picture string, building result
227
228 Result := Null_Unbounded_String;
229 P := Picture'First;
230 while P <= Picture'Last loop
231
232 -- A directive has the following format "%[-_]."
233
234 if Picture (P) = '%' then
235 Padding := Zero;
236
237 if P = Picture'Last then
238 raise Picture_Error with "picture string ends with '%";
239 end if;
240
241 -- Check for GNU extension to change the padding
242
243 if Picture (P + 1) = '-' then
244 Padding := None;
245 P := P + 1;
246
247 elsif Picture (P + 1) = '_' then
248 Padding := Space;
249 P := P + 1;
250 end if;
251
252 if P = Picture'Last then
253 raise Picture_Error with "picture string ends with '- or '_";
254 end if;
255
256 case Picture (P + 1) is
257
258 -- Literal %
259
260 when '%' =>
261 Result := Result & '%';
262
263 -- A newline
264
265 when 'n' =>
266 Result := Result & ASCII.LF;
267
268 -- A horizontal tab
269
270 when 't' =>
271 Result := Result & ASCII.HT;
272
273 -- Hour (00..23)
274
275 when 'H' =>
276 Result := Result & Image (Hour, Padding, 2);
277
278 -- Hour (01..12)
279
280 when 'I' =>
281 Result := Result & Image (Hour_12 (Hour), Padding, 2);
282
283 -- Hour ( 0..23)
284
285 when 'k' =>
286 Result := Result & Image (Hour, Space, 2);
287
288 -- Hour ( 1..12)
289
290 when 'l' =>
291 Result := Result & Image (Hour_12 (Hour), Space, 2);
292
293 -- Minute (00..59)
294
295 when 'M' =>
296 Result := Result & Image (Minute, Padding, 2);
297
298 -- AM/PM
299
300 when 'p' =>
301 Result := Result & Am_Pm (Hour);
302
303 -- Time, 12-hour (hh:mm:ss [AP]M)
304
305 when 'r' =>
306 Result := Result &
307 Image (Hour_12 (Hour), Padding, Length => 2) & ':' &
308 Image (Minute, Padding, Length => 2) & ':' &
309 Image (Second, Padding, Length => 2) & ' ' &
310 Am_Pm (Hour);
311
312 -- Seconds since 1970-01-01 00:00:00 UTC
313 -- (a nonstandard extension)
314
315 when 's' =>
316 declare
317 -- Compute the number of seconds using Ada.Calendar.Time
318 -- values rather than Julian days to account for Daylight
319 -- Savings Time.
320
321 Neg : Boolean := False;
322 Sec : Duration := Date - Time_Of (1970, 1, 1, 0.0);
323
324 begin
325 -- Avoid rounding errors and perform special processing
326 -- for dates earlier than the Unix Epoc.
327
328 if Sec > 0.0 then
329 Sec := Sec - 0.5;
330 elsif Sec < 0.0 then
331 Neg := True;
332 Sec := abs (Sec + 0.5);
333 end if;
334
335 -- Prepend a minus sign to the result since Sec_Number
336 -- cannot handle negative numbers.
337
338 if Neg then
339 Result :=
340 Result & "-" & Image (Sec_Number (Sec), None);
341 else
342 Result := Result & Image (Sec_Number (Sec), None);
343 end if;
344 end;
345
346 -- Second (00..59)
347
348 when 'S' =>
349 Result := Result & Image (Second, Padding, Length => 2);
350
351 -- Milliseconds (3 digits)
352 -- Microseconds (6 digits)
353 -- Nanoseconds (9 digits)
354
355 when 'i' | 'e' | 'o' =>
356 declare
357 Sub_Sec : constant Long_Integer :=
358 Long_Integer (Sub_Second * 1_000_000_000);
359
360 Img1 : constant String := Sub_Sec'Img;
361 Img2 : constant String :=
362 "00000000" & Img1 (Img1'First + 1 .. Img1'Last);
363 Nanos : constant String :=
364 Img2 (Img2'Last - 8 .. Img2'Last);
365
366 begin
367 case Picture (P + 1) is
368 when 'i' =>
369 Result := Result &
370 Nanos (Nanos'First .. Nanos'First + 2);
371
372 when 'e' =>
373 Result := Result &
374 Nanos (Nanos'First .. Nanos'First + 5);
375
376 when 'o' =>
377 Result := Result & Nanos;
378
379 when others =>
380 null;
381 end case;
382 end;
383
384 -- Time, 24-hour (hh:mm:ss)
385
386 when 'T' =>
387 Result := Result &
388 Image (Hour, Padding, Length => 2) & ':' &
389 Image (Minute, Padding, Length => 2) & ':' &
390 Image (Second, Padding, Length => 2);
391
392 -- Locale's abbreviated weekday name (Sun..Sat)
393
394 when 'a' =>
395 Result := Result &
396 Image (Day_Name'Image (Day_Of_Week (Date)), 3);
397
398 -- Locale's full weekday name, variable length
399 -- (Sunday..Saturday)
400
401 when 'A' =>
402 Result := Result &
403 Image (Day_Name'Image (Day_Of_Week (Date)));
404
405 -- Locale's abbreviated month name (Jan..Dec)
406
407 when 'b' | 'h' =>
408 Result := Result &
409 Image (Month_Name'Image (Month_Name'Val (Month - 1)), 3);
410
411 -- Locale's full month name, variable length
412 -- (January..December).
413
414 when 'B' =>
415 Result := Result &
416 Image (Month_Name'Image (Month_Name'Val (Month - 1)));
417
418 -- Locale's date and time (Sat Nov 04 12:02:33 EST 1989)
419
420 when 'c' =>
421 case Padding is
422 when Zero =>
423 Result := Result & Image (Date, "%a %b %d %T %Y");
424 when Space =>
425 Result := Result & Image (Date, "%a %b %_d %_T %Y");
426 when None =>
427 Result := Result & Image (Date, "%a %b %-d %-T %Y");
428 end case;
429
430 -- Day of month (01..31)
431
432 when 'd' =>
433 Result := Result & Image (Day, Padding, 2);
434
435 -- Date (mm/dd/yy)
436
437 when 'D' | 'x' =>
438 Result := Result &
439 Image (Month, Padding, 2) & '/' &
440 Image (Day, Padding, 2) & '/' &
441 Image (Year, Padding, 2);
442
443 -- Day of year (001..366)
444
445 when 'j' =>
446 Result := Result & Image (Day_In_Year (Date), Padding, 3);
447
448 -- Month (01..12)
449
450 when 'm' =>
451 Result := Result & Image (Month, Padding, 2);
452
453 -- Week number of year with Sunday as first day of week
454 -- (00..53)
455
456 when 'U' =>
457 declare
458 Offset : constant Natural :=
459 (Julian_Day (Year, 1, 1) + 1) mod 7;
460
461 Week : constant Natural :=
462 1 + ((Day_In_Year (Date) - 1) + Offset) / 7;
463
464 begin
465 Result := Result & Image (Week, Padding, 2);
466 end;
467
468 -- Day of week (0..6) with 0 corresponding to Sunday
469
470 when 'w' =>
471 declare
472 DOW : constant Natural range 0 .. 6 :=
473 (if Day_Of_Week (Date) = Sunday
474 then 0
475 else Day_Name'Pos (Day_Of_Week (Date)));
476 begin
477 Result := Result & Image (DOW, Length => 1);
478 end;
479
480 -- Week number of year with Monday as first day of week
481 -- (00..53)
482
483 when 'W' =>
484 Result := Result & Image (Week_In_Year (Date), Padding, 2);
485
486 -- Last two digits of year (00..99)
487
488 when 'y' =>
489 declare
490 Y : constant Natural := Year - (Year / 100) * 100;
491 begin
492 Result := Result & Image (Y, Padding, 2);
493 end;
494
495 -- Year (1970...)
496
497 when 'Y' =>
498 Result := Result & Image (Year, None, 4);
499
500 when others =>
501 raise Picture_Error with
502 "unknown format character in picture string";
503
504 end case;
505
506 -- Skip past % and format character
507
508 P := P + 2;
509
510 -- Character other than % is copied into the result
511
512 else
513 Result := Result & Picture (P);
514 P := P + 1;
515 end if;
516 end loop;
517
518 return To_String (Result);
519 end Image;
520
521 --------------------------
522 -- Month_Name_To_Number --
523 --------------------------
524
525 function Month_Name_To_Number
526 (Str : String) return Ada.Calendar.Month_Number
527 is
528 subtype String3 is String (1 .. 3);
529 Abbrev_Upper_Month_Names :
530 constant array (Ada.Calendar.Month_Number) of String3 :=
531 ("JAN", "FEB", "MAR", "APR", "MAY", "JUN",
532 "JUL", "AUG", "SEP", "OCT", "NOV", "DEC");
533 -- Short version of the month names, used when parsing date strings
534
535 S : String := Str;
536
537 begin
538 GNAT.Case_Util.To_Upper (S);
539
540 for J in Abbrev_Upper_Month_Names'Range loop
541 if Abbrev_Upper_Month_Names (J) = S then
542 return J;
543 end if;
544 end loop;
545
546 return Abbrev_Upper_Month_Names'First;
547 end Month_Name_To_Number;
548
549 -----------
550 -- Value --
551 -----------
552
553 function Value (Date : String) return Ada.Calendar.Time is
554 D : String (1 .. 21);
555 D_Length : constant Natural := Date'Length;
556
557 Year : Year_Number;
558 Month : Month_Number;
559 Day : Day_Number;
560 Hour : Hour_Number;
561 Minute : Minute_Number;
562 Second : Second_Number;
563
564 procedure Extract_Date
565 (Year : out Year_Number;
566 Month : out Month_Number;
567 Day : out Day_Number;
568 Time_Start : out Natural);
569 -- Try and extract a date value from string D. Time_Start is set to the
570 -- first character that could be the start of time data.
571
572 procedure Extract_Time
573 (Index : Positive;
574 Hour : out Hour_Number;
575 Minute : out Minute_Number;
576 Second : out Second_Number;
577 Check_Space : Boolean := False);
578 -- Try and extract a time value from string D starting from position
579 -- Index. Set Check_Space to True to check whether the character at
580 -- Index - 1 is a space. Raise Constraint_Error if the portion of D
581 -- corresponding to the date is not well formatted.
582
583 ------------------
584 -- Extract_Date --
585 ------------------
586
587 procedure Extract_Date
588 (Year : out Year_Number;
589 Month : out Month_Number;
590 Day : out Day_Number;
591 Time_Start : out Natural)
592 is
593 begin
594 if D (3) = '-' or else D (3) = '/' then
595 if D_Length = 8 or else D_Length = 17 then
596
597 -- Formats are "yy*mm*dd" or "yy*mm*dd hh:mm:ss"
598
599 if D (6) /= D (3) then
600 raise Constraint_Error;
601 end if;
602
603 Year := Year_Number'Value ("20" & D (1 .. 2));
604 Month := Month_Number'Value (D (4 .. 5));
605 Day := Day_Number'Value (D (7 .. 8));
606 Time_Start := 10;
607
608 elsif D_Length = 10 or else D_Length = 19 then
609
610 -- Formats are "mm*dd*yyyy" or "mm*dd*yyyy hh:mm:ss"
611
612 if D (6) /= D (3) then
613 raise Constraint_Error;
614 end if;
615
616 Year := Year_Number'Value (D (7 .. 10));
617 Month := Month_Number'Value (D (1 .. 2));
618 Day := Day_Number'Value (D (4 .. 5));
619 Time_Start := 12;
620
621 elsif D_Length = 11 or else D_Length = 20 then
622
623 -- Formats are "dd*mmm*yyyy" or "dd*mmm*yyyy hh:mm:ss"
624
625 if D (7) /= D (3) then
626 raise Constraint_Error;
627 end if;
628
629 Year := Year_Number'Value (D (8 .. 11));
630 Month := Month_Name_To_Number (D (4 .. 6));
631 Day := Day_Number'Value (D (1 .. 2));
632 Time_Start := 13;
633
634 else
635 raise Constraint_Error;
636 end if;
637
638 elsif D (3) = ' ' then
639 if D_Length = 11 or else D_Length = 20 then
640
641 -- Possible formats are "dd mmm yyyy", "dd mmm yyyy hh:mm:ss"
642
643 if D (7) /= ' ' then
644 raise Constraint_Error;
645 end if;
646
647 Year := Year_Number'Value (D (8 .. 11));
648 Month := Month_Name_To_Number (D (4 .. 6));
649 Day := Day_Number'Value (D (1 .. 2));
650 Time_Start := 13;
651
652 else
653 raise Constraint_Error;
654 end if;
655
656 else
657 if D_Length = 8 or else D_Length = 17 then
658
659 -- Possible formats are "yyyymmdd" or "yyyymmdd hh:mm:ss"
660
661 Year := Year_Number'Value (D (1 .. 4));
662 Month := Month_Number'Value (D (5 .. 6));
663 Day := Day_Number'Value (D (7 .. 8));
664 Time_Start := 10;
665
666 elsif D_Length = 10 or else D_Length = 19 then
667
668 -- Possible formats are "yyyy*mm*dd" or "yyyy*mm*dd hh:mm:ss"
669
670 if (D (5) /= '-' and then D (5) /= '/')
671 or else D (8) /= D (5)
672 then
673 raise Constraint_Error;
674 end if;
675
676 Year := Year_Number'Value (D (1 .. 4));
677 Month := Month_Number'Value (D (6 .. 7));
678 Day := Day_Number'Value (D (9 .. 10));
679 Time_Start := 12;
680
681 elsif D_Length = 11 or else D_Length = 20 then
682
683 -- Possible formats are "yyyy*mmm*dd"
684
685 if (D (5) /= '-' and then D (5) /= '/')
686 or else D (9) /= D (5)
687 then
688 raise Constraint_Error;
689 end if;
690
691 Year := Year_Number'Value (D (1 .. 4));
692 Month := Month_Name_To_Number (D (6 .. 8));
693 Day := Day_Number'Value (D (10 .. 11));
694 Time_Start := 13;
695
696 elsif D_Length = 12 or else D_Length = 21 then
697
698 -- Formats are "mmm dd, yyyy" or "mmm dd, yyyy hh:mm:ss"
699
700 if D (4) /= ' '
701 or else D (7) /= ','
702 or else D (8) /= ' '
703 then
704 raise Constraint_Error;
705 end if;
706
707 Year := Year_Number'Value (D (9 .. 12));
708 Month := Month_Name_To_Number (D (1 .. 3));
709 Day := Day_Number'Value (D (5 .. 6));
710 Time_Start := 14;
711
712 else
713 raise Constraint_Error;
714 end if;
715 end if;
716 end Extract_Date;
717
718 ------------------
719 -- Extract_Time --
720 ------------------
721
722 procedure Extract_Time
723 (Index : Positive;
724 Hour : out Hour_Number;
725 Minute : out Minute_Number;
726 Second : out Second_Number;
727 Check_Space : Boolean := False)
728 is
729 begin
730 -- If no time was specified in the string (do not allow trailing
731 -- character either)
732
733 if Index = D_Length + 2 then
734 Hour := 0;
735 Minute := 0;
736 Second := 0;
737
738 else
739 -- Not enough characters left ?
740
741 if Index /= D_Length - 7 then
742 raise Constraint_Error;
743 end if;
744
745 if Check_Space and then D (Index - 1) /= ' ' then
746 raise Constraint_Error;
747 end if;
748
749 if D (Index + 2) /= ':' or else D (Index + 5) /= ':' then
750 raise Constraint_Error;
751 end if;
752
753 Hour := Hour_Number'Value (D (Index .. Index + 1));
754 Minute := Minute_Number'Value (D (Index + 3 .. Index + 4));
755 Second := Second_Number'Value (D (Index + 6 .. Index + 7));
756 end if;
757 end Extract_Time;
758
759 -- Local Declarations
760
761 Time_Start : Natural := 1;
762
763 -- Start of processing for Value
764
765 begin
766 -- Length checks
767
768 if D_Length /= 8
769 and then D_Length /= 10
770 and then D_Length /= 11
771 and then D_Length /= 12
772 and then D_Length /= 17
773 and then D_Length /= 19
774 and then D_Length /= 20
775 and then D_Length /= 21
776 then
777 raise Constraint_Error;
778 end if;
779
780 -- After the correct length has been determined, it is safe to create
781 -- a local string copy in order to avoid String'First N arithmetic.
782
783 D (1 .. D_Length) := Date;
784
785 if D_Length /= 8 or else D (3) /= ':' then
786 Extract_Date (Year, Month, Day, Time_Start);
787 Extract_Time (Time_Start, Hour, Minute, Second, Check_Space => True);
788
789 else
790 declare
791 Discard : Second_Duration;
792 begin
793 Split (Clock, Year, Month, Day, Hour, Minute, Second,
794 Sub_Second => Discard);
795 end;
796
797 Extract_Time (1, Hour, Minute, Second, Check_Space => False);
798 end if;
799
800 -- Sanity checks
801
802 if not Year'Valid
803 or else not Month'Valid
804 or else not Day'Valid
805 or else not Hour'Valid
806 or else not Minute'Valid
807 or else not Second'Valid
808 then
809 raise Constraint_Error;
810 end if;
811
812 return Time_Of (Year, Month, Day, Hour, Minute, Second);
813 end Value;
814
815 --------------
816 -- Put_Time --
817 --------------
818
819 procedure Put_Time (Date : Ada.Calendar.Time; Picture : Picture_String) is
820 begin
821 Ada.Text_IO.Put (Image (Date, Picture));
822 end Put_Time;
823
824 end GNAT.Calendar.Time_IO;