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-2020, 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-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 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 32with Ada.Characters.Handling; 33with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; 34with Ada.Text_IO; 35 36with GNAT.Case_Util; 37 38package body GNAT.Calendar.Time_IO is 39 40 type Month_Name is 41 (January, 42 February, 43 March, 44 April, 45 May, 46 June, 47 July, 48 August, 49 September, 50 October, 51 November, 52 December); 53 54 function Month_Name_To_Number 55 (Str : String) return Ada.Calendar.Month_Number; 56 -- Converts a string that contains an abbreviated month name to a month 57 -- number. Constraint_Error is raised if Str is not a valid month name. 58 -- Comparison is case insensitive 59 60 type Padding_Mode is (None, Zero, Space); 61 62 type Sec_Number is mod 2 ** 64; 63 -- Type used to compute the number of seconds since 01/01/1970. A 32 bit 64 -- number will cover only a period of 136 years. This means that for date 65 -- past 2106 the computation is not possible. A 64 bits number should be 66 -- enough for a very large period of time. 67 68 ----------------------- 69 -- Local Subprograms -- 70 ----------------------- 71 72 function Image_Helper 73 (Date : Ada.Calendar.Time; 74 Picture : Picture_String; 75 Time_Zone : Time_Zones.Time_Offset) return String; 76 -- This is called by the two exported Image functions. It uses the local 77 -- time zone for its computations, but uses Time_Zone when interpreting the 78 -- "%:::z" tag. 79 80 function Am_Pm (H : Natural) return String; 81 -- Return AM or PM depending on the hour H 82 83 function Hour_12 (H : Natural) return Positive; 84 -- Convert a 1-24h format to a 0-12 hour format 85 86 function Image (Str : String; Length : Natural := 0) return String; 87 -- Return Str capitalized and cut to length number of characters. If 88 -- length is 0, then no cut operation is performed. 89 90 function Image 91 (N : Sec_Number; 92 Padding : Padding_Mode := Zero; 93 Length : Natural := 0) return String; 94 -- Return image of N. This number is eventually padded with zeros or spaces 95 -- depending of the length required. If length is 0 then no padding occurs. 96 97 function Image 98 (N : Natural; 99 Padding : Padding_Mode := Zero; 100 Length : Natural := 0) return String; 101 -- As above with N provided in Integer format 102 103 procedure Parse_ISO_8601 104 (Date : String; 105 Time : out Ada.Calendar.Time; 106 Success : out Boolean); 107 -- Subsidiary of function Value. It parses the string Date, interpreted as 108 -- an ISO 8601 time representation, and returns corresponding Time value. 109 -- Success is set to False when the string is not a supported ISO 8601 110 -- date. 111 -- 112 -- Examples: 113 -- 114 -- 2017-04-14T14:47:06 20170414T14:47:06 20170414T144706 115 -- 2017-04-14T14:47:06,12 20170414T14:47:06.12 116 -- 2017-04-14T19:47:06+05 20170414T09:00:06-05:47 117 118 ----------- 119 -- Am_Pm -- 120 ----------- 121 122 function Am_Pm (H : Natural) return String is 123 begin 124 if H = 0 or else H > 12 then 125 return "PM"; 126 else 127 return "AM"; 128 end if; 129 end Am_Pm; 130 131 ------------- 132 -- Hour_12 -- 133 ------------- 134 135 function Hour_12 (H : Natural) return Positive is 136 begin 137 if H = 0 then 138 return 12; 139 elsif H <= 12 then 140 return H; 141 else -- H > 12 142 return H - 12; 143 end if; 144 end Hour_12; 145 146 ----------- 147 -- Image -- 148 ----------- 149 150 function Image 151 (Str : String; 152 Length : Natural := 0) return String 153 is 154 use Ada.Characters.Handling; 155 Local : constant String := 156 To_Upper (Str (Str'First)) & 157 To_Lower (Str (Str'First + 1 .. Str'Last)); 158 begin 159 if Length = 0 then 160 return Local; 161 else 162 return Local (1 .. Length); 163 end if; 164 end Image; 165 166 ----------- 167 -- Image -- 168 ----------- 169 170 function Image 171 (N : Natural; 172 Padding : Padding_Mode := Zero; 173 Length : Natural := 0) return String 174 is 175 begin 176 return Image (Sec_Number (N), Padding, Length); 177 end Image; 178 179 ----------- 180 -- Image -- 181 ----------- 182 183 function Image 184 (N : Sec_Number; 185 Padding : Padding_Mode := Zero; 186 Length : Natural := 0) return String 187 is 188 function Pad_Char return String; 189 190 -------------- 191 -- Pad_Char -- 192 -------------- 193 194 function Pad_Char return String is 195 begin 196 case Padding is 197 when None => return ""; 198 when Zero => return "00"; 199 when Space => return " "; 200 end case; 201 end Pad_Char; 202 203 -- Local Declarations 204 205 NI : constant String := Sec_Number'Image (N); 206 NIP : constant String := Pad_Char & NI (2 .. NI'Last); 207 208 -- Start of processing for Image 209 210 begin 211 if Length = 0 or else Padding = None then 212 return NI (2 .. NI'Last); 213 else 214 return NIP (NIP'Last - Length + 1 .. NIP'Last); 215 end if; 216 end Image; 217 218 ----------- 219 -- Image -- 220 ----------- 221 222 function Image 223 (Date : Ada.Calendar.Time; 224 Picture : Picture_String; 225 Time_Zone : Time_Zones.Time_Offset) return String 226 is 227 -- We subtract off the local time zone, and add in the requested 228 -- Time_Zone, and then pass it on to Image_Helper, which uses the 229 -- local time zone. 230 231 use Time_Zones; 232 Local_TZ : constant Time_Offset := Local_Time_Offset (Date); 233 Minute_Offset : constant Integer := Integer (Time_Zone - Local_TZ); 234 Second_Offset : constant Integer := Minute_Offset * 60; 235 begin 236 return Image_Helper 237 (Date + Duration (Second_Offset), Picture, Time_Zone); 238 end Image; 239 240 ----------- 241 -- Image -- 242 ----------- 243 244 function Image 245 (Date : Ada.Calendar.Time; 246 Picture : Picture_String) return String 247 is 248 use Time_Zones; 249 Local_TZ : constant Time_Offset := Local_Time_Offset (Date); 250 begin 251 return Image_Helper (Date, Picture, Local_TZ); 252 end Image; 253 254 ------------------ 255 -- Image_Helper -- 256 ------------------ 257 258 function Image_Helper 259 (Date : Ada.Calendar.Time; 260 Picture : Picture_String; 261 Time_Zone : Time_Zones.Time_Offset) return String 262 is 263 Padding : Padding_Mode := Zero; 264 -- Padding is set for one directive 265 266 Result : Unbounded_String; 267 268 Year : Year_Number; 269 Month : Month_Number; 270 Day : Day_Number; 271 Hour : Hour_Number; 272 Minute : Minute_Number; 273 Second : Second_Number; 274 Sub_Second : Second_Duration; 275 276 P : Positive; 277 278 begin 279 -- Get current time in split format 280 281 Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second); 282 283 -- Null picture string is error 284 285 if Picture = "" then 286 raise Picture_Error with "null picture string"; 287 end if; 288 289 -- Loop through characters of picture string, building result 290 291 Result := Null_Unbounded_String; 292 P := Picture'First; 293 while P <= Picture'Last loop 294 295 -- A directive has the following format "%[-_]." 296 297 if Picture (P) = '%' then 298 Padding := Zero; 299 300 if P = Picture'Last then 301 raise Picture_Error with "picture string ends with '%"; 302 end if; 303 304 -- Check for GNU extension to change the padding 305 306 if Picture (P + 1) = '-' then 307 Padding := None; 308 P := P + 1; 309 310 elsif Picture (P + 1) = '_' then 311 Padding := Space; 312 P := P + 1; 313 end if; 314 315 if P = Picture'Last then 316 raise Picture_Error with "picture string ends with '- or '_"; 317 end if; 318 319 case Picture (P + 1) is 320 321 -- Literal % 322 323 when '%' => 324 Result := Result & '%'; 325 326 -- A newline 327 328 when 'n' => 329 Result := Result & ASCII.LF; 330 331 -- A horizontal tab 332 333 when 't' => 334 Result := Result & ASCII.HT; 335 336 -- Hour (00..23) 337 338 when 'H' => 339 Result := Result & Image (Hour, Padding, 2); 340 341 -- Hour (01..12) 342 343 when 'I' => 344 Result := Result & Image (Hour_12 (Hour), Padding, 2); 345 346 -- Hour ( 0..23) 347 348 when 'k' => 349 Result := Result & Image (Hour, Space, 2); 350 351 -- Hour ( 1..12) 352 353 when 'l' => 354 Result := Result & Image (Hour_12 (Hour), Space, 2); 355 356 -- Minute (00..59) 357 358 when 'M' => 359 Result := Result & Image (Minute, Padding, 2); 360 361 -- AM/PM 362 363 when 'p' => 364 Result := Result & Am_Pm (Hour); 365 366 -- Time, 12-hour (hh:mm:ss [AP]M) 367 368 when 'r' => 369 Result := Result & 370 Image (Hour_12 (Hour), Padding, Length => 2) & ':' & 371 Image (Minute, Padding, Length => 2) & ':' & 372 Image (Second, Padding, Length => 2) & ' ' & 373 Am_Pm (Hour); 374 375 -- Seconds since 1970-01-01 00:00:00 UTC 376 -- (a nonstandard extension) 377 378 when 's' => 379 declare 380 -- Compute the number of seconds using Ada.Calendar.Time 381 -- values rather than Julian days to account for Daylight 382 -- Savings Time. 383 384 Neg : Boolean := False; 385 Sec : Duration := Date - Time_Of (1970, 1, 1, 0.0); 386 387 begin 388 -- Avoid rounding errors and perform special processing 389 -- for dates earlier than the Unix Epoc. 390 391 if Sec > 0.0 then 392 Sec := Sec - 0.5; 393 elsif Sec < 0.0 then 394 Neg := True; 395 Sec := abs (Sec + 0.5); 396 end if; 397 398 -- Prepend a minus sign to the result since Sec_Number 399 -- cannot handle negative numbers. 400 401 if Neg then 402 Result := 403 Result & "-" & Image (Sec_Number (Sec), None); 404 else 405 Result := Result & Image (Sec_Number (Sec), None); 406 end if; 407 end; 408 409 -- Second (00..59) 410 411 when 'S' => 412 Result := Result & Image (Second, Padding, Length => 2); 413 414 -- Milliseconds (3 digits) 415 -- Microseconds (6 digits) 416 -- Nanoseconds (9 digits) 417 418 when 'i' | 'e' | 'o' => 419 declare 420 Sub_Sec : constant Long_Integer := 421 Long_Integer (Sub_Second * 1_000_000_000); 422 423 Img1 : constant String := Sub_Sec'Img; 424 Img2 : constant String := 425 "00000000" & Img1 (Img1'First + 1 .. Img1'Last); 426 Nanos : constant String := 427 Img2 (Img2'Last - 8 .. Img2'Last); 428 429 begin 430 case Picture (P + 1) is 431 when 'i' => 432 Result := Result & 433 Nanos (Nanos'First .. Nanos'First + 2); 434 435 when 'e' => 436 Result := Result & 437 Nanos (Nanos'First .. Nanos'First + 5); 438 439 when 'o' => 440 Result := Result & Nanos; 441 442 when others => 443 null; 444 end case; 445 end; 446 447 -- Time, 24-hour (hh:mm:ss) 448 449 when 'T' => 450 Result := Result & 451 Image (Hour, Padding, Length => 2) & ':' & 452 Image (Minute, Padding, Length => 2) & ':' & 453 Image (Second, Padding, Length => 2); 454 455 -- Time zone. Append "+hh", "-hh", "+hh:mm", or "-hh:mm", as 456 -- appropriate. 457 458 when ':' => 459 declare 460 use type Time_Zones.Time_Offset; 461 TZ_Form : constant Picture_String := "%:::z"; 462 TZ : constant Natural := Natural (abs Time_Zone); 463 begin 464 if P + TZ_Form'Length - 1 <= Picture'Last 465 and then Picture (P .. P + TZ_Form'Length - 1) = "%:::z" 466 then 467 if Time_Zone >= 0 then 468 Result := Result & "+"; 469 else 470 Result := Result & "-"; 471 end if; 472 473 Result := Result & 474 Image (Integer (TZ / 60), Padding, Length => 2); 475 476 if TZ mod 60 /= 0 then 477 Result := Result & ":"; 478 Result := Result & 479 Image (TZ mod 60, Padding, Length => 2); 480 end if; 481 482 P := P + TZ_Form'Length - 2; -- will add 2 below 483 484 -- We do not support any of the other standard GNU 485 -- time-zone formats (%z, %:z, %::z, %Z). 486 487 else 488 raise Picture_Error with "unsupported picture format"; 489 end if; 490 end; 491 492 -- Locale's abbreviated weekday name (Sun..Sat) 493 494 when 'a' => 495 Result := Result & 496 Image (Day_Name'Image (Day_Of_Week (Date)), 3); 497 498 -- Locale's full weekday name, variable length 499 -- (Sunday..Saturday) 500 501 when 'A' => 502 Result := Result & 503 Image (Day_Name'Image (Day_Of_Week (Date))); 504 505 -- Locale's abbreviated month name (Jan..Dec) 506 507 when 'b' | 'h' => 508 Result := Result & 509 Image (Month_Name'Image (Month_Name'Val (Month - 1)), 3); 510 511 -- Locale's full month name, variable length 512 -- (January..December). 513 514 when 'B' => 515 Result := Result & 516 Image (Month_Name'Image (Month_Name'Val (Month - 1))); 517 518 -- Locale's date and time (Sat Nov 04 12:02:33 EST 1989) 519 520 when 'c' => 521 case Padding is 522 when Zero => 523 Result := Result & Image (Date, "%a %b %d %T %Y"); 524 when Space => 525 Result := Result & Image (Date, "%a %b %_d %_T %Y"); 526 when None => 527 Result := Result & Image (Date, "%a %b %-d %-T %Y"); 528 end case; 529 530 -- Day of month (01..31) 531 532 when 'd' => 533 Result := Result & Image (Day, Padding, 2); 534 535 -- Date (mm/dd/yy) 536 537 when 'D' | 'x' => 538 Result := Result & 539 Image (Month, Padding, 2) & '/' & 540 Image (Day, Padding, 2) & '/' & 541 Image (Year, Padding, 2); 542 543 -- Day of year (001..366) 544 545 when 'j' => 546 Result := Result & Image (Day_In_Year (Date), Padding, 3); 547 548 -- Month (01..12) 549 550 when 'm' => 551 Result := Result & Image (Month, Padding, 2); 552 553 -- Week number of year with Sunday as first day of week 554 -- (00..53) 555 556 when 'U' => 557 declare 558 Offset : constant Natural := 559 (Julian_Day (Year, 1, 1) + 1) mod 7; 560 561 Week : constant Natural := 562 1 + ((Day_In_Year (Date) - 1) + Offset) / 7; 563 564 begin 565 Result := Result & Image (Week, Padding, 2); 566 end; 567 568 -- Day of week (0..6) with 0 corresponding to Sunday 569 570 when 'w' => 571 declare 572 DOW : constant Natural range 0 .. 6 := 573 (if Day_Of_Week (Date) = Sunday 574 then 0 575 else Day_Name'Pos (Day_Of_Week (Date))); 576 begin 577 Result := Result & Image (DOW, Length => 1); 578 end; 579 580 -- Week number of year with Monday as first day of week 581 -- (00..53) 582 583 when 'W' => 584 Result := Result & Image (Week_In_Year (Date), Padding, 2); 585 586 -- Last two digits of year (00..99) 587 588 when 'y' => 589 declare 590 Y : constant Natural := Year - (Year / 100) * 100; 591 begin 592 Result := Result & Image (Y, Padding, 2); 593 end; 594 595 -- Year (1970...) 596 597 when 'Y' => 598 Result := Result & Image (Year, None, 4); 599 600 when others => 601 raise Picture_Error with 602 "unknown format character in picture string"; 603 end case; 604 605 -- Skip past % and format character 606 607 P := P + 2; 608 609 -- Character other than % is copied into the result 610 611 else 612 Result := Result & Picture (P); 613 P := P + 1; 614 end if; 615 end loop; 616 617 return To_String (Result); 618 end Image_Helper; 619 620 -------------------------- 621 -- Month_Name_To_Number -- 622 -------------------------- 623 624 function Month_Name_To_Number 625 (Str : String) return Ada.Calendar.Month_Number 626 is 627 subtype String3 is String (1 .. 3); 628 Abbrev_Upper_Month_Names : 629 constant array (Ada.Calendar.Month_Number) of String3 := 630 ("JAN", "FEB", "MAR", "APR", "MAY", "JUN", 631 "JUL", "AUG", "SEP", "OCT", "NOV", "DEC"); 632 -- Short version of the month names, used when parsing date strings 633 634 S : String := Str; 635 636 begin 637 GNAT.Case_Util.To_Upper (S); 638 639 for J in Abbrev_Upper_Month_Names'Range loop 640 if Abbrev_Upper_Month_Names (J) = S then 641 return J; 642 end if; 643 end loop; 644 645 return Abbrev_Upper_Month_Names'First; 646 end Month_Name_To_Number; 647 648 -------------------- 649 -- Parse_ISO_8601 -- 650 -------------------- 651 652 procedure Parse_ISO_8601 653 (Date : String; 654 Time : out Ada.Calendar.Time; 655 Success : out Boolean) 656 is 657 pragma Unsuppress (All_Checks); 658 -- This is necessary because the run-time library is usually compiled 659 -- with checks suppressed, and we are relying on constraint checks in 660 -- this code to catch syntax errors in the Date string (e.g. out of 661 -- bounds slices). 662 663 Index : Positive := Date'First; 664 -- The current character scan index. After a call to Advance, Index 665 -- points to the next character. 666 667 Wrong_Syntax : exception; 668 -- An exception used to signal that the scan pointer has reached an 669 -- unexpected character in the source string, or if premature 670 -- end-of-source was reached. 671 672 procedure Advance; 673 pragma Inline (Advance); 674 -- Past the current character of Date 675 676 procedure Advance_Digits (Num_Digits : Positive); 677 pragma Inline (Advance_Digits); 678 -- Past the given number of digit characters 679 680 function Scan_Day return Day_Number; 681 pragma Inline (Scan_Day); 682 -- Scan the two digits of a day number and return its value 683 684 function Scan_Hour return Hour_Number; 685 pragma Inline (Scan_Hour); 686 -- Scan the two digits of an hour number and return its value 687 688 function Scan_Minute return Minute_Number; 689 pragma Inline (Scan_Minute); 690 -- Scan the two digits of a minute number and return its value 691 692 function Scan_Month return Month_Number; 693 pragma Inline (Scan_Month); 694 -- Scan the two digits of a month number and return its value 695 696 function Scan_Second return Second_Number; 697 pragma Inline (Scan_Second); 698 -- Scan the two digits of a second number and return its value 699 700 function Scan_Separator (Expected_Symbol : Character) return Boolean; 701 pragma Inline (Scan_Separator); 702 -- If the current symbol matches the Expected_Symbol then advance the 703 -- scanner index and return True; otherwise do nothing and return False 704 705 procedure Scan_Separator (Required : Boolean; Separator : Character); 706 pragma Inline (Scan_Separator); 707 -- If Required then check that the current character matches Separator 708 -- and advance the scanner index; if not Required then do nothing. 709 710 function Scan_Subsecond return Second_Duration; 711 pragma Inline (Scan_Subsecond); 712 -- Scan all the digits of a subsecond number and return its value 713 714 function Scan_Year return Year_Number; 715 pragma Inline (Scan_Year); 716 -- Scan the four digits of a year number and return its value 717 718 function Symbol return Character; 719 pragma Inline (Symbol); 720 -- Return the current character being scanned 721 722 ------------- 723 -- Advance -- 724 ------------- 725 726 procedure Advance is 727 begin 728 -- Signal the end of the source string. This stops a complex scan 729 -- by bottoming up any recursive calls till control reaches routine 730 -- Scan, which handles the exception. 731 732 if Index > Date'Last then 733 raise Wrong_Syntax; 734 735 -- Advance the scan pointer as long as there are characters to scan, 736 -- in other words, the scan pointer has not passed the end of the 737 -- source string. 738 739 else 740 Index := Index + 1; 741 end if; 742 end Advance; 743 744 -------------------- 745 -- Advance_Digits -- 746 -------------------- 747 748 procedure Advance_Digits (Num_Digits : Positive) is 749 begin 750 for J in 1 .. Num_Digits loop 751 if Symbol not in '0' .. '9' then 752 raise Wrong_Syntax; 753 end if; 754 755 Advance; -- past digit 756 end loop; 757 end Advance_Digits; 758 759 -------------- 760 -- Scan_Day -- 761 -------------- 762 763 function Scan_Day return Day_Number is 764 From : constant Positive := Index; 765 begin 766 Advance_Digits (Num_Digits => 2); 767 return Day_Number'Value (Date (From .. Index - 1)); 768 end Scan_Day; 769 770 --------------- 771 -- Scan_Hour -- 772 --------------- 773 774 function Scan_Hour return Hour_Number is 775 From : constant Positive := Index; 776 begin 777 Advance_Digits (Num_Digits => 2); 778 return Hour_Number'Value (Date (From .. Index - 1)); 779 end Scan_Hour; 780 781 ----------------- 782 -- Scan_Minute -- 783 ----------------- 784 785 function Scan_Minute return Minute_Number is 786 From : constant Positive := Index; 787 begin 788 Advance_Digits (Num_Digits => 2); 789 return Minute_Number'Value (Date (From .. Index - 1)); 790 end Scan_Minute; 791 792 ---------------- 793 -- Scan_Month -- 794 ---------------- 795 796 function Scan_Month return Month_Number is 797 From : constant Positive := Index; 798 begin 799 Advance_Digits (Num_Digits => 2); 800 return Month_Number'Value (Date (From .. Index - 1)); 801 end Scan_Month; 802 803 ----------------- 804 -- Scan_Second -- 805 ----------------- 806 807 function Scan_Second return Second_Number is 808 From : constant Positive := Index; 809 begin 810 Advance_Digits (Num_Digits => 2); 811 return Second_Number'Value (Date (From .. Index - 1)); 812 end Scan_Second; 813 814 -------------------- 815 -- Scan_Separator -- 816 -------------------- 817 818 function Scan_Separator (Expected_Symbol : Character) return Boolean is 819 begin 820 if Symbol = Expected_Symbol then 821 Advance; 822 return True; 823 else 824 return False; 825 end if; 826 end Scan_Separator; 827 828 -------------------- 829 -- Scan_Separator -- 830 -------------------- 831 832 procedure Scan_Separator (Required : Boolean; Separator : Character) is 833 begin 834 if Required then 835 if Symbol /= Separator then 836 raise Wrong_Syntax; 837 end if; 838 839 Advance; -- Past the separator 840 end if; 841 end Scan_Separator; 842 843 -------------------- 844 -- Scan_Subsecond -- 845 -------------------- 846 847 function Scan_Subsecond return Second_Duration is 848 From : constant Positive := Index; 849 begin 850 Advance_Digits (Num_Digits => 1); 851 852 while Index <= Date'Length and then Symbol in '0' .. '9' loop 853 Advance; 854 end loop; 855 856 return Second_Duration'Value ("0." & Date (From .. Index - 1)); 857 end Scan_Subsecond; 858 859 --------------- 860 -- Scan_Year -- 861 --------------- 862 863 function Scan_Year return Year_Number is 864 From : constant Positive := Index; 865 begin 866 Advance_Digits (Num_Digits => 4); 867 return Year_Number'Value (Date (From .. Index - 1)); 868 end Scan_Year; 869 870 ------------ 871 -- Symbol -- 872 ------------ 873 874 function Symbol return Character is 875 begin 876 -- Signal the end of the source string. This stops a complex scan by 877 -- bottoming up any recursive calls till control reaches routine Scan 878 -- which handles the exception. Certain scanning scenarios may handle 879 -- this exception on their own. 880 881 if Index > Date'Last then 882 raise Wrong_Syntax; 883 884 else 885 return Date (Index); 886 end if; 887 end Symbol; 888 889 -- Local variables 890 891 use Time_Zones; 892 893 Date_Separator : constant Character := '-'; 894 Hour_Separator : constant Character := ':'; 895 896 Day : Day_Number; 897 Month : Month_Number; 898 Year : Year_Number; 899 Hour : Hour_Number := 0; 900 Minute : Minute_Number := 0; 901 Second : Second_Number := 0; 902 Subsec : Second_Duration := 0.0; 903 904 Time_Zone_Seen : Boolean := False; 905 Time_Zone_Offset : Time_Offset; -- Valid only if Time_Zone_Seen 906 907 Sep_Required : Boolean := False; 908 -- True if a separator is seen (and therefore required after it!) 909 910 subtype Sign_Type is Character with Predicate => Sign_Type in '+' | '-'; 911 912 -- Start of processing for Parse_ISO_8601 913 914 begin 915 -- Parse date 916 917 Year := Scan_Year; 918 Sep_Required := Scan_Separator (Date_Separator); 919 920 Month := Scan_Month; 921 Scan_Separator (Sep_Required, Date_Separator); 922 923 Day := Scan_Day; 924 925 if Index < Date'Last and then Symbol = 'T' then 926 Advance; 927 928 -- Parse time 929 930 Hour := Scan_Hour; 931 Sep_Required := Scan_Separator (Hour_Separator); 932 933 Minute := Scan_Minute; 934 Scan_Separator (Sep_Required, Hour_Separator); 935 936 Second := Scan_Second; 937 938 -- [ ('.' | ',') s{s} ] 939 940 if Index <= Date'Last then 941 -- A decimal fraction shall have at least one digit, and has as 942 -- many digits as supported by the underlying implementation. 943 -- The valid decimal separators are those specified in ISO 31-0, 944 -- i.e. the comma [,] or full stop [.]. Of these, the comma is 945 -- the preferred separator of ISO-8601. 946 947 if Symbol = ',' or else Symbol = '.' then 948 Advance; -- past decimal separator 949 Subsec := Scan_Subsecond; 950 end if; 951 end if; 952 953 -- [ ('Z' | ('+'|'-')hh':'mm) ] 954 955 if Index <= Date'Last then 956 Time_Zone_Seen := Symbol in 'Z' | Sign_Type; 957 958 -- Suffix 'Z' signifies that this is UTC time (time zone 0) 959 960 if Symbol = 'Z' then 961 Time_Zone_Offset := 0; 962 Advance; 963 964 -- Difference between local time and UTC: It shall be expressed 965 -- as positive (i.e. with the leading plus sign [+]) if the local 966 -- time is ahead of or equal to UTC of day and as negative (i.e. 967 -- with the leading minus sign [-]) if it is behind UTC of day. 968 -- The minutes time element of the difference may only be omitted 969 -- if the difference between the time scales is exactly an 970 -- integral number of hours. 971 972 elsif Symbol in Sign_Type then 973 declare 974 Time_Zone_Sign : constant Sign_Type := Symbol; 975 Time_Zone_Hour : Hour_Number; 976 Time_Zone_Minute : Minute_Number; 977 begin 978 Advance; 979 Time_Zone_Hour := Scan_Hour; 980 981 -- Past ':' 982 983 if Index < Date'Last and then Symbol = Hour_Separator then 984 Advance; 985 Time_Zone_Minute := Scan_Minute; 986 else 987 Time_Zone_Minute := 0; 988 end if; 989 990 -- Compute Time_Zone_Offset 991 992 Time_Zone_Offset := 993 Time_Offset (Time_Zone_Hour * 60 + Time_Zone_Minute); 994 995 case Time_Zone_Sign is 996 when '+' => null; 997 when '-' => Time_Zone_Offset := -Time_Zone_Offset; 998 end case; 999 end; 1000 else 1001 raise Wrong_Syntax; 1002 end if; 1003 end if; 1004 end if; 1005 1006 -- Check for trailing characters 1007 1008 if Index /= Date'Length + 1 then 1009 raise Wrong_Syntax; 1010 end if; 1011 1012 -- If a time zone was specified, use Ada.Calendar.Formatting.Time_Of, 1013 -- and specify the time zone. Otherwise, call GNAT.Calendar.Time_Of, 1014 -- which uses local time. 1015 1016 if Time_Zone_Seen then 1017 Time := Ada.Calendar.Formatting.Time_Of 1018 (Year, Month, Day, Hour, Minute, Second, Subsec, 1019 Time_Zone => Time_Zone_Offset); 1020 else 1021 Time := GNAT.Calendar.Time_Of 1022 (Year, Month, Day, Hour, Minute, Second, Subsec); 1023 end if; 1024 1025 -- Notify that the input string was successfully parsed 1026 1027 Success := True; 1028 1029 exception 1030 when Wrong_Syntax | Constraint_Error => 1031 -- If constraint check fails, we want to behave the same as 1032 -- Wrong_Syntax; we want the caller (Value) to try other 1033 -- allowed syntaxes. 1034 Time := 1035 Time_Of (Year_Number'First, Month_Number'First, Day_Number'First); 1036 Success := False; 1037 end Parse_ISO_8601; 1038 1039 ----------- 1040 -- Value -- 1041 ----------- 1042 1043 function Value (Date : String) return Ada.Calendar.Time is 1044 pragma Unsuppress (All_Checks); -- see comment in Parse_ISO_8601 1045 1046 D : String (1 .. 21); 1047 D_Length : constant Natural := Date'Length; 1048 1049 Year : Year_Number; 1050 Month : Month_Number; 1051 Day : Day_Number; 1052 Hour : Hour_Number; 1053 Minute : Minute_Number; 1054 Second : Second_Number; 1055 1056 procedure Extract_Date 1057 (Year : out Year_Number; 1058 Month : out Month_Number; 1059 Day : out Day_Number; 1060 Time_Start : out Natural); 1061 -- Try and extract a date value from string D. Time_Start is set to the 1062 -- first character that could be the start of time data. 1063 1064 procedure Extract_Time 1065 (Index : Positive; 1066 Hour : out Hour_Number; 1067 Minute : out Minute_Number; 1068 Second : out Second_Number; 1069 Check_Space : Boolean := False); 1070 -- Try and extract a time value from string D starting from position 1071 -- Index. Set Check_Space to True to check whether the character at 1072 -- Index - 1 is a space. Raise Constraint_Error if the portion of D 1073 -- corresponding to the date is not well formatted. 1074 1075 ------------------ 1076 -- Extract_Date -- 1077 ------------------ 1078 1079 procedure Extract_Date 1080 (Year : out Year_Number; 1081 Month : out Month_Number; 1082 Day : out Day_Number; 1083 Time_Start : out Natural) 1084 is 1085 begin 1086 if D (3) = '-' or else D (3) = '/' then 1087 if D_Length = 8 or else D_Length = 17 then 1088 1089 -- Formats are "yy*mm*dd" or "yy*mm*dd hh:mm:ss" 1090 1091 if D (6) /= D (3) then 1092 raise Constraint_Error; 1093 end if; 1094 1095 Year := Year_Number'Value ("20" & D (1 .. 2)); 1096 Month := Month_Number'Value (D (4 .. 5)); 1097 Day := Day_Number'Value (D (7 .. 8)); 1098 Time_Start := 10; 1099 1100 elsif D_Length = 10 or else D_Length = 19 then 1101 1102 -- Formats are "mm*dd*yyyy" or "mm*dd*yyyy hh:mm:ss" 1103 1104 if D (6) /= D (3) then 1105 raise Constraint_Error; 1106 end if; 1107 1108 Year := Year_Number'Value (D (7 .. 10)); 1109 Month := Month_Number'Value (D (1 .. 2)); 1110 Day := Day_Number'Value (D (4 .. 5)); 1111 Time_Start := 12; 1112 1113 elsif D_Length = 11 or else D_Length = 20 then 1114 1115 -- Formats are "dd*mmm*yyyy" or "dd*mmm*yyyy hh:mm:ss" 1116 1117 if D (7) /= D (3) then 1118 raise Constraint_Error; 1119 end if; 1120 1121 Year := Year_Number'Value (D (8 .. 11)); 1122 Month := Month_Name_To_Number (D (4 .. 6)); 1123 Day := Day_Number'Value (D (1 .. 2)); 1124 Time_Start := 13; 1125 1126 else 1127 raise Constraint_Error; 1128 end if; 1129 1130 elsif D (3) = ' ' then 1131 if D_Length = 11 or else D_Length = 20 then 1132 1133 -- Possible formats are "dd mmm yyyy", "dd mmm yyyy hh:mm:ss" 1134 1135 if D (7) /= ' ' then 1136 raise Constraint_Error; 1137 end if; 1138 1139 Year := Year_Number'Value (D (8 .. 11)); 1140 Month := Month_Name_To_Number (D (4 .. 6)); 1141 Day := Day_Number'Value (D (1 .. 2)); 1142 Time_Start := 13; 1143 1144 else 1145 raise Constraint_Error; 1146 end if; 1147 1148 else 1149 if D_Length = 8 or else D_Length = 17 then 1150 1151 -- Possible formats are "yyyymmdd" or "yyyymmdd hh:mm:ss" 1152 1153 Year := Year_Number'Value (D (1 .. 4)); 1154 Month := Month_Number'Value (D (5 .. 6)); 1155 Day := Day_Number'Value (D (7 .. 8)); 1156 Time_Start := 10; 1157 1158 elsif D_Length = 10 or else D_Length = 19 then 1159 1160 -- Possible formats are "yyyy*mm*dd" or "yyyy*mm*dd hh:mm:ss" 1161 1162 if (D (5) /= '-' and then D (5) /= '/') 1163 or else D (8) /= D (5) 1164 then 1165 raise Constraint_Error; 1166 end if; 1167 1168 Year := Year_Number'Value (D (1 .. 4)); 1169 Month := Month_Number'Value (D (6 .. 7)); 1170 Day := Day_Number'Value (D (9 .. 10)); 1171 Time_Start := 12; 1172 1173 elsif D_Length = 11 or else D_Length = 20 then 1174 1175 -- Possible formats are "yyyy*mmm*dd" 1176 1177 if (D (5) /= '-' and then D (5) /= '/') 1178 or else D (9) /= D (5) 1179 then 1180 raise Constraint_Error; 1181 end if; 1182 1183 Year := Year_Number'Value (D (1 .. 4)); 1184 Month := Month_Name_To_Number (D (6 .. 8)); 1185 Day := Day_Number'Value (D (10 .. 11)); 1186 Time_Start := 13; 1187 1188 elsif D_Length = 12 or else D_Length = 21 then 1189 1190 -- Formats are "mmm dd, yyyy" or "mmm dd, yyyy hh:mm:ss" 1191 1192 if D (4) /= ' ' 1193 or else D (7) /= ',' 1194 or else D (8) /= ' ' 1195 then 1196 raise Constraint_Error; 1197 end if; 1198 1199 Year := Year_Number'Value (D (9 .. 12)); 1200 Month := Month_Name_To_Number (D (1 .. 3)); 1201 Day := Day_Number'Value (D (5 .. 6)); 1202 Time_Start := 14; 1203 1204 else 1205 raise Constraint_Error; 1206 end if; 1207 end if; 1208 end Extract_Date; 1209 1210 ------------------ 1211 -- Extract_Time -- 1212 ------------------ 1213 1214 procedure Extract_Time 1215 (Index : Positive; 1216 Hour : out Hour_Number; 1217 Minute : out Minute_Number; 1218 Second : out Second_Number; 1219 Check_Space : Boolean := False) 1220 is 1221 begin 1222 -- If no time was specified in the string (do not allow trailing 1223 -- character either) 1224 1225 if Index = D_Length + 2 then 1226 Hour := 0; 1227 Minute := 0; 1228 Second := 0; 1229 1230 else 1231 -- Not enough characters left ? 1232 1233 if Index /= D_Length - 7 then 1234 raise Constraint_Error; 1235 end if; 1236 1237 if Check_Space and then D (Index - 1) /= ' ' then 1238 raise Constraint_Error; 1239 end if; 1240 1241 if D (Index + 2) /= ':' or else D (Index + 5) /= ':' then 1242 raise Constraint_Error; 1243 end if; 1244 1245 Hour := Hour_Number'Value (D (Index .. Index + 1)); 1246 Minute := Minute_Number'Value (D (Index + 3 .. Index + 4)); 1247 Second := Second_Number'Value (D (Index + 6 .. Index + 7)); 1248 end if; 1249 end Extract_Time; 1250 1251 -- Local Declarations 1252 1253 Success : Boolean; 1254 Time_Start : Natural := 1; 1255 Time : Ada.Calendar.Time; 1256 1257 -- Start of processing for Value 1258 1259 begin 1260 -- Let's try parsing Date as a supported ISO-8601 format. If we do not 1261 -- succeed, then retry using all the other GNAT supported formats. 1262 1263 Parse_ISO_8601 (Date, Time, Success); 1264 1265 if Success then 1266 return Time; 1267 end if; 1268 1269 -- Length checks 1270 1271 if D_Length not in 8 | 10 | 11 | 12 | 17 | 19 | 20 | 21 then 1272 raise Constraint_Error; 1273 end if; 1274 1275 -- After the correct length has been determined, it is safe to create 1276 -- a local string copy in order to avoid String'First N arithmetic. 1277 1278 D (1 .. D_Length) := Date; 1279 1280 if D_Length /= 8 or else D (3) /= ':' then 1281 Extract_Date (Year, Month, Day, Time_Start); 1282 Extract_Time (Time_Start, Hour, Minute, Second, Check_Space => True); 1283 1284 else 1285 declare 1286 Discard : Second_Duration; 1287 begin 1288 Split (Clock, Year, Month, Day, Hour, Minute, Second, 1289 Sub_Second => Discard); 1290 end; 1291 1292 Extract_Time (1, Hour, Minute, Second, Check_Space => False); 1293 end if; 1294 1295 return Time_Of (Year, Month, Day, Hour, Minute, Second); 1296 end Value; 1297 1298 -------------- 1299 -- Put_Time -- 1300 -------------- 1301 1302 procedure Put_Time (Date : Ada.Calendar.Time; Picture : Picture_String) is 1303 begin 1304 Ada.Text_IO.Put (Image (Date, Picture)); 1305 end Put_Time; 1306 1307end GNAT.Calendar.Time_IO; 1308