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-2006, 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 := Picture'First;
 206
 207    begin
 208       Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
 209
 210       loop
 211          --  A directive has the following format "%[-_]."
 212
 213          if Picture (P) = '%' then
 214             Padding := Zero;
 215
 216             if P = Picture'Last then
 217                raise Picture_Error;
 218             end if;
 219
 220             --  Check for GNU extension to change the padding
 221
 222             if Picture (P + 1) = '-' then
 223                Padding := None;
 224                P := P + 1;
 225             elsif Picture (P + 1) = '_' then
 226                Padding := Space;
 227                P := P + 1;
 228             end if;
 229
 230             if P = Picture'Last then
 231                raise Picture_Error;
 232             end if;
 233
 234             case Picture (P + 1) is
 235
 236                --  Literal %
 237
 238                when '%' =>
 239                   Result := Result & '%';
 240
 241                --  A newline
 242
 243                when 'n' =>
 244                   Result := Result & ASCII.LF;
 245
 246                --  A horizontal tab
 247
 248                when 't' =>
 249                   Result := Result & ASCII.HT;
 250
 251                --  Hour (00..23)
 252
 253                when 'H' =>
 254                   Result := Result & Image (Hour, Padding, 2);
 255
 256                --  Hour (01..12)
 257
 258                when 'I' =>
 259                   Result := Result & Image (Hour_12 (Hour), Padding, 2);
 260
 261                --  Hour ( 0..23)
 262
 263                when 'k' =>
 264                   Result := Result & Image (Hour, Space, 2);
 265
 266                --  Hour ( 1..12)
 267
 268                when 'l' =>
 269                   Result := Result & Image (Hour_12 (Hour), Space, 2);
 270
 271                --  Minute (00..59)
 272
 273                when 'M' =>
 274                   Result := Result & Image (Minute, Padding, 2);
 275
 276                --  AM/PM
 277
 278                when 'p' =>
 279                   Result := Result & Am_Pm (Hour);
 280
 281                --  Time, 12-hour (hh:mm:ss [AP]M)
 282
 283                when 'r' =>
 284                   Result := Result &
 285                     Image (Hour_12 (Hour), Padding, Length => 2) & ':' &
 286                     Image (Minute, Padding, Length => 2) & ':' &
 287                     Image (Second, Padding, Length => 2) & ' ' &
 288                     Am_Pm (Hour);
 289
 290                --   Seconds since 1970-01-01  00:00:00 UTC
 291                --   (a nonstandard extension)
 292
 293                when 's' =>
 294                   declare
 295                      Sec : constant Sec_Number :=
 296                              Sec_Number (Julian_Day (Year, Month, Day)
 297                                           - Julian_Day (1970, 1, 1)) * 86_400
 298                                           + Sec_Number (Hour) * 3_600
 299                                           + Sec_Number (Minute) * 60
 300                                           + Sec_Number (Second);
 301
 302                   begin
 303                      Result := Result & Image (Sec, None);
 304                   end;
 305
 306                --  Second (00..59)
 307
 308                when 'S' =>
 309                   Result := Result & Image (Second, Padding, Length => 2);
 310
 311                --  Milliseconds (3 digits)
 312                --  Microseconds (6 digits)
 313                --  Nanoseconds  (9 digits)
 314
 315                when 'i' | 'e' | 'o' =>
 316                   declare
 317                      Sub_Sec : constant Long_Integer :=
 318                                  Long_Integer (Sub_Second * 1_000_000_000);
 319
 320                      Img1  : constant String := Sub_Sec'Img;
 321                      Img2  : constant String :=
 322                                "00000000" & Img1 (Img1'First + 1 .. Img1'Last);
 323                      Nanos : constant String :=
 324                                Img2 (Img2'Last - 8 .. Img2'Last);
 325
 326                   begin
 327                      case Picture (P + 1) is
 328                         when 'i' =>
 329                            Result := Result &
 330                              Nanos (Nanos'First .. Nanos'First + 2);
 331
 332                         when 'e' =>
 333                            Result := Result &
 334                              Nanos (Nanos'First .. Nanos'First + 5);
 335
 336                         when 'o' =>
 337                            Result := Result & Nanos;
 338
 339                         when others =>
 340                            null;
 341                      end case;
 342                   end;
 343
 344                --  Time, 24-hour (hh:mm:ss)
 345
 346                when 'T' =>
 347                   Result := Result &
 348                     Image (Hour, Padding, Length => 2)   & ':' &
 349                     Image (Minute, Padding, Length => 2) & ':' &
 350                     Image (Second, Padding, Length => 2);
 351
 352                --  Locale's abbreviated weekday name (Sun..Sat)
 353
 354                when 'a' =>
 355                   Result := Result &
 356                     Image (Day_Name'Image (Day_Of_Week (Date)), 3);
 357
 358                --  Locale's full weekday name, variable length
 359                --  (Sunday..Saturday)
 360
 361                when 'A' =>
 362                   Result := Result &
 363                     Image (Day_Name'Image (Day_Of_Week (Date)));
 364
 365                --  Locale's abbreviated month name (Jan..Dec)
 366
 367                when 'b' | 'h' =>
 368                   Result := Result &
 369                     Image (Month_Name'Image (Month_Name'Val (Month - 1)), 3);
 370
 371                --  Locale's full month name, variable length
 372                --  (January..December).
 373
 374                when 'B' =>
 375                   Result := Result &
 376                     Image (Month_Name'Image (Month_Name'Val (Month - 1)));
 377
 378                --  Locale's date and time (Sat Nov 04 12:02:33 EST 1989)
 379
 380                when 'c' =>
 381                   case Padding is
 382                      when Zero =>
 383                         Result := Result & Image (Date, "%a %b %d %T %Y");
 384                      when Space =>
 385                         Result := Result & Image (Date, "%a %b %_d %_T %Y");
 386                      when None =>
 387                         Result := Result & Image (Date, "%a %b %-d %-T %Y");
 388                   end case;
 389
 390                --   Day of month (01..31)
 391
 392                when 'd' =>
 393                   Result := Result & Image (Day, Padding, 2);
 394
 395                --  Date (mm/dd/yy)
 396
 397                when 'D' | 'x' =>
 398                   Result := Result &
 399                               Image (Month, Padding, 2) & '/' &
 400                               Image (Day, Padding, 2) & '/' &
 401                               Image (Year, Padding, 2);
 402
 403                --  Day of year (001..366)
 404
 405                when 'j' =>
 406                   Result := Result & Image (Day_In_Year (Date), Padding, 3);
 407
 408                --  Month (01..12)
 409
 410                when 'm' =>
 411                   Result := Result & Image (Month, Padding, 2);
 412
 413                --  Week number of year with Sunday as first day of week
 414                --  (00..53)
 415
 416                when 'U' =>
 417                   declare
 418                      Offset : constant Natural :=
 419                                 (Julian_Day (Year, 1, 1) + 1) mod 7;
 420
 421                      Week : constant Natural :=
 422                               1 + ((Day_In_Year (Date) - 1) + Offset) / 7;
 423
 424                   begin
 425                      Result := Result & Image (Week, Padding, 2);
 426                   end;
 427
 428                --  Day of week (0..6) with 0 corresponding to Sunday
 429
 430                when 'w' =>
 431                   declare
 432                      DOW : Natural range 0 .. 6;
 433
 434                   begin
 435                      if Day_Of_Week (Date) = Sunday then
 436                         DOW := 0;
 437                      else
 438                         DOW := Day_Name'Pos (Day_Of_Week (Date));
 439                      end if;
 440
 441                      Result := Result & Image (DOW, Length => 1);
 442                   end;
 443
 444                --  Week number of year with Monday as first day of week
 445                --  (00..53)
 446
 447                when 'W' =>
 448                   Result := Result & Image (Week_In_Year (Date), Padding, 2);
 449
 450                --  Last two digits of year (00..99)
 451
 452                when 'y' =>
 453                   declare
 454                      Y : constant Natural := Year - (Year / 100) * 100;
 455                   begin
 456                      Result := Result & Image (Y, Padding, 2);
 457                   end;
 458
 459                --   Year (1970...)
 460
 461                when 'Y' =>
 462                   Result := Result & Image (Year, None, 4);
 463
 464                when others =>
 465                   raise Picture_Error;
 466             end case;
 467
 468             P := P + 2;
 469
 470          else
 471             Result := Result & Picture (P);
 472             P := P + 1;
 473          end if;
 474
 475          exit when P > Picture'Last;
 476
 477       end loop;
 478
 479       return To_String (Result);
 480    end Image;
 481
 482    -----------
 483    -- Value --
 484    -----------
 485
 486    function Value (Date : String) return Ada.Calendar.Time is
 487       D          : String (1 .. 19);
 488       D_Length   : constant Natural := Date'Length;
 489
 490       Year       : Year_Number;
 491       Month      : Month_Number;
 492       Day        : Day_Number;
 493       Hour       : Hour_Number;
 494       Minute     : Minute_Number;
 495       Second     : Second_Number;
 496       Sub_Second : Second_Duration;
 497
 498       procedure Extract_Date
 499         (Year  : out Year_Number;
 500          Month : out Month_Number;
 501          Day   : out Day_Number;
 502          Y2K   : Boolean := False);
 503       --  Try and extract a date value from string D. Set Y2K to True to
 504       --  account for the 20YY case. Raise Constraint_Error if the portion
 505       --  of D corresponding to the date is not well formatted.
 506
 507       procedure Extract_Time
 508         (Index       : Positive;
 509          Hour        : out Hour_Number;
 510          Minute      : out Minute_Number;
 511          Second      : out Second_Number;
 512          Check_Space : Boolean := False);
 513       --  Try and extract a time value from string D starting from position
 514       --  Index. Set Check_Space to True to check whether the character at
 515       --  Index - 1 is a space. Raise Constraint_Error if the portion of D
 516       --  corresponding to the date is not well formatted.
 517
 518       ------------------
 519       -- Extract_Date --
 520       ------------------
 521
 522       procedure Extract_Date
 523         (Year  : out Year_Number;
 524          Month : out Month_Number;
 525          Day   : out Day_Number;
 526          Y2K   : Boolean := False)
 527       is
 528          Delim_Index : Positive := 5;
 529
 530       begin
 531          if Y2K then
 532             Delim_Index := 3;
 533          end if;
 534
 535          if (D (Delim_Index) /= '-' or else D (Delim_Index + 3) /= '-')
 536            and then
 537             (D (Delim_Index) /= '/' or else D (Delim_Index + 3) /= '/')
 538          then
 539             raise Constraint_Error;
 540          end if;
 541
 542          if Y2K then
 543             Year  := Year_Number'Value ("20" & D (1 .. 2));
 544             Month := Month_Number'Value       (D (4 .. 5));
 545             Day   := Day_Number'Value         (D (7 .. 8));
 546          else
 547             Year  := Year_Number'Value  (D (1 .. 4));
 548             Month := Month_Number'Value (D (6 .. 7));
 549             Day   := Day_Number'Value   (D (9 .. 10));
 550          end if;
 551       end Extract_Date;
 552
 553       ------------------
 554       -- Extract_Time --
 555       ------------------
 556
 557       procedure Extract_Time
 558         (Index       : Positive;
 559          Hour        : out Hour_Number;
 560          Minute      : out Minute_Number;
 561          Second      : out Second_Number;
 562          Check_Space : Boolean := False) is
 563
 564       begin
 565          if Check_Space and then D (Index - 1) /= ' ' then
 566             raise Constraint_Error;
 567          end if;
 568
 569          if D (Index + 2) /= ':' or else D (Index + 5) /= ':' then
 570             raise Constraint_Error;
 571          end if;
 572
 573          Hour   := Hour_Number'Value   (D (Index     .. Index + 1));
 574          Minute := Minute_Number'Value (D (Index + 3 .. Index + 4));
 575          Second := Second_Number'Value (D (Index + 6 .. Index + 7));
 576       end Extract_Time;
 577
 578    --  Start of processing for Value
 579
 580    begin
 581       Split (Clock, Year, Month, Day, Hour, Minute, Second, Sub_Second);
 582       Sub_Second := 0.0;
 583
 584       --  Length checks
 585
 586       if D_Length /= 8
 587         and then D_Length /= 10
 588         and then D_Length /= 17
 589         and then D_Length /= 19
 590       then
 591          raise Constraint_Error;
 592       end if;
 593
 594       --  After the correct length has been determined, it is safe to create
 595       --  a local string copy in order to avoid String'First N arithmetic.
 596
 597       D (1 .. D_Length) := Date;
 598
 599       --  Case 1:
 600
 601       --    hh:mm:ss
 602       --    yy*mm*dd
 603
 604       if D_Length = 8 then
 605
 606          if D (3) = ':' then
 607             Extract_Time (1, Hour, Minute, Second);
 608          else
 609             Extract_Date (Year, Month, Day, True);
 610             Hour   := 0;
 611             Minute := 0;
 612             Second := 0;
 613          end if;
 614
 615       --  Case 2:
 616
 617       --    yyyy*mm*dd
 618
 619       elsif D_Length = 10 then
 620          Extract_Date (Year, Month, Day);
 621          Hour   := 0;
 622          Minute := 0;
 623          Second := 0;
 624
 625       --  Case 3:
 626
 627       --    yy*mm*dd hh:mm:ss
 628
 629       elsif D_Length = 17 then
 630          Extract_Date (Year, Month, Day, True);
 631          Extract_Time (10, Hour, Minute, Second, True);
 632
 633       --  Case 4:
 634
 635       --    yyyy*mm*dd hh:mm:ss
 636
 637       else
 638          Extract_Date (Year, Month, Day);
 639          Extract_Time (12, Hour, Minute, Second, True);
 640       end if;
 641
 642       --  Sanity checks
 643
 644       if not Year'Valid
 645         or else not Month'Valid
 646         or else not Day'Valid
 647         or else not Hour'Valid
 648         or else not Minute'Valid
 649         or else not Second'Valid
 650       then
 651          raise Constraint_Error;
 652       end if;
 653
 654       return Time_Of (Year, Month, Day, Hour, Minute, Second, Sub_Second);
 655    end Value;
 656
 657    --------------
 658    -- Put_Time --
 659    --------------
 660
 661    procedure Put_Time
 662      (Date    : Ada.Calendar.Time;
 663       Picture : Picture_String)
 664    is
 665    begin
 666       Ada.Text_IO.Put (Image (Date, Picture));
 667    end Put_Time;
 668
 669 end GNAT.Calendar.Time_IO;