gcc/ada/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-2007, 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 2,  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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with Ada.Calendar;            use Ada.Calendar;
  35 with Ada.Characters.Handling;
  36 with Ada.Strings.Unbounded;   use Ada.Strings.Unbounded;
  37 with Ada.Text_IO;
  38
  39 package body GNAT.Calendar.Time_IO is
  40
  41    type Month_Name is
  42      (January,
  43       February,
  44       March,
  45       April,
  46       May,
  47       June,
  48       July,
  49       August,
  50       September,
  51       October,
  52       November,
  53       December);
  54
  55    type Padding_Mode is (None, Zero, Space);
  56
  57    type Sec_Number is mod 2 ** 64;
  58    --  Type used to compute the number of seconds since 01/01/1970. A 32 bit
  59    --  number will cover only a period of 136 years. This means that for date
  60    --  past 2106 the computation is not possible. A 64 bits number should be
  61    --  enough for a very large period of time.
  62
  63    -----------------------
  64    -- Local Subprograms --
  65    -----------------------
  66
  67    function Am_Pm (H : Natural) return String;
  68    --  Return AM or PM depending on the hour H
  69
  70    function Hour_12 (H : Natural) return Positive;
  71    --  Convert a 1-24h format to a 0-12 hour format
  72
  73    function Image (Str : String; Length : Natural := 0) return String;
  74    --  Return Str capitalized and cut to length number of characters. If
  75    --  length is 0, then no cut operation is performed.
  76
  77    function Image
  78      (N       : Sec_Number;
  79       Padding : Padding_Mode := Zero;
  80       Length  : Natural := 0) return String;
  81    --  Return image of N. This number is eventually padded with zeros or spaces
  82    --  depending of the length required. If length is 0 then no padding occurs.
  83
  84    function Image
  85      (N       : Natural;
  86       Padding : Padding_Mode := Zero;
  87       Length  : Natural := 0) return String;
  88    --  As above with N provided in Integer format
  89
  90    -----------
  91    -- Am_Pm --
  92    -----------
  93
  94    function Am_Pm (H : Natural) return String is
  95    begin
  96       if H = 0 or else H > 12 then
  97          return "PM";
  98       else
  99          return "AM";
 100       end if;
 101    end Am_Pm;
 102
 103    -------------
 104    -- Hour_12 --
 105    -------------
 106
 107    function Hour_12 (H : Natural) return Positive is
 108    begin
 109       if H = 0 then
 110          return 12;
 111       elsif H <= 12 then
 112          return H;
 113       else --  H > 12
 114          return H - 12;
 115       end if;
 116    end Hour_12;
 117
 118    -----------
 119    -- Image --
 120    -----------
 121
 122    function Image
 123      (Str    : String;
 124       Length : Natural := 0) return String
 125    is
 126       use Ada.Characters.Handling;
 127       Local : constant String :=
 128                 To_Upper (Str (Str'First)) &
 129                   To_Lower (Str (Str'First + 1 .. Str'Last));
 130    begin
 131       if Length = 0 then
 132          return Local;
 133       else
 134          return Local (1 .. Length);
 135       end if;
 136    end Image;
 137
 138    -----------
 139    -- Image --
 140    -----------
 141
 142    function Image
 143      (N       : Natural;
 144       Padding : Padding_Mode := Zero;
 145       Length  : Natural := 0) return String
 146    is
 147    begin
 148       return Image (Sec_Number (N), Padding, Length);
 149    end Image;
 150
 151    function Image
 152      (N       : Sec_Number;
 153       Padding : Padding_Mode := Zero;
 154       Length  : Natural := 0) return String
 155    is
 156       function Pad_Char return String;
 157
 158       --------------
 159       -- Pad_Char --
 160       --------------
 161
 162       function Pad_Char return String is
 163       begin
 164          case Padding is
 165             when None  => return "";
 166             when Zero  => return "00";
 167             when Space => return "  ";
 168          end case;
 169       end Pad_Char;
 170
 171       NI  : constant String := Sec_Number'Image (N);
 172       NIP : constant String := Pad_Char & NI (2 .. NI'Last);
 173
 174    --  Start of processing for Image
 175
 176    begin
 177       if Length = 0 or else Padding = None then
 178          return NI (2 .. NI'Last);
 179       else
 180          return NIP (NIP'Last - Length + 1 .. NIP'Last);
 181       end if;
 182    end Image;
 183
 184    -----------
 185    -- Image --
 186    -----------
 187
 188    function Image
 189      (Date    : Ada.Calendar.Time;
 190       Picture : Picture_String) return String
 191    is
 192       Padding : Padding_Mode := Zero;
 193       --  Padding is set for one directive
 194
 195       Result : Unbounded_String;
 196
 197       Year       : Year_Number;
 198       Month      : Month_Number;
 199       Day        : Day_Number;
 200       Hour       : Hour_Number;
 201       Minute     : Minute_Number;
 202       Second     : Second_Number;
 203       Sub_Second : Second_Duration;
 204
 205       P : Positive;
 206
 207    begin
 208       --  Get current time in split format
 209
 210       Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
 211
 212       --  Null picture string is error
 213
 214       if Picture = "" then
 215          raise Picture_Error with "null picture string";
 216       end if;
 217
 218       --  Loop through characters of picture string, building result
 219
 220       Result := Null_Unbounded_String;
 221       P := Picture'First;
 222       while P <= Picture'Last loop
 223
 224          --  A directive has the following format "%[-_]."
 225
 226          if Picture (P) = '%' then
 227             Padding := Zero;
 228
 229             if P = Picture'Last then
 230                raise Picture_Error with "picture string ends with '%";
 231             end if;
 232
 233             --  Check for GNU extension to change the padding
 234
 235             if Picture (P + 1) = '-' then
 236                Padding := None;
 237                P := P + 1;
 238
 239             elsif Picture (P + 1) = '_' then
 240                Padding := Space;
 241                P := P + 1;
 242             end if;
 243
 244             if P = Picture'Last then
 245                raise Picture_Error with "picture string ends with '- or '_";
 246             end if;
 247
 248             case Picture (P + 1) is
 249
 250                --  Literal %
 251
 252                when '%' =>
 253                   Result := Result & '%';
 254
 255                --  A newline
 256
 257                when 'n' =>
 258                   Result := Result & ASCII.LF;
 259
 260                --  A horizontal tab
 261
 262                when 't' =>
 263                   Result := Result & ASCII.HT;
 264
 265                --  Hour (00..23)
 266
 267                when 'H' =>
 268                   Result := Result & Image (Hour, Padding, 2);
 269
 270                --  Hour (01..12)
 271
 272                when 'I' =>
 273                   Result := Result & Image (Hour_12 (Hour), Padding, 2);
 274
 275                --  Hour ( 0..23)
 276
 277                when 'k' =>
 278                   Result := Result & Image (Hour, Space, 2);
 279
 280                --  Hour ( 1..12)
 281
 282                when 'l' =>
 283                   Result := Result & Image (Hour_12 (Hour), Space, 2);
 284
 285                --  Minute (00..59)
 286
 287                when 'M' =>
 288                   Result := Result & Image (Minute, Padding, 2);
 289
 290                --  AM/PM
 291
 292                when 'p' =>
 293                   Result := Result & Am_Pm (Hour);
 294
 295                --  Time, 12-hour (hh:mm:ss [AP]M)
 296
 297                when 'r' =>
 298                   Result := Result &
 299                     Image (Hour_12 (Hour), Padding, Length => 2) & ':' &
 300                     Image (Minute, Padding, Length => 2) & ':' &
 301                     Image (Second, Padding, Length => 2) & ' ' &
 302                     Am_Pm (Hour);
 303
 304                --   Seconds since 1970-01-01  00:00:00 UTC
 305                --   (a nonstandard extension)
 306
 307                when 's' =>
 308                   declare
 309                      Sec : constant Sec_Number :=
 310                              Sec_Number (Julian_Day (Year, Month, Day)
 311                                           - Julian_Day (1970, 1, 1)) * 86_400
 312                                           + Sec_Number (Hour) * 3_600
 313                                           + Sec_Number (Minute) * 60
 314                                           + Sec_Number (Second);
 315
 316                   begin
 317                      Result := Result & Image (Sec, None);
 318                   end;
 319
 320                --  Second (00..59)
 321
 322                when 'S' =>
 323                   Result := Result & Image (Second, Padding, Length => 2);
 324
 325                --  Milliseconds (3 digits)
 326                --  Microseconds (6 digits)
 327                --  Nanoseconds  (9 digits)
 328
 329                when 'i' | 'e' | 'o' =>
 330                   declare
 331                      Sub_Sec : constant Long_Integer :=
 332                                  Long_Integer (Sub_Second * 1_000_000_000);
 333
 334                      Img1  : constant String := Sub_Sec'Img;
 335                      Img2  : constant String :=
 336                                "00000000" & Img1 (Img1'First + 1 .. Img1'Last);
 337                      Nanos : constant String :=
 338                                Img2 (Img2'Last - 8 .. Img2'Last);
 339
 340                   begin
 341                      case Picture (P + 1) is
 342                         when 'i' =>
 343                            Result := Result &
 344                              Nanos (Nanos'First .. Nanos'First + 2);
 345
 346                         when 'e' =>
 347                            Result := Result &
 348                              Nanos (Nanos'First .. Nanos'First + 5);
 349
 350                         when 'o' =>
 351                            Result := Result & Nanos;
 352
 353                         when others =>
 354                            null;
 355                      end case;
 356                   end;
 357
 358                --  Time, 24-hour (hh:mm:ss)
 359
 360                when 'T' =>
 361                   Result := Result &
 362                     Image (Hour, Padding, Length => 2)   & ':' &
 363                     Image (Minute, Padding, Length => 2) & ':' &
 364                     Image (Second, Padding, Length => 2);
 365
 366                --  Locale's abbreviated weekday name (Sun..Sat)
 367
 368                when 'a' =>
 369                   Result := Result &
 370                     Image (Day_Name'Image (Day_Of_Week (Date)), 3);
 371
 372                --  Locale's full weekday name, variable length
 373                --  (Sunday..Saturday)
 374
 375                when 'A' =>
 376                   Result := Result &
 377                     Image (Day_Name'Image (Day_Of_Week (Date)));
 378
 379                --  Locale's abbreviated month name (Jan..Dec)
 380
 381                when 'b' | 'h' =>
 382                   Result := Result &
 383                     Image (Month_Name'Image (Month_Name'Val (Month - 1)), 3);
 384
 385                --  Locale's full month name, variable length
 386                --  (January..December).
 387
 388                when 'B' =>
 389                   Result := Result &
 390                     Image (Month_Name'Image (Month_Name'Val (Month - 1)));
 391
 392                --  Locale's date and time (Sat Nov 04 12:02:33 EST 1989)
 393
 394                when 'c' =>
 395                   case Padding is
 396                      when Zero =>
 397                         Result := Result & Image (Date, "%a %b %d %T %Y");
 398                      when Space =>
 399                         Result := Result & Image (Date, "%a %b %_d %_T %Y");
 400                      when None =>
 401                         Result := Result & Image (Date, "%a %b %-d %-T %Y");
 402                   end case;
 403
 404                --   Day of month (01..31)
 405
 406                when 'd' =>
 407                   Result := Result & Image (Day, Padding, 2);
 408
 409                --  Date (mm/dd/yy)
 410
 411                when 'D' | 'x' =>
 412                   Result := Result &
 413                               Image (Month, Padding, 2) & '/' &
 414                               Image (Day, Padding, 2) & '/' &
 415                               Image (Year, Padding, 2);
 416
 417                --  Day of year (001..366)
 418
 419                when 'j' =>
 420                   Result := Result & Image (Day_In_Year (Date), Padding, 3);
 421
 422                --  Month (01..12)
 423
 424                when 'm' =>
 425                   Result := Result & Image (Month, Padding, 2);
 426
 427                --  Week number of year with Sunday as first day of week
 428                --  (00..53)
 429
 430                when 'U' =>
 431                   declare
 432                      Offset : constant Natural :=
 433                                 (Julian_Day (Year, 1, 1) + 1) mod 7;
 434
 435                      Week : constant Natural :=
 436                               1 + ((Day_In_Year (Date) - 1) + Offset) / 7;
 437
 438                   begin
 439                      Result := Result & Image (Week, Padding, 2);
 440                   end;
 441
 442                --  Day of week (0..6) with 0 corresponding to Sunday
 443
 444                when 'w' =>
 445                   declare
 446                      DOW : Natural range 0 .. 6;
 447
 448                   begin
 449                      if Day_Of_Week (Date) = Sunday then
 450                         DOW := 0;
 451                      else
 452                         DOW := Day_Name'Pos (Day_Of_Week (Date));
 453                      end if;
 454
 455                      Result := Result & Image (DOW, Length => 1);
 456                   end;
 457
 458                --  Week number of year with Monday as first day of week
 459                --  (00..53)
 460
 461                when 'W' =>
 462                   Result := Result & Image (Week_In_Year (Date), Padding, 2);
 463
 464                --  Last two digits of year (00..99)
 465
 466                when 'y' =>
 467                   declare
 468                      Y : constant Natural := Year - (Year / 100) * 100;
 469                   begin
 470                      Result := Result & Image (Y, Padding, 2);
 471                   end;
 472
 473                --   Year (1970...)
 474
 475                when 'Y' =>
 476                   Result := Result & Image (Year, None, 4);
 477
 478                when others =>
 479                   raise Picture_Error with
 480                     "unknown format character in picture string";
 481
 482             end case;
 483
 484             --  Skip past % and format character
 485
 486             P := P + 2;
 487
 488          --  Character other than % is copied into the result
 489
 490          else
 491             Result := Result & Picture (P);
 492             P := P + 1;
 493          end if;
 494       end loop;
 495
 496       return To_String (Result);
 497    end Image;
 498
 499    -----------
 500    -- Value --
 501    -----------
 502
 503    function Value (Date : String) return Ada.Calendar.Time is
 504       D          : String (1 .. 19);
 505       D_Length   : constant Natural := Date'Length;
 506
 507       Year       : Year_Number;
 508       Month      : Month_Number;
 509       Day        : Day_Number;
 510       Hour       : Hour_Number;
 511       Minute     : Minute_Number;
 512       Second     : Second_Number;
 513       Sub_Second : Second_Duration;
 514
 515       procedure Extract_Date
 516         (Year  : out Year_Number;
 517          Month : out Month_Number;
 518          Day   : out Day_Number;
 519          Y2K   : Boolean := False);
 520       --  Try and extract a date value from string D. Set Y2K to True to
 521       --  account for the 20YY case. Raise Constraint_Error if the portion
 522       --  of D corresponding to the date is not well formatted.
 523
 524       procedure Extract_Time
 525         (Index       : Positive;
 526          Hour        : out Hour_Number;
 527          Minute      : out Minute_Number;
 528          Second      : out Second_Number;
 529          Check_Space : Boolean := False);
 530       --  Try and extract a time value from string D starting from position
 531       --  Index. Set Check_Space to True to check whether the character at
 532       --  Index - 1 is a space. Raise Constraint_Error if the portion of D
 533       --  corresponding to the date is not well formatted.
 534
 535       ------------------
 536       -- Extract_Date --
 537       ------------------
 538
 539       procedure Extract_Date
 540         (Year  : out Year_Number;
 541          Month : out Month_Number;
 542          Day   : out Day_Number;
 543          Y2K   : Boolean := False)
 544       is
 545          Delim_Index : Positive := 5;
 546
 547       begin
 548          if Y2K then
 549             Delim_Index := 3;
 550          end if;
 551
 552          if (D (Delim_Index) /= '-' or else D (Delim_Index + 3) /= '-')
 553            and then
 554             (D (Delim_Index) /= '/' or else D (Delim_Index + 3) /= '/')
 555          then
 556             raise Constraint_Error;
 557          end if;
 558
 559          if Y2K then
 560             Year  := Year_Number'Value ("20" & D (1 .. 2));
 561             Month := Month_Number'Value       (D (4 .. 5));
 562             Day   := Day_Number'Value         (D (7 .. 8));
 563          else
 564             Year  := Year_Number'Value  (D (1 .. 4));
 565             Month := Month_Number'Value (D (6 .. 7));
 566             Day   := Day_Number'Value   (D (9 .. 10));
 567          end if;
 568       end Extract_Date;
 569
 570       ------------------
 571       -- Extract_Time --
 572       ------------------
 573
 574       procedure Extract_Time
 575         (Index       : Positive;
 576          Hour        : out Hour_Number;
 577          Minute      : out Minute_Number;
 578          Second      : out Second_Number;
 579          Check_Space : Boolean := False) is
 580
 581       begin
 582          if Check_Space and then D (Index - 1) /= ' ' then
 583             raise Constraint_Error;
 584          end if;
 585
 586          if D (Index + 2) /= ':' or else D (Index + 5) /= ':' then
 587             raise Constraint_Error;
 588          end if;
 589
 590          Hour   := Hour_Number'Value   (D (Index     .. Index + 1));
 591          Minute := Minute_Number'Value (D (Index + 3 .. Index + 4));
 592          Second := Second_Number'Value (D (Index + 6 .. Index + 7));
 593       end Extract_Time;
 594
 595    --  Start of processing for Value
 596
 597    begin
 598       Split (Clock, Year, Month, Day, Hour, Minute, Second, Sub_Second);
 599       Sub_Second := 0.0;
 600
 601       --  Length checks
 602
 603       if D_Length /= 8
 604         and then D_Length /= 10
 605         and then D_Length /= 17
 606         and then D_Length /= 19
 607       then
 608          raise Constraint_Error;
 609       end if;
 610
 611       --  After the correct length has been determined, it is safe to create
 612       --  a local string copy in order to avoid String'First N arithmetic.
 613
 614       D (1 .. D_Length) := Date;
 615
 616       --  Case 1:
 617
 618       --    hh:mm:ss
 619       --    yy*mm*dd
 620
 621       if D_Length = 8 then
 622
 623          if D (3) = ':' then
 624             Extract_Time (1, Hour, Minute, Second);
 625          else
 626             Extract_Date (Year, Month, Day, True);
 627             Hour   := 0;
 628             Minute := 0;
 629             Second := 0;
 630          end if;
 631
 632       --  Case 2:
 633
 634       --    yyyy*mm*dd
 635
 636       elsif D_Length = 10 then
 637          Extract_Date (Year, Month, Day);
 638          Hour   := 0;
 639          Minute := 0;
 640          Second := 0;
 641
 642       --  Case 3:
 643
 644       --    yy*mm*dd hh:mm:ss
 645
 646       elsif D_Length = 17 then
 647          Extract_Date (Year, Month, Day, True);
 648          Extract_Time (10, Hour, Minute, Second, True);
 649
 650       --  Case 4:
 651
 652       --    yyyy*mm*dd hh:mm:ss
 653
 654       else
 655          Extract_Date (Year, Month, Day);
 656          Extract_Time (12, Hour, Minute, Second, True);
 657       end if;
 658
 659       --  Sanity checks
 660
 661       if not Year'Valid
 662         or else not Month'Valid
 663         or else not Day'Valid
 664         or else not Hour'Valid
 665         or else not Minute'Valid
 666         or else not Second'Valid
 667       then
 668          raise Constraint_Error;
 669       end if;
 670
 671       return Time_Of (Year, Month, Day, Hour, Minute, Second, Sub_Second);
 672    end Value;
 673
 674    --------------
 675    -- Put_Time --
 676    --------------
 677
 678    procedure Put_Time
 679      (Date    : Ada.Calendar.Time;
 680       Picture : Picture_String)
 681    is
 682    begin
 683       Ada.Text_IO.Put (Image (Date, Picture));
 684    end Put_Time;
 685
 686 end GNAT.Calendar.Time_IO;