gcc/ada/libgnat/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-2024, 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
  32 with Ada.Characters.Handling;
  33 with Ada.Strings.Unbounded;   use Ada.Strings.Unbounded;
  34 with Ada.Text_IO;
  35
  36 with GNAT.Case_Util;
  37
  38 package 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'Last 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'Last + 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
1307 end GNAT.Calendar.Time_IO;