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                      --  Compute the number of seconds using Ada.Calendar.Time
 310                      --  values rather than Julian days to account for Daylight
 311                      --  Savings Time.
 312
 313                      Neg : Boolean  := False;
 314                      Sec : Duration := Date - Time_Of (1970, 1, 1, 0.0);
 315
 316                   begin
 317                      --  Avoid rounding errors and perform special processing
 318                      --  for dates earlier than the Unix Epoc.
 319
 320                      if Sec > 0.0 then
 321                         Sec := Sec - 0.5;
 322                      elsif Sec < 0.0 then
 323                         Neg := True;
 324                         Sec := abs (Sec + 0.5);
 325                      end if;
 326
 327                      --  Prepend a minus sign to the result since Sec_Number
 328                      --  cannot handle negative numbers.
 329
 330                      if Neg then
 331                         Result :=
 332                           Result & "-" & Image (Sec_Number (Sec), None);
 333                      else
 334                         Result := Result & Image (Sec_Number (Sec), None);
 335                      end if;
 336                   end;
 337
 338                --  Second (00..59)
 339
 340                when 'S' =>
 341                   Result := Result & Image (Second, Padding, Length => 2);
 342
 343                --  Milliseconds (3 digits)
 344                --  Microseconds (6 digits)
 345                --  Nanoseconds  (9 digits)
 346
 347                when 'i' | 'e' | 'o' =>
 348                   declare
 349                      Sub_Sec : constant Long_Integer :=
 350                                  Long_Integer (Sub_Second * 1_000_000_000);
 351
 352                      Img1  : constant String := Sub_Sec'Img;
 353                      Img2  : constant String :=
 354                                "00000000" & Img1 (Img1'First + 1 .. Img1'Last);
 355                      Nanos : constant String :=
 356                                Img2 (Img2'Last - 8 .. Img2'Last);
 357
 358                   begin
 359                      case Picture (P + 1) is
 360                         when 'i' =>
 361                            Result := Result &
 362                              Nanos (Nanos'First .. Nanos'First + 2);
 363
 364                         when 'e' =>
 365                            Result := Result &
 366                              Nanos (Nanos'First .. Nanos'First + 5);
 367
 368                         when 'o' =>
 369                            Result := Result & Nanos;
 370
 371                         when others =>
 372                            null;
 373                      end case;
 374                   end;
 375
 376                --  Time, 24-hour (hh:mm:ss)
 377
 378                when 'T' =>
 379                   Result := Result &
 380                     Image (Hour, Padding, Length => 2)   & ':' &
 381                     Image (Minute, Padding, Length => 2) & ':' &
 382                     Image (Second, Padding, Length => 2);
 383
 384                --  Locale's abbreviated weekday name (Sun..Sat)
 385
 386                when 'a' =>
 387                   Result := Result &
 388                     Image (Day_Name'Image (Day_Of_Week (Date)), 3);
 389
 390                --  Locale's full weekday name, variable length
 391                --  (Sunday..Saturday)
 392
 393                when 'A' =>
 394                   Result := Result &
 395                     Image (Day_Name'Image (Day_Of_Week (Date)));
 396
 397                --  Locale's abbreviated month name (Jan..Dec)
 398
 399                when 'b' | 'h' =>
 400                   Result := Result &
 401                     Image (Month_Name'Image (Month_Name'Val (Month - 1)), 3);
 402
 403                --  Locale's full month name, variable length
 404                --  (January..December).
 405
 406                when 'B' =>
 407                   Result := Result &
 408                     Image (Month_Name'Image (Month_Name'Val (Month - 1)));
 409
 410                --  Locale's date and time (Sat Nov 04 12:02:33 EST 1989)
 411
 412                when 'c' =>
 413                   case Padding is
 414                      when Zero =>
 415                         Result := Result & Image (Date, "%a %b %d %T %Y");
 416                      when Space =>
 417                         Result := Result & Image (Date, "%a %b %_d %_T %Y");
 418                      when None =>
 419                         Result := Result & Image (Date, "%a %b %-d %-T %Y");
 420                   end case;
 421
 422                --   Day of month (01..31)
 423
 424                when 'd' =>
 425                   Result := Result & Image (Day, Padding, 2);
 426
 427                --  Date (mm/dd/yy)
 428
 429                when 'D' | 'x' =>
 430                   Result := Result &
 431                               Image (Month, Padding, 2) & '/' &
 432                               Image (Day, Padding, 2) & '/' &
 433                               Image (Year, Padding, 2);
 434
 435                --  Day of year (001..366)
 436
 437                when 'j' =>
 438                   Result := Result & Image (Day_In_Year (Date), Padding, 3);
 439
 440                --  Month (01..12)
 441
 442                when 'm' =>
 443                   Result := Result & Image (Month, Padding, 2);
 444
 445                --  Week number of year with Sunday as first day of week
 446                --  (00..53)
 447
 448                when 'U' =>
 449                   declare
 450                      Offset : constant Natural :=
 451                                 (Julian_Day (Year, 1, 1) + 1) mod 7;
 452
 453                      Week : constant Natural :=
 454                               1 + ((Day_In_Year (Date) - 1) + Offset) / 7;
 455
 456                   begin
 457                      Result := Result & Image (Week, Padding, 2);
 458                   end;
 459
 460                --  Day of week (0..6) with 0 corresponding to Sunday
 461
 462                when 'w' =>
 463                   declare
 464                      DOW : Natural range 0 .. 6;
 465
 466                   begin
 467                      if Day_Of_Week (Date) = Sunday then
 468                         DOW := 0;
 469                      else
 470                         DOW := Day_Name'Pos (Day_Of_Week (Date));
 471                      end if;
 472
 473                      Result := Result & Image (DOW, Length => 1);
 474                   end;
 475
 476                --  Week number of year with Monday as first day of week
 477                --  (00..53)
 478
 479                when 'W' =>
 480                   Result := Result & Image (Week_In_Year (Date), Padding, 2);
 481
 482                --  Last two digits of year (00..99)
 483
 484                when 'y' =>
 485                   declare
 486                      Y : constant Natural := Year - (Year / 100) * 100;
 487                   begin
 488                      Result := Result & Image (Y, Padding, 2);
 489                   end;
 490
 491                --   Year (1970...)
 492
 493                when 'Y' =>
 494                   Result := Result & Image (Year, None, 4);
 495
 496                when others =>
 497                   raise Picture_Error with
 498                     "unknown format character in picture string";
 499
 500             end case;
 501
 502             --  Skip past % and format character
 503
 504             P := P + 2;
 505
 506          --  Character other than % is copied into the result
 507
 508          else
 509             Result := Result & Picture (P);
 510             P := P + 1;
 511          end if;
 512       end loop;
 513
 514       return To_String (Result);
 515    end Image;
 516
 517    -----------
 518    -- Value --
 519    -----------
 520
 521    function Value (Date : String) return Ada.Calendar.Time is
 522       D          : String (1 .. 19);
 523       D_Length   : constant Natural := Date'Length;
 524
 525       Year       : Year_Number;
 526       Month      : Month_Number;
 527       Day        : Day_Number;
 528       Hour       : Hour_Number;
 529       Minute     : Minute_Number;
 530       Second     : Second_Number;
 531       Sub_Second : Second_Duration;
 532
 533       procedure Extract_Date
 534         (Year  : out Year_Number;
 535          Month : out Month_Number;
 536          Day   : out Day_Number;
 537          Y2K   : Boolean := False);
 538       --  Try and extract a date value from string D. Set Y2K to True to
 539       --  account for the 20YY case. Raise Constraint_Error if the portion
 540       --  of D corresponding to the date is not well formatted.
 541
 542       procedure Extract_Time
 543         (Index       : Positive;
 544          Hour        : out Hour_Number;
 545          Minute      : out Minute_Number;
 546          Second      : out Second_Number;
 547          Check_Space : Boolean := False);
 548       --  Try and extract a time value from string D starting from position
 549       --  Index. Set Check_Space to True to check whether the character at
 550       --  Index - 1 is a space. Raise Constraint_Error if the portion of D
 551       --  corresponding to the date is not well formatted.
 552
 553       ------------------
 554       -- Extract_Date --
 555       ------------------
 556
 557       procedure Extract_Date
 558         (Year  : out Year_Number;
 559          Month : out Month_Number;
 560          Day   : out Day_Number;
 561          Y2K   : Boolean := False)
 562       is
 563          Delim_Index : Positive := 5;
 564
 565       begin
 566          if Y2K then
 567             Delim_Index := 3;
 568          end if;
 569
 570          if (D (Delim_Index) /= '-' or else D (Delim_Index + 3) /= '-')
 571            and then
 572             (D (Delim_Index) /= '/' or else D (Delim_Index + 3) /= '/')
 573          then
 574             raise Constraint_Error;
 575          end if;
 576
 577          if Y2K then
 578             Year  := Year_Number'Value ("20" & D (1 .. 2));
 579             Month := Month_Number'Value       (D (4 .. 5));
 580             Day   := Day_Number'Value         (D (7 .. 8));
 581          else
 582             Year  := Year_Number'Value  (D (1 .. 4));
 583             Month := Month_Number'Value (D (6 .. 7));
 584             Day   := Day_Number'Value   (D (9 .. 10));
 585          end if;
 586       end Extract_Date;
 587
 588       ------------------
 589       -- Extract_Time --
 590       ------------------
 591
 592       procedure Extract_Time
 593         (Index       : Positive;
 594          Hour        : out Hour_Number;
 595          Minute      : out Minute_Number;
 596          Second      : out Second_Number;
 597          Check_Space : Boolean := False) is
 598
 599       begin
 600          if Check_Space and then D (Index - 1) /= ' ' then
 601             raise Constraint_Error;
 602          end if;
 603
 604          if D (Index + 2) /= ':' or else D (Index + 5) /= ':' then
 605             raise Constraint_Error;
 606          end if;
 607
 608          Hour   := Hour_Number'Value   (D (Index     .. Index + 1));
 609          Minute := Minute_Number'Value (D (Index + 3 .. Index + 4));
 610          Second := Second_Number'Value (D (Index + 6 .. Index + 7));
 611       end Extract_Time;
 612
 613    --  Start of processing for Value
 614
 615    begin
 616       Split (Clock, Year, Month, Day, Hour, Minute, Second, Sub_Second);
 617       Sub_Second := 0.0;
 618
 619       --  Length checks
 620
 621       if D_Length /= 8
 622         and then D_Length /= 10
 623         and then D_Length /= 17
 624         and then D_Length /= 19
 625       then
 626          raise Constraint_Error;
 627       end if;
 628
 629       --  After the correct length has been determined, it is safe to create
 630       --  a local string copy in order to avoid String'First N arithmetic.
 631
 632       D (1 .. D_Length) := Date;
 633
 634       --  Case 1:
 635
 636       --    hh:mm:ss
 637       --    yy*mm*dd
 638
 639       if D_Length = 8 then
 640
 641          if D (3) = ':' then
 642             Extract_Time (1, Hour, Minute, Second);
 643          else
 644             Extract_Date (Year, Month, Day, True);
 645             Hour   := 0;
 646             Minute := 0;
 647             Second := 0;
 648          end if;
 649
 650       --  Case 2:
 651
 652       --    yyyy*mm*dd
 653
 654       elsif D_Length = 10 then
 655          Extract_Date (Year, Month, Day);
 656          Hour   := 0;
 657          Minute := 0;
 658          Second := 0;
 659
 660       --  Case 3:
 661
 662       --    yy*mm*dd hh:mm:ss
 663
 664       elsif D_Length = 17 then
 665          Extract_Date (Year, Month, Day, True);
 666          Extract_Time (10, Hour, Minute, Second, True);
 667
 668       --  Case 4:
 669
 670       --    yyyy*mm*dd hh:mm:ss
 671
 672       else
 673          Extract_Date (Year, Month, Day);
 674          Extract_Time (12, Hour, Minute, Second, True);
 675       end if;
 676
 677       --  Sanity checks
 678
 679       if not Year'Valid
 680         or else not Month'Valid
 681         or else not Day'Valid
 682         or else not Hour'Valid
 683         or else not Minute'Valid
 684         or else not Second'Valid
 685       then
 686          raise Constraint_Error;
 687       end if;
 688
 689       return Time_Of (Year, Month, Day, Hour, Minute, Second, Sub_Second);
 690    end Value;
 691
 692    --------------
 693    -- Put_Time --
 694    --------------
 695
 696    procedure Put_Time
 697      (Date    : Ada.Calendar.Time;
 698       Picture : Picture_String)
 699    is
 700    begin
 701       Ada.Text_IO.Put (Image (Date, Picture));
 702    end Put_Time;
 703
 704 end GNAT.Calendar.Time_IO;