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