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-2010, 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 32with Ada.Calendar; use Ada.Calendar; 33with Ada.Characters.Handling; 34with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; 35with Ada.Text_IO; 36 37with GNAT.Case_Util; 38 39package 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 function Month_Name_To_Number 56 (Str : String) return Ada.Calendar.Month_Number; 57 -- Converts a string that contains an abbreviated month name to a month 58 -- number. Constraint_Error is raised if Str is not a valid month name. 59 -- Comparison is case insensitive 60 61 type Padding_Mode is (None, Zero, Space); 62 63 type Sec_Number is mod 2 ** 64; 64 -- Type used to compute the number of seconds since 01/01/1970. A 32 bit 65 -- number will cover only a period of 136 years. This means that for date 66 -- past 2106 the computation is not possible. A 64 bits number should be 67 -- enough for a very large period of time. 68 69 ----------------------- 70 -- Local Subprograms -- 71 ----------------------- 72 73 function Am_Pm (H : Natural) return String; 74 -- Return AM or PM depending on the hour H 75 76 function Hour_12 (H : Natural) return Positive; 77 -- Convert a 1-24h format to a 0-12 hour format 78 79 function Image (Str : String; Length : Natural := 0) return String; 80 -- Return Str capitalized and cut to length number of characters. If 81 -- length is 0, then no cut operation is performed. 82 83 function Image 84 (N : Sec_Number; 85 Padding : Padding_Mode := Zero; 86 Length : Natural := 0) return String; 87 -- Return image of N. This number is eventually padded with zeros or spaces 88 -- depending of the length required. If length is 0 then no padding occurs. 89 90 function Image 91 (N : Natural; 92 Padding : Padding_Mode := Zero; 93 Length : Natural := 0) return String; 94 -- As above with N provided in Integer format 95 96 ----------- 97 -- Am_Pm -- 98 ----------- 99 100 function Am_Pm (H : Natural) return String is 101 begin 102 if H = 0 or else H > 12 then 103 return "PM"; 104 else 105 return "AM"; 106 end if; 107 end Am_Pm; 108 109 ------------- 110 -- Hour_12 -- 111 ------------- 112 113 function Hour_12 (H : Natural) return Positive is 114 begin 115 if H = 0 then 116 return 12; 117 elsif H <= 12 then 118 return H; 119 else -- H > 12 120 return H - 12; 121 end if; 122 end Hour_12; 123 124 ----------- 125 -- Image -- 126 ----------- 127 128 function Image 129 (Str : String; 130 Length : Natural := 0) return String 131 is 132 use Ada.Characters.Handling; 133 Local : constant String := 134 To_Upper (Str (Str'First)) & 135 To_Lower (Str (Str'First + 1 .. Str'Last)); 136 begin 137 if Length = 0 then 138 return Local; 139 else 140 return Local (1 .. Length); 141 end if; 142 end Image; 143 144 ----------- 145 -- Image -- 146 ----------- 147 148 function Image 149 (N : Natural; 150 Padding : Padding_Mode := Zero; 151 Length : Natural := 0) return String 152 is 153 begin 154 return Image (Sec_Number (N), Padding, Length); 155 end Image; 156 157 function Image 158 (N : Sec_Number; 159 Padding : Padding_Mode := Zero; 160 Length : Natural := 0) return String 161 is 162 function Pad_Char return String; 163 164 -------------- 165 -- Pad_Char -- 166 -------------- 167 168 function Pad_Char return String is 169 begin 170 case Padding is 171 when None => return ""; 172 when Zero => return "00"; 173 when Space => return " "; 174 end case; 175 end Pad_Char; 176 177 -- Local Declarations 178 179 NI : constant String := Sec_Number'Image (N); 180 NIP : constant String := Pad_Char & NI (2 .. NI'Last); 181 182 -- Start of processing for Image 183 184 begin 185 if Length = 0 or else Padding = None then 186 return NI (2 .. NI'Last); 187 else 188 return NIP (NIP'Last - Length + 1 .. NIP'Last); 189 end if; 190 end Image; 191 192 ----------- 193 -- Image -- 194 ----------- 195 196 function Image 197 (Date : Ada.Calendar.Time; 198 Picture : Picture_String) return String 199 is 200 Padding : Padding_Mode := Zero; 201 -- Padding is set for one directive 202 203 Result : Unbounded_String; 204 205 Year : Year_Number; 206 Month : Month_Number; 207 Day : Day_Number; 208 Hour : Hour_Number; 209 Minute : Minute_Number; 210 Second : Second_Number; 211 Sub_Second : Second_Duration; 212 213 P : Positive; 214 215 begin 216 -- Get current time in split format 217 218 Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second); 219 220 -- Null picture string is error 221 222 if Picture = "" then 223 raise Picture_Error with "null picture string"; 224 end if; 225 226 -- Loop through characters of picture string, building result 227 228 Result := Null_Unbounded_String; 229 P := Picture'First; 230 while P <= Picture'Last loop 231 232 -- A directive has the following format "%[-_]." 233 234 if Picture (P) = '%' then 235 Padding := Zero; 236 237 if P = Picture'Last then 238 raise Picture_Error with "picture string ends with '%"; 239 end if; 240 241 -- Check for GNU extension to change the padding 242 243 if Picture (P + 1) = '-' then 244 Padding := None; 245 P := P + 1; 246 247 elsif Picture (P + 1) = '_' then 248 Padding := Space; 249 P := P + 1; 250 end if; 251 252 if P = Picture'Last then 253 raise Picture_Error with "picture string ends with '- or '_"; 254 end if; 255 256 case Picture (P + 1) is 257 258 -- Literal % 259 260 when '%' => 261 Result := Result & '%'; 262 263 -- A newline 264 265 when 'n' => 266 Result := Result & ASCII.LF; 267 268 -- A horizontal tab 269 270 when 't' => 271 Result := Result & ASCII.HT; 272 273 -- Hour (00..23) 274 275 when 'H' => 276 Result := Result & Image (Hour, Padding, 2); 277 278 -- Hour (01..12) 279 280 when 'I' => 281 Result := Result & Image (Hour_12 (Hour), Padding, 2); 282 283 -- Hour ( 0..23) 284 285 when 'k' => 286 Result := Result & Image (Hour, Space, 2); 287 288 -- Hour ( 1..12) 289 290 when 'l' => 291 Result := Result & Image (Hour_12 (Hour), Space, 2); 292 293 -- Minute (00..59) 294 295 when 'M' => 296 Result := Result & Image (Minute, Padding, 2); 297 298 -- AM/PM 299 300 when 'p' => 301 Result := Result & Am_Pm (Hour); 302 303 -- Time, 12-hour (hh:mm:ss [AP]M) 304 305 when 'r' => 306 Result := Result & 307 Image (Hour_12 (Hour), Padding, Length => 2) & ':' & 308 Image (Minute, Padding, Length => 2) & ':' & 309 Image (Second, Padding, Length => 2) & ' ' & 310 Am_Pm (Hour); 311 312 -- Seconds since 1970-01-01 00:00:00 UTC 313 -- (a nonstandard extension) 314 315 when 's' => 316 declare 317 -- Compute the number of seconds using Ada.Calendar.Time 318 -- values rather than Julian days to account for Daylight 319 -- Savings Time. 320 321 Neg : Boolean := False; 322 Sec : Duration := Date - Time_Of (1970, 1, 1, 0.0); 323 324 begin 325 -- Avoid rounding errors and perform special processing 326 -- for dates earlier than the Unix Epoc. 327 328 if Sec > 0.0 then 329 Sec := Sec - 0.5; 330 elsif Sec < 0.0 then 331 Neg := True; 332 Sec := abs (Sec + 0.5); 333 end if; 334 335 -- Prepend a minus sign to the result since Sec_Number 336 -- cannot handle negative numbers. 337 338 if Neg then 339 Result := 340 Result & "-" & Image (Sec_Number (Sec), None); 341 else 342 Result := Result & Image (Sec_Number (Sec), None); 343 end if; 344 end; 345 346 -- Second (00..59) 347 348 when 'S' => 349 Result := Result & Image (Second, Padding, Length => 2); 350 351 -- Milliseconds (3 digits) 352 -- Microseconds (6 digits) 353 -- Nanoseconds (9 digits) 354 355 when 'i' | 'e' | 'o' => 356 declare 357 Sub_Sec : constant Long_Integer := 358 Long_Integer (Sub_Second * 1_000_000_000); 359 360 Img1 : constant String := Sub_Sec'Img; 361 Img2 : constant String := 362 "00000000" & Img1 (Img1'First + 1 .. Img1'Last); 363 Nanos : constant String := 364 Img2 (Img2'Last - 8 .. Img2'Last); 365 366 begin 367 case Picture (P + 1) is 368 when 'i' => 369 Result := Result & 370 Nanos (Nanos'First .. Nanos'First + 2); 371 372 when 'e' => 373 Result := Result & 374 Nanos (Nanos'First .. Nanos'First + 5); 375 376 when 'o' => 377 Result := Result & Nanos; 378 379 when others => 380 null; 381 end case; 382 end; 383 384 -- Time, 24-hour (hh:mm:ss) 385 386 when 'T' => 387 Result := Result & 388 Image (Hour, Padding, Length => 2) & ':' & 389 Image (Minute, Padding, Length => 2) & ':' & 390 Image (Second, Padding, Length => 2); 391 392 -- Locale's abbreviated weekday name (Sun..Sat) 393 394 when 'a' => 395 Result := Result & 396 Image (Day_Name'Image (Day_Of_Week (Date)), 3); 397 398 -- Locale's full weekday name, variable length 399 -- (Sunday..Saturday) 400 401 when 'A' => 402 Result := Result & 403 Image (Day_Name'Image (Day_Of_Week (Date))); 404 405 -- Locale's abbreviated month name (Jan..Dec) 406 407 when 'b' | 'h' => 408 Result := Result & 409 Image (Month_Name'Image (Month_Name'Val (Month - 1)), 3); 410 411 -- Locale's full month name, variable length 412 -- (January..December). 413 414 when 'B' => 415 Result := Result & 416 Image (Month_Name'Image (Month_Name'Val (Month - 1))); 417 418 -- Locale's date and time (Sat Nov 04 12:02:33 EST 1989) 419 420 when 'c' => 421 case Padding is 422 when Zero => 423 Result := Result & Image (Date, "%a %b %d %T %Y"); 424 when Space => 425 Result := Result & Image (Date, "%a %b %_d %_T %Y"); 426 when None => 427 Result := Result & Image (Date, "%a %b %-d %-T %Y"); 428 end case; 429 430 -- Day of month (01..31) 431 432 when 'd' => 433 Result := Result & Image (Day, Padding, 2); 434 435 -- Date (mm/dd/yy) 436 437 when 'D' | 'x' => 438 Result := Result & 439 Image (Month, Padding, 2) & '/' & 440 Image (Day, Padding, 2) & '/' & 441 Image (Year, Padding, 2); 442 443 -- Day of year (001..366) 444 445 when 'j' => 446 Result := Result & Image (Day_In_Year (Date), Padding, 3); 447 448 -- Month (01..12) 449 450 when 'm' => 451 Result := Result & Image (Month, Padding, 2); 452 453 -- Week number of year with Sunday as first day of week 454 -- (00..53) 455 456 when 'U' => 457 declare 458 Offset : constant Natural := 459 (Julian_Day (Year, 1, 1) + 1) mod 7; 460 461 Week : constant Natural := 462 1 + ((Day_In_Year (Date) - 1) + Offset) / 7; 463 464 begin 465 Result := Result & Image (Week, Padding, 2); 466 end; 467 468 -- Day of week (0..6) with 0 corresponding to Sunday 469 470 when 'w' => 471 declare 472 DOW : constant Natural range 0 .. 6 := 473 (if Day_Of_Week (Date) = Sunday 474 then 0 475 else Day_Name'Pos (Day_Of_Week (Date))); 476 begin 477 Result := Result & Image (DOW, Length => 1); 478 end; 479 480 -- Week number of year with Monday as first day of week 481 -- (00..53) 482 483 when 'W' => 484 Result := Result & Image (Week_In_Year (Date), Padding, 2); 485 486 -- Last two digits of year (00..99) 487 488 when 'y' => 489 declare 490 Y : constant Natural := Year - (Year / 100) * 100; 491 begin 492 Result := Result & Image (Y, Padding, 2); 493 end; 494 495 -- Year (1970...) 496 497 when 'Y' => 498 Result := Result & Image (Year, None, 4); 499 500 when others => 501 raise Picture_Error with 502 "unknown format character in picture string"; 503 504 end case; 505 506 -- Skip past % and format character 507 508 P := P + 2; 509 510 -- Character other than % is copied into the result 511 512 else 513 Result := Result & Picture (P); 514 P := P + 1; 515 end if; 516 end loop; 517 518 return To_String (Result); 519 end Image; 520 521 -------------------------- 522 -- Month_Name_To_Number -- 523 -------------------------- 524 525 function Month_Name_To_Number 526 (Str : String) return Ada.Calendar.Month_Number 527 is 528 subtype String3 is String (1 .. 3); 529 Abbrev_Upper_Month_Names : 530 constant array (Ada.Calendar.Month_Number) of String3 := 531 ("JAN", "FEB", "MAR", "APR", "MAY", "JUN", 532 "JUL", "AUG", "SEP", "OCT", "NOV", "DEC"); 533 -- Short version of the month names, used when parsing date strings 534 535 S : String := Str; 536 537 begin 538 GNAT.Case_Util.To_Upper (S); 539 540 for J in Abbrev_Upper_Month_Names'Range loop 541 if Abbrev_Upper_Month_Names (J) = S then 542 return J; 543 end if; 544 end loop; 545 546 return Abbrev_Upper_Month_Names'First; 547 end Month_Name_To_Number; 548 549 ----------- 550 -- Value -- 551 ----------- 552 553 function Value (Date : String) return Ada.Calendar.Time is 554 D : String (1 .. 21); 555 D_Length : constant Natural := Date'Length; 556 557 Year : Year_Number; 558 Month : Month_Number; 559 Day : Day_Number; 560 Hour : Hour_Number; 561 Minute : Minute_Number; 562 Second : Second_Number; 563 564 procedure Extract_Date 565 (Year : out Year_Number; 566 Month : out Month_Number; 567 Day : out Day_Number; 568 Time_Start : out Natural); 569 -- Try and extract a date value from string D. Time_Start is set to the 570 -- first character that could be the start of time data. 571 572 procedure Extract_Time 573 (Index : Positive; 574 Hour : out Hour_Number; 575 Minute : out Minute_Number; 576 Second : out Second_Number; 577 Check_Space : Boolean := False); 578 -- Try and extract a time value from string D starting from position 579 -- Index. Set Check_Space to True to check whether the character at 580 -- Index - 1 is a space. Raise Constraint_Error if the portion of D 581 -- corresponding to the date is not well formatted. 582 583 ------------------ 584 -- Extract_Date -- 585 ------------------ 586 587 procedure Extract_Date 588 (Year : out Year_Number; 589 Month : out Month_Number; 590 Day : out Day_Number; 591 Time_Start : out Natural) 592 is 593 begin 594 if D (3) = '-' or else D (3) = '/' then 595 if D_Length = 8 or else D_Length = 17 then 596 597 -- Formats are "yy*mm*dd" or "yy*mm*dd hh:mm:ss" 598 599 if D (6) /= D (3) then 600 raise Constraint_Error; 601 end if; 602 603 Year := Year_Number'Value ("20" & D (1 .. 2)); 604 Month := Month_Number'Value (D (4 .. 5)); 605 Day := Day_Number'Value (D (7 .. 8)); 606 Time_Start := 10; 607 608 elsif D_Length = 10 or else D_Length = 19 then 609 610 -- Formats are "mm*dd*yyyy" or "mm*dd*yyyy hh:mm:ss" 611 612 if D (6) /= D (3) then 613 raise Constraint_Error; 614 end if; 615 616 Year := Year_Number'Value (D (7 .. 10)); 617 Month := Month_Number'Value (D (1 .. 2)); 618 Day := Day_Number'Value (D (4 .. 5)); 619 Time_Start := 12; 620 621 elsif D_Length = 11 or else D_Length = 20 then 622 623 -- Formats are "dd*mmm*yyyy" or "dd*mmm*yyyy hh:mm:ss" 624 625 if D (7) /= D (3) then 626 raise Constraint_Error; 627 end if; 628 629 Year := Year_Number'Value (D (8 .. 11)); 630 Month := Month_Name_To_Number (D (4 .. 6)); 631 Day := Day_Number'Value (D (1 .. 2)); 632 Time_Start := 13; 633 634 else 635 raise Constraint_Error; 636 end if; 637 638 elsif D (3) = ' ' then 639 if D_Length = 11 or else D_Length = 20 then 640 641 -- Possible formats are "dd mmm yyyy", "dd mmm yyyy hh:mm:ss" 642 643 if D (7) /= ' ' then 644 raise Constraint_Error; 645 end if; 646 647 Year := Year_Number'Value (D (8 .. 11)); 648 Month := Month_Name_To_Number (D (4 .. 6)); 649 Day := Day_Number'Value (D (1 .. 2)); 650 Time_Start := 13; 651 652 else 653 raise Constraint_Error; 654 end if; 655 656 else 657 if D_Length = 8 or else D_Length = 17 then 658 659 -- Possible formats are "yyyymmdd" or "yyyymmdd hh:mm:ss" 660 661 Year := Year_Number'Value (D (1 .. 4)); 662 Month := Month_Number'Value (D (5 .. 6)); 663 Day := Day_Number'Value (D (7 .. 8)); 664 Time_Start := 10; 665 666 elsif D_Length = 10 or else D_Length = 19 then 667 668 -- Possible formats are "yyyy*mm*dd" or "yyyy*mm*dd hh:mm:ss" 669 670 if (D (5) /= '-' and then D (5) /= '/') 671 or else D (8) /= D (5) 672 then 673 raise Constraint_Error; 674 end if; 675 676 Year := Year_Number'Value (D (1 .. 4)); 677 Month := Month_Number'Value (D (6 .. 7)); 678 Day := Day_Number'Value (D (9 .. 10)); 679 Time_Start := 12; 680 681 elsif D_Length = 11 or else D_Length = 20 then 682 683 -- Possible formats are "yyyy*mmm*dd" 684 685 if (D (5) /= '-' and then D (5) /= '/') 686 or else D (9) /= D (5) 687 then 688 raise Constraint_Error; 689 end if; 690 691 Year := Year_Number'Value (D (1 .. 4)); 692 Month := Month_Name_To_Number (D (6 .. 8)); 693 Day := Day_Number'Value (D (10 .. 11)); 694 Time_Start := 13; 695 696 elsif D_Length = 12 or else D_Length = 21 then 697 698 -- Formats are "mmm dd, yyyy" or "mmm dd, yyyy hh:mm:ss" 699 700 if D (4) /= ' ' 701 or else D (7) /= ',' 702 or else D (8) /= ' ' 703 then 704 raise Constraint_Error; 705 end if; 706 707 Year := Year_Number'Value (D (9 .. 12)); 708 Month := Month_Name_To_Number (D (1 .. 3)); 709 Day := Day_Number'Value (D (5 .. 6)); 710 Time_Start := 14; 711 712 else 713 raise Constraint_Error; 714 end if; 715 end if; 716 end Extract_Date; 717 718 ------------------ 719 -- Extract_Time -- 720 ------------------ 721 722 procedure Extract_Time 723 (Index : Positive; 724 Hour : out Hour_Number; 725 Minute : out Minute_Number; 726 Second : out Second_Number; 727 Check_Space : Boolean := False) 728 is 729 begin 730 -- If no time was specified in the string (do not allow trailing 731 -- character either) 732 733 if Index = D_Length + 2 then 734 Hour := 0; 735 Minute := 0; 736 Second := 0; 737 738 else 739 -- Not enough characters left ? 740 741 if Index /= D_Length - 7 then 742 raise Constraint_Error; 743 end if; 744 745 if Check_Space and then D (Index - 1) /= ' ' then 746 raise Constraint_Error; 747 end if; 748 749 if D (Index + 2) /= ':' or else D (Index + 5) /= ':' then 750 raise Constraint_Error; 751 end if; 752 753 Hour := Hour_Number'Value (D (Index .. Index + 1)); 754 Minute := Minute_Number'Value (D (Index + 3 .. Index + 4)); 755 Second := Second_Number'Value (D (Index + 6 .. Index + 7)); 756 end if; 757 end Extract_Time; 758 759 -- Local Declarations 760 761 Time_Start : Natural := 1; 762 763 -- Start of processing for Value 764 765 begin 766 -- Length checks 767 768 if D_Length /= 8 769 and then D_Length /= 10 770 and then D_Length /= 11 771 and then D_Length /= 12 772 and then D_Length /= 17 773 and then D_Length /= 19 774 and then D_Length /= 20 775 and then D_Length /= 21 776 then 777 raise Constraint_Error; 778 end if; 779 780 -- After the correct length has been determined, it is safe to create 781 -- a local string copy in order to avoid String'First N arithmetic. 782 783 D (1 .. D_Length) := Date; 784 785 if D_Length /= 8 or else D (3) /= ':' then 786 Extract_Date (Year, Month, Day, Time_Start); 787 Extract_Time (Time_Start, Hour, Minute, Second, Check_Space => True); 788 789 else 790 declare 791 Discard : Second_Duration; 792 pragma Unreferenced (Discard); 793 begin 794 Split (Clock, Year, Month, Day, Hour, Minute, Second, 795 Sub_Second => Discard); 796 end; 797 798 Extract_Time (1, Hour, Minute, Second, Check_Space => False); 799 end if; 800 801 -- Sanity checks 802 803 if not Year'Valid 804 or else not Month'Valid 805 or else not Day'Valid 806 or else not Hour'Valid 807 or else not Minute'Valid 808 or else not Second'Valid 809 then 810 raise Constraint_Error; 811 end if; 812 813 return Time_Of (Year, Month, Day, Hour, Minute, Second); 814 end Value; 815 816 -------------- 817 -- Put_Time -- 818 -------------- 819 820 procedure Put_Time (Date : Ada.Calendar.Time; Picture : Picture_String) is 821 begin 822 Ada.Text_IO.Put (Image (Date, Picture)); 823 end Put_Time; 824 825end GNAT.Calendar.Time_IO; 826