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-2005, AdaCore                     --
  10 --                                                                          --
  11 -- This specification is derived from the Ada Reference Manual for use with --
  12 -- GNAT. The copyright notice above, and the license provisions that follow --
  13 -- apply solely to the  contents of the part following the private keyword. --
  14 --                                                                          --
  15 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  16 -- terms of the  GNU General Public License as published  by the Free Soft- --
  17 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  18 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  19 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  20 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  21 -- for  more details.  You should have  received  a copy of the GNU General --
  22 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  23 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  24 -- Boston, MA 02110-1301, USA.                                              --
  25 --                                                                          --
  26 -- As a special exception,  if other files  instantiate  generics from this --
  27 -- unit, or you link  this unit with other files  to produce an executable, --
  28 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  29 -- covered  by the  GNU  General  Public  License.  This exception does not --
  30 -- however invalidate  any other reasons why  the executable file  might be --
  31 -- covered by the  GNU Public License.                                      --
  32 --                                                                          --
  33 -- GNAT was originally developed  by the GNAT team at  New York University. --
  34 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  35 --                                                                          --
  36 ------------------------------------------------------------------------------
  37
  38 with Ada.Calendar;            use Ada.Calendar;
  39 with Ada.Characters.Handling;
  40 with Ada.Strings.Unbounded;   use Ada.Strings.Unbounded;
  41 with Ada.Text_IO;
  42
  43 package body GNAT.Calendar.Time_IO is
  44
  45    type Month_Name is
  46      (January,
  47       February,
  48       March,
  49       April,
  50       May,
  51       June,
  52       July,
  53       August,
  54       September,
  55       October,
  56       November,
  57       December);
  58
  59    type Padding_Mode is (None, Zero, Space);
  60
  61    -----------------------
  62    -- Local Subprograms --
  63    -----------------------
  64
  65    function Am_Pm (H : Natural) return String;
  66    --  Return AM or PM depending on the hour H
  67
  68    function Hour_12 (H : Natural) return Positive;
  69    --  Convert a 1-24h format to a 0-12 hour format
  70
  71    function Image (Str : String; Length : Natural := 0) return String;
  72    --  Return Str capitalized and cut to length number of characters. If
  73    --  length is set to 0 it does not cut it.
  74
  75    function Image
  76      (N       : Long_Integer;
  77       Padding : Padding_Mode := Zero;
  78       Length  : Natural := 0) return String;
  79    --  Return image of N. This number is eventually padded with zeros or spaces
  80    --  depending of the length required. If length is 0 then no padding occurs.
  81
  82    function Image
  83      (N       : Integer;
  84       Padding : Padding_Mode := Zero;
  85       Length  : Natural := 0) return String;
  86    --  As above with N provided in Integer format
  87
  88    -----------
  89    -- Am_Pm --
  90    -----------
  91
  92    function Am_Pm (H : Natural) return String is
  93    begin
  94       if H = 0 or else H > 12 then
  95          return "PM";
  96       else
  97          return "AM";
  98       end if;
  99    end Am_Pm;
 100
 101    -------------
 102    -- Hour_12 --
 103    -------------
 104
 105    function Hour_12 (H : Natural) return Positive is
 106    begin
 107       if H = 0 then
 108          return 12;
 109       elsif H <= 12 then
 110          return H;
 111       else --  H > 12
 112          return H - 12;
 113       end if;
 114    end Hour_12;
 115
 116    -----------
 117    -- Image --
 118    -----------
 119
 120    function Image
 121      (Str    : String;
 122       Length : Natural := 0) return String
 123    is
 124       use Ada.Characters.Handling;
 125       Local : constant String :=
 126                 To_Upper (Str (1)) & To_Lower (Str (2 .. Str'Last));
 127    begin
 128       if Length = 0 then
 129          return Local;
 130       else
 131          return Local (1 .. Length);
 132       end if;
 133    end Image;
 134
 135    -----------
 136    -- Image --
 137    -----------
 138
 139    function Image
 140      (N       : Integer;
 141       Padding : Padding_Mode := Zero;
 142       Length  : Natural := 0) return String
 143    is
 144    begin
 145       return Image (Long_Integer (N), Padding, Length);
 146    end Image;
 147
 148    function Image
 149      (N       : Long_Integer;
 150       Padding : Padding_Mode := Zero;
 151       Length  : Natural := 0) return String
 152    is
 153       function Pad_Char return String;
 154
 155       --------------
 156       -- Pad_Char --
 157       --------------
 158
 159       function Pad_Char return String is
 160       begin
 161          case Padding is
 162             when None  => return "";
 163             when Zero  => return "00";
 164             when Space => return "  ";
 165          end case;
 166       end Pad_Char;
 167
 168       NI  : constant String := Long_Integer'Image (N);
 169       NIP : constant String := Pad_Char & NI (2 .. NI'Last);
 170
 171    --  Start of processing for Image
 172
 173    begin
 174       if Length = 0 or else Padding = None then
 175          return NI (2 .. NI'Last);
 176       else
 177          return NIP (NIP'Last - Length + 1 .. NIP'Last);
 178       end if;
 179    end Image;
 180
 181    -----------
 182    -- Image --
 183    -----------
 184
 185    function Image
 186      (Date    : Ada.Calendar.Time;
 187       Picture : Picture_String) return String
 188    is
 189       Padding : Padding_Mode := Zero;
 190       --  Padding is set for one directive
 191
 192       Result : Unbounded_String;
 193
 194       Year       : Year_Number;
 195       Month      : Month_Number;
 196       Day        : Day_Number;
 197       Hour       : Hour_Number;
 198       Minute     : Minute_Number;
 199       Second     : Second_Number;
 200       Sub_Second : Second_Duration;
 201
 202       P : Positive := Picture'First;
 203
 204    begin
 205       Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
 206
 207       loop
 208          --  A directive has the following format "%[-_]."
 209
 210          if Picture (P) = '%' then
 211
 212             Padding := Zero;
 213
 214             if P = Picture'Last then
 215                raise Picture_Error;
 216             end if;
 217
 218             --  Check for GNU extension to change the padding
 219
 220             if Picture (P + 1) = '-' then
 221                Padding := None;
 222                P := P + 1;
 223             elsif Picture (P + 1) = '_' then
 224                Padding := Space;
 225                P := P + 1;
 226             end if;
 227
 228             if P = Picture'Last then
 229                raise Picture_Error;
 230             end if;
 231
 232             case Picture (P + 1) is
 233
 234                --  Literal %
 235
 236                when '%' =>
 237                   Result := Result & '%';
 238
 239                --  A newline
 240
 241                when 'n' =>
 242                   Result := Result & ASCII.LF;
 243
 244                --  A horizontal tab
 245
 246                when 't' =>
 247                   Result := Result & ASCII.HT;
 248
 249                --  Hour (00..23)
 250
 251                when 'H' =>
 252                   Result := Result & Image (Hour, Padding, 2);
 253
 254                --  Hour (01..12)
 255
 256                when 'I' =>
 257                   Result := Result & Image (Hour_12 (Hour), Padding, 2);
 258
 259                --  Hour ( 0..23)
 260
 261                when 'k' =>
 262                   Result := Result & Image (Hour, Space, 2);
 263
 264                --  Hour ( 1..12)
 265
 266                when 'l' =>
 267                   Result := Result & Image (Hour_12 (Hour), Space, 2);
 268
 269                --  Minute (00..59)
 270
 271                when 'M' =>
 272                   Result := Result & Image (Minute, Padding, 2);
 273
 274                --  AM/PM
 275
 276                when 'p' =>
 277                   Result := Result & Am_Pm (Hour);
 278
 279                --  Time, 12-hour (hh:mm:ss [AP]M)
 280
 281                when 'r' =>
 282                   Result := Result &
 283                     Image (Hour_12 (Hour), Padding, Length => 2) & ':' &
 284                     Image (Minute, Padding, Length => 2) & ':' &
 285                     Image (Second, Padding, Length => 2) & ' ' &
 286                     Am_Pm (Hour);
 287
 288                --   Seconds  since 1970-01-01  00:00:00 UTC
 289                --   (a nonstandard extension)
 290
 291                when 's' =>
 292                   declare
 293                      Sec : constant Long_Integer :=
 294                              Long_Integer
 295                                ((Julian_Day (Year, Month, Day) -
 296                                   Julian_Day (1970, 1, 1)) * 86_400 +
 297                                 Hour * 3_600 + Minute * 60 + Second);
 298
 299                   begin
 300                      Result := Result & Image (Sec, None);
 301                   end;
 302
 303                --  Second (00..59)
 304
 305                when 'S' =>
 306                   Result := Result & Image (Second, Padding, Length => 2);
 307
 308                --  Milliseconds (3 digits)
 309                --  Microseconds (6 digits)
 310                --  Nanoseconds  (9 digits)
 311
 312                when 'i' | 'e' | 'o' =>
 313                   declare
 314                      Sub_Sec : constant Long_Integer :=
 315                                  Long_Integer (Sub_Second * 1_000_000_000);
 316
 317                      Img1  : constant String := Sub_Sec'Img;
 318                      Img2  : constant String :=
 319                                "00000000" & Img1 (Img1'First + 1 .. Img1'Last);
 320                      Nanos : constant String :=
 321                                Img2 (Img2'Last - 8 .. Img2'Last);
 322
 323                   begin
 324                      case Picture (P + 1) is
 325                         when 'i' =>
 326                            Result := Result &
 327                              Nanos (Nanos'First .. Nanos'First + 2);
 328
 329                         when 'e' =>
 330                            Result := Result &
 331                              Nanos (Nanos'First .. Nanos'First + 5);
 332
 333                         when 'o' =>
 334                            Result := Result & Nanos;
 335
 336                         when others =>
 337                            null;
 338                      end case;
 339                   end;
 340
 341                --  Time, 24-hour (hh:mm:ss)
 342
 343                when 'T' =>
 344                   Result := Result &
 345                     Image (Hour, Padding, Length => 2) & ':' &
 346                     Image (Minute, Padding, Length => 2) & ':' &
 347                     Image (Second, Padding, Length => 2);
 348
 349                --  Locale's abbreviated weekday name (Sun..Sat)
 350
 351                when 'a' =>
 352                   Result := Result &
 353                     Image (Day_Name'Image (Day_Of_Week (Date)), 3);
 354
 355                --  Locale's full weekday name, variable length
 356                --  (Sunday..Saturday)
 357
 358                when 'A' =>
 359                   Result := Result &
 360                     Image (Day_Name'Image (Day_Of_Week (Date)));
 361
 362                --  Locale's abbreviated month name (Jan..Dec)
 363
 364                when 'b' | 'h' =>
 365                   Result := Result &
 366                     Image (Month_Name'Image (Month_Name'Val (Month - 1)), 3);
 367
 368                --  Locale's full month name, variable length
 369                --  (January..December)
 370
 371                when 'B' =>
 372                   Result := Result &
 373                     Image (Month_Name'Image (Month_Name'Val (Month - 1)));
 374
 375                --  Locale's date and time (Sat Nov 04 12:02:33 EST 1989)
 376
 377                when 'c' =>
 378                   case Padding is
 379                      when Zero =>
 380                         Result := Result & Image (Date, "%a %b %d %T %Y");
 381                      when Space =>
 382                         Result := Result & Image (Date, "%a %b %_d %_T %Y");
 383                      when None =>
 384                         Result := Result & Image (Date, "%a %b %-d %-T %Y");
 385                   end case;
 386
 387                --   Day of month (01..31)
 388
 389                when 'd' =>
 390                   Result := Result & Image (Day, Padding, 2);
 391
 392                --  Date (mm/dd/yy)
 393
 394                when 'D' | 'x' =>
 395                   Result := Result &
 396                               Image (Month, Padding, 2) & '/' &
 397                               Image (Day, Padding, 2) & '/' &
 398                               Image (Year, Padding, 2);
 399
 400                --  Day of year (001..366)
 401
 402                when 'j' =>
 403                   Result := Result & Image (Day_In_Year (Date), Padding, 3);
 404
 405                --  Month (01..12)
 406
 407                when 'm' =>
 408                   Result := Result & Image (Month, Padding, 2);
 409
 410                --  Week number of year with Sunday as first day of week
 411                --  (00..53)
 412
 413                when 'U' =>
 414                   declare
 415                      Offset : constant Natural :=
 416                                 (Julian_Day (Year, 1, 1) + 1) mod 7;
 417
 418                      Week : constant Natural :=
 419                               1 + ((Day_In_Year (Date) - 1) + Offset) / 7;
 420
 421                   begin
 422                      Result := Result & Image (Week, Padding, 2);
 423                   end;
 424
 425                --  Day of week (0..6) with 0 corresponding to Sunday
 426
 427                when 'w' =>
 428                   declare
 429                      DOW : Natural range 0 .. 6;
 430
 431                   begin
 432                      if Day_Of_Week (Date) = Sunday then
 433                         DOW := 0;
 434                      else
 435                         DOW := Day_Name'Pos (Day_Of_Week (Date));
 436                      end if;
 437
 438                      Result := Result & Image (DOW, Length => 1);
 439                   end;
 440
 441                --  Week number of year with Monday as first day of week
 442                --  (00..53)
 443
 444                when 'W' =>
 445                   Result := Result & Image (Week_In_Year (Date), Padding, 2);
 446
 447                --  Last two digits of year (00..99)
 448
 449                when 'y' =>
 450                   declare
 451                      Y : constant Natural := Year - (Year / 100) * 100;
 452                   begin
 453                      Result := Result & Image (Y, Padding, 2);
 454                   end;
 455
 456                --   Year (1970...)
 457
 458                when 'Y' =>
 459                   Result := Result & Image (Year, None, 4);
 460
 461                when others =>
 462                   raise Picture_Error;
 463             end case;
 464
 465             P := P + 2;
 466
 467          else
 468             Result := Result & Picture (P);
 469             P := P + 1;
 470          end if;
 471
 472          exit when P > Picture'Last;
 473
 474       end loop;
 475
 476       return To_String (Result);
 477    end Image;
 478
 479    --------------
 480    -- Put_Time --
 481    --------------
 482
 483    procedure Put_Time
 484      (Date    : Ada.Calendar.Time;
 485       Picture : Picture_String)
 486    is
 487    begin
 488       Ada.Text_IO.Put (Image (Date, Picture));
 489    end Put_Time;
 490
 491 end GNAT.Calendar.Time_IO;