1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- G N A T . A W K -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2000-2018, 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.Exceptions; 33with Ada.Text_IO; 34with Ada.Strings.Unbounded; 35with Ada.Strings.Fixed; 36with Ada.Strings.Maps; 37with Ada.Unchecked_Deallocation; 38 39with GNAT.Directory_Operations; 40with GNAT.Dynamic_Tables; 41with GNAT.OS_Lib; 42 43package body GNAT.AWK is 44 45 use Ada; 46 use Ada.Strings.Unbounded; 47 48 ----------------------- 49 -- Local subprograms -- 50 ----------------------- 51 52 -- The following two subprograms provide a functional interface to the 53 -- two special session variables, that are manipulated explicitly by 54 -- Finalize, but must be declared after Finalize to prevent static 55 -- elaboration warnings. 56 57 function Get_Def return Session_Data_Access; 58 procedure Set_Cur; 59 60 ---------------- 61 -- Split mode -- 62 ---------------- 63 64 package Split is 65 66 type Mode is abstract tagged null record; 67 -- This is the main type which is declared abstract. This type must be 68 -- derived for each split style. 69 70 type Mode_Access is access Mode'Class; 71 72 procedure Current_Line (S : Mode; Session : Session_Type) 73 is abstract; 74 -- Split current line of Session using split mode S 75 76 ------------------------ 77 -- Split on separator -- 78 ------------------------ 79 80 type Separator (Size : Positive) is new Mode with record 81 Separators : String (1 .. Size); 82 end record; 83 84 procedure Current_Line 85 (S : Separator; 86 Session : Session_Type); 87 88 --------------------- 89 -- Split on column -- 90 --------------------- 91 92 type Column (Size : Positive) is new Mode with record 93 Columns : Widths_Set (1 .. Size); 94 end record; 95 96 procedure Current_Line (S : Column; Session : Session_Type); 97 98 end Split; 99 100 procedure Free is new Unchecked_Deallocation 101 (Split.Mode'Class, Split.Mode_Access); 102 103 ---------------- 104 -- File_Table -- 105 ---------------- 106 107 type AWK_File is access String; 108 109 package File_Table is 110 new Dynamic_Tables (AWK_File, Natural, 1, 5, 50); 111 -- List of file names associated with a Session 112 113 procedure Free is new Unchecked_Deallocation (String, AWK_File); 114 115 ----------------- 116 -- Field_Table -- 117 ----------------- 118 119 type Field_Slice is record 120 First : Positive; 121 Last : Natural; 122 end record; 123 -- This is a field slice (First .. Last) in session's current line 124 125 package Field_Table is 126 new Dynamic_Tables (Field_Slice, Natural, 1, 10, 100); 127 -- List of fields for the current line 128 129 -------------- 130 -- Patterns -- 131 -------------- 132 133 -- Define all patterns style: exact string, regular expression, boolean 134 -- function. 135 136 package Patterns is 137 138 type Pattern is abstract tagged null record; 139 -- This is the main type which is declared abstract. This type must be 140 -- derived for each patterns style. 141 142 type Pattern_Access is access Pattern'Class; 143 144 function Match 145 (P : Pattern; 146 Session : Session_Type) return Boolean 147 is abstract; 148 -- Returns True if P match for the current session and False otherwise 149 150 procedure Release (P : in out Pattern); 151 -- Release memory used by the pattern structure 152 153 -------------------------- 154 -- Exact string pattern -- 155 -------------------------- 156 157 type String_Pattern is new Pattern with record 158 Str : Unbounded_String; 159 Rank : Count; 160 end record; 161 162 function Match 163 (P : String_Pattern; 164 Session : Session_Type) return Boolean; 165 166 -------------------------------- 167 -- Regular expression pattern -- 168 -------------------------------- 169 170 type Pattern_Matcher_Access is access Regpat.Pattern_Matcher; 171 172 type Regexp_Pattern is new Pattern with record 173 Regx : Pattern_Matcher_Access; 174 Rank : Count; 175 end record; 176 177 function Match 178 (P : Regexp_Pattern; 179 Session : Session_Type) return Boolean; 180 181 procedure Release (P : in out Regexp_Pattern); 182 183 ------------------------------ 184 -- Boolean function pattern -- 185 ------------------------------ 186 187 type Callback_Pattern is new Pattern with record 188 Pattern : Pattern_Callback; 189 end record; 190 191 function Match 192 (P : Callback_Pattern; 193 Session : Session_Type) return Boolean; 194 195 end Patterns; 196 197 procedure Free is new Unchecked_Deallocation 198 (Patterns.Pattern'Class, Patterns.Pattern_Access); 199 200 ------------- 201 -- Actions -- 202 ------------- 203 204 -- Define all action style : simple call, call with matches 205 206 package Actions is 207 208 type Action is abstract tagged null record; 209 -- This is the main type which is declared abstract. This type must be 210 -- derived for each action style. 211 212 type Action_Access is access Action'Class; 213 214 procedure Call 215 (A : Action; 216 Session : Session_Type) is abstract; 217 -- Call action A as required 218 219 ------------------- 220 -- Simple action -- 221 ------------------- 222 223 type Simple_Action is new Action with record 224 Proc : Action_Callback; 225 end record; 226 227 procedure Call 228 (A : Simple_Action; 229 Session : Session_Type); 230 231 ------------------------- 232 -- Action with matches -- 233 ------------------------- 234 235 type Match_Action is new Action with record 236 Proc : Match_Action_Callback; 237 end record; 238 239 procedure Call 240 (A : Match_Action; 241 Session : Session_Type); 242 243 end Actions; 244 245 procedure Free is new Unchecked_Deallocation 246 (Actions.Action'Class, Actions.Action_Access); 247 248 -------------------------- 249 -- Pattern/Action table -- 250 -------------------------- 251 252 type Pattern_Action is record 253 Pattern : Patterns.Pattern_Access; -- If Pattern is True 254 Action : Actions.Action_Access; -- Action will be called 255 end record; 256 257 package Pattern_Action_Table is 258 new Dynamic_Tables (Pattern_Action, Natural, 1, 5, 50); 259 260 ------------------ 261 -- Session Data -- 262 ------------------ 263 264 type Session_Data is record 265 Current_File : Text_IO.File_Type; 266 Current_Line : Unbounded_String; 267 Separators : Split.Mode_Access; 268 Files : File_Table.Instance; 269 File_Index : Natural := 0; 270 Fields : Field_Table.Instance; 271 Filters : Pattern_Action_Table.Instance; 272 NR : Natural := 0; 273 FNR : Natural := 0; 274 Matches : Regpat.Match_Array (0 .. 100); 275 -- Latest matches for the regexp pattern 276 end record; 277 278 procedure Free is 279 new Unchecked_Deallocation (Session_Data, Session_Data_Access); 280 281 -------------- 282 -- Finalize -- 283 -------------- 284 285 procedure Finalize (Session : in out Session_Type) is 286 begin 287 -- We release the session data only if it is not the default session 288 289 if Session.Data /= Get_Def then 290 -- Release separators 291 292 Free (Session.Data.Separators); 293 294 Free (Session.Data); 295 296 -- Since we have closed the current session, set it to point now to 297 -- the default session. 298 299 Set_Cur; 300 end if; 301 end Finalize; 302 303 ---------------- 304 -- Initialize -- 305 ---------------- 306 307 procedure Initialize (Session : in out Session_Type) is 308 begin 309 Session.Data := new Session_Data; 310 311 -- Initialize separators 312 313 Session.Data.Separators := 314 new Split.Separator'(Default_Separators'Length, Default_Separators); 315 316 -- Initialize all tables 317 318 File_Table.Init (Session.Data.Files); 319 Field_Table.Init (Session.Data.Fields); 320 Pattern_Action_Table.Init (Session.Data.Filters); 321 end Initialize; 322 323 ----------------------- 324 -- Session Variables -- 325 ----------------------- 326 327 Def_Session : Session_Type; 328 Cur_Session : Session_Type; 329 330 ---------------------- 331 -- Private Services -- 332 ---------------------- 333 334 function Always_True return Boolean; 335 -- A function that always returns True 336 337 function Apply_Filters 338 (Session : Session_Type) return Boolean; 339 -- Apply any filters for which the Pattern is True for Session. It returns 340 -- True if a least one filters has been applied (i.e. associated action 341 -- callback has been called). 342 343 procedure Open_Next_File 344 (Session : Session_Type); 345 pragma Inline (Open_Next_File); 346 -- Open next file for Session closing current file if needed. It raises 347 -- End_Error if there is no more file in the table. 348 349 procedure Raise_With_Info 350 (E : Exceptions.Exception_Id; 351 Message : String; 352 Session : Session_Type); 353 pragma No_Return (Raise_With_Info); 354 -- Raises exception E with the message prepended with the current line 355 -- number and the filename if possible. 356 357 procedure Read_Line (Session : Session_Type); 358 -- Read a line for the Session and set Current_Line 359 360 procedure Split_Line (Session : Session_Type); 361 -- Split session's Current_Line according to the session separators and 362 -- set the Fields table. This procedure can be called at any time. 363 364 ---------------------- 365 -- Private Packages -- 366 ---------------------- 367 368 ------------- 369 -- Actions -- 370 ------------- 371 372 package body Actions is 373 374 ---------- 375 -- Call -- 376 ---------- 377 378 procedure Call 379 (A : Simple_Action; 380 Session : Session_Type) 381 is 382 pragma Unreferenced (Session); 383 begin 384 A.Proc.all; 385 end Call; 386 387 ---------- 388 -- Call -- 389 ---------- 390 391 procedure Call 392 (A : Match_Action; 393 Session : Session_Type) 394 is 395 begin 396 A.Proc (Session.Data.Matches); 397 end Call; 398 399 end Actions; 400 401 -------------- 402 -- Patterns -- 403 -------------- 404 405 package body Patterns is 406 407 ----------- 408 -- Match -- 409 ----------- 410 411 function Match 412 (P : String_Pattern; 413 Session : Session_Type) return Boolean 414 is 415 begin 416 return P.Str = Field (P.Rank, Session); 417 end Match; 418 419 ----------- 420 -- Match -- 421 ----------- 422 423 function Match 424 (P : Regexp_Pattern; 425 Session : Session_Type) return Boolean 426 is 427 use type Regpat.Match_Location; 428 begin 429 Regpat.Match 430 (P.Regx.all, Field (P.Rank, Session), Session.Data.Matches); 431 return Session.Data.Matches (0) /= Regpat.No_Match; 432 end Match; 433 434 ----------- 435 -- Match -- 436 ----------- 437 438 function Match 439 (P : Callback_Pattern; 440 Session : Session_Type) return Boolean 441 is 442 pragma Unreferenced (Session); 443 begin 444 return P.Pattern.all; 445 end Match; 446 447 ------------- 448 -- Release -- 449 ------------- 450 451 procedure Release (P : in out Pattern) is 452 pragma Unreferenced (P); 453 begin 454 null; 455 end Release; 456 457 ------------- 458 -- Release -- 459 ------------- 460 461 procedure Release (P : in out Regexp_Pattern) is 462 procedure Free is new Unchecked_Deallocation 463 (Regpat.Pattern_Matcher, Pattern_Matcher_Access); 464 begin 465 Free (P.Regx); 466 end Release; 467 468 end Patterns; 469 470 ----------- 471 -- Split -- 472 ----------- 473 474 package body Split is 475 476 use Ada.Strings; 477 478 ------------------ 479 -- Current_Line -- 480 ------------------ 481 482 procedure Current_Line (S : Separator; Session : Session_Type) is 483 Line : constant String := To_String (Session.Data.Current_Line); 484 Fields : Field_Table.Instance renames Session.Data.Fields; 485 Seps : constant Maps.Character_Set := Maps.To_Set (S.Separators); 486 487 Start : Natural; 488 Stop : Natural; 489 490 begin 491 -- First field start here 492 493 Start := Line'First; 494 495 -- Record the first field start position which is the first character 496 -- in the line. 497 498 Field_Table.Increment_Last (Fields); 499 Fields.Table (Field_Table.Last (Fields)).First := Start; 500 501 loop 502 -- Look for next separator 503 504 Stop := Fixed.Index 505 (Source => Line (Start .. Line'Last), 506 Set => Seps); 507 508 exit when Stop = 0; 509 510 Fields.Table (Field_Table.Last (Fields)).Last := Stop - 1; 511 512 -- If separators are set to the default (space and tab) we skip 513 -- all spaces and tabs following current field. 514 515 if S.Separators = Default_Separators then 516 Start := Fixed.Index 517 (Line (Stop + 1 .. Line'Last), 518 Maps.To_Set (Default_Separators), 519 Outside, 520 Strings.Forward); 521 522 if Start = 0 then 523 Start := Stop + 1; 524 end if; 525 526 else 527 Start := Stop + 1; 528 end if; 529 530 -- Record in the field table the start of this new field 531 532 Field_Table.Increment_Last (Fields); 533 Fields.Table (Field_Table.Last (Fields)).First := Start; 534 535 end loop; 536 537 Fields.Table (Field_Table.Last (Fields)).Last := Line'Last; 538 end Current_Line; 539 540 ------------------ 541 -- Current_Line -- 542 ------------------ 543 544 procedure Current_Line (S : Column; Session : Session_Type) is 545 Line : constant String := To_String (Session.Data.Current_Line); 546 Fields : Field_Table.Instance renames Session.Data.Fields; 547 Start : Positive := Line'First; 548 549 begin 550 -- Record the first field start position which is the first character 551 -- in the line. 552 553 for C in 1 .. S.Columns'Length loop 554 555 Field_Table.Increment_Last (Fields); 556 557 Fields.Table (Field_Table.Last (Fields)).First := Start; 558 559 Start := Start + S.Columns (C); 560 561 Fields.Table (Field_Table.Last (Fields)).Last := Start - 1; 562 563 end loop; 564 565 -- If there is some remaining character on the line, add them in a 566 -- new field. 567 568 if Start - 1 < Line'Length then 569 570 Field_Table.Increment_Last (Fields); 571 572 Fields.Table (Field_Table.Last (Fields)).First := Start; 573 574 Fields.Table (Field_Table.Last (Fields)).Last := Line'Last; 575 end if; 576 end Current_Line; 577 578 end Split; 579 580 -------------- 581 -- Add_File -- 582 -------------- 583 584 procedure Add_File 585 (Filename : String; 586 Session : Session_Type) 587 is 588 Files : File_Table.Instance renames Session.Data.Files; 589 590 begin 591 if OS_Lib.Is_Regular_File (Filename) then 592 File_Table.Increment_Last (Files); 593 Files.Table (File_Table.Last (Files)) := new String'(Filename); 594 else 595 Raise_With_Info 596 (File_Error'Identity, 597 "File " & Filename & " not found.", 598 Session); 599 end if; 600 end Add_File; 601 602 procedure Add_File 603 (Filename : String) 604 is 605 606 begin 607 Add_File (Filename, Cur_Session); 608 end Add_File; 609 610 --------------- 611 -- Add_Files -- 612 --------------- 613 614 procedure Add_Files 615 (Directory : String; 616 Filenames : String; 617 Number_Of_Files_Added : out Natural; 618 Session : Session_Type) 619 is 620 use Directory_Operations; 621 622 Dir : Dir_Type; 623 Filename : String (1 .. 200); 624 Last : Natural; 625 626 begin 627 Number_Of_Files_Added := 0; 628 629 Open (Dir, Directory); 630 631 loop 632 Read (Dir, Filename, Last); 633 exit when Last = 0; 634 635 Add_File (Filename (1 .. Last), Session); 636 Number_Of_Files_Added := Number_Of_Files_Added + 1; 637 end loop; 638 639 Close (Dir); 640 641 exception 642 when others => 643 Raise_With_Info 644 (File_Error'Identity, 645 "Error scanning directory " & Directory 646 & " for files " & Filenames & '.', 647 Session); 648 end Add_Files; 649 650 procedure Add_Files 651 (Directory : String; 652 Filenames : String; 653 Number_Of_Files_Added : out Natural) 654 is 655 656 begin 657 Add_Files (Directory, Filenames, Number_Of_Files_Added, Cur_Session); 658 end Add_Files; 659 660 ----------------- 661 -- Always_True -- 662 ----------------- 663 664 function Always_True return Boolean is 665 begin 666 return True; 667 end Always_True; 668 669 ------------------- 670 -- Apply_Filters -- 671 ------------------- 672 673 function Apply_Filters 674 (Session : Session_Type) return Boolean 675 is 676 Filters : Pattern_Action_Table.Instance renames Session.Data.Filters; 677 Results : Boolean := False; 678 679 begin 680 -- Iterate through the filters table, if pattern match call action 681 682 for F in 1 .. Pattern_Action_Table.Last (Filters) loop 683 if Patterns.Match (Filters.Table (F).Pattern.all, Session) then 684 Results := True; 685 Actions.Call (Filters.Table (F).Action.all, Session); 686 end if; 687 end loop; 688 689 return Results; 690 end Apply_Filters; 691 692 ----------- 693 -- Close -- 694 ----------- 695 696 procedure Close (Session : Session_Type) is 697 Filters : Pattern_Action_Table.Instance renames Session.Data.Filters; 698 Files : File_Table.Instance renames Session.Data.Files; 699 700 begin 701 -- Close current file if needed 702 703 if Text_IO.Is_Open (Session.Data.Current_File) then 704 Text_IO.Close (Session.Data.Current_File); 705 end if; 706 707 -- Release Filters table 708 709 for F in 1 .. Pattern_Action_Table.Last (Filters) loop 710 Patterns.Release (Filters.Table (F).Pattern.all); 711 Free (Filters.Table (F).Pattern); 712 Free (Filters.Table (F).Action); 713 end loop; 714 715 for F in 1 .. File_Table.Last (Files) loop 716 Free (Files.Table (F)); 717 end loop; 718 719 File_Table.Set_Last (Session.Data.Files, 0); 720 Field_Table.Set_Last (Session.Data.Fields, 0); 721 Pattern_Action_Table.Set_Last (Session.Data.Filters, 0); 722 723 Session.Data.NR := 0; 724 Session.Data.FNR := 0; 725 Session.Data.File_Index := 0; 726 Session.Data.Current_Line := Null_Unbounded_String; 727 end Close; 728 729 --------------------- 730 -- Current_Session -- 731 --------------------- 732 733 function Current_Session return not null access Session_Type is 734 begin 735 return Cur_Session.Self; 736 end Current_Session; 737 738 --------------------- 739 -- Default_Session -- 740 --------------------- 741 742 function Default_Session return not null access Session_Type is 743 begin 744 return Def_Session.Self; 745 end Default_Session; 746 747 -------------------- 748 -- Discrete_Field -- 749 -------------------- 750 751 function Discrete_Field 752 (Rank : Count; 753 Session : Session_Type) return Discrete 754 is 755 begin 756 return Discrete'Value (Field (Rank, Session)); 757 end Discrete_Field; 758 759 function Discrete_Field_Current_Session 760 (Rank : Count) return Discrete is 761 function Do_It is new Discrete_Field (Discrete); 762 begin 763 return Do_It (Rank, Cur_Session); 764 end Discrete_Field_Current_Session; 765 766 ----------------- 767 -- End_Of_Data -- 768 ----------------- 769 770 function End_Of_Data 771 (Session : Session_Type) return Boolean 772 is 773 begin 774 return Session.Data.File_Index = File_Table.Last (Session.Data.Files) 775 and then End_Of_File (Session); 776 end End_Of_Data; 777 778 function End_Of_Data 779 return Boolean 780 is 781 begin 782 return End_Of_Data (Cur_Session); 783 end End_Of_Data; 784 785 ----------------- 786 -- End_Of_File -- 787 ----------------- 788 789 function End_Of_File 790 (Session : Session_Type) return Boolean 791 is 792 begin 793 return Text_IO.End_Of_File (Session.Data.Current_File); 794 end End_Of_File; 795 796 function End_Of_File 797 return Boolean 798 is 799 begin 800 return End_Of_File (Cur_Session); 801 end End_Of_File; 802 803 ----------- 804 -- Field -- 805 ----------- 806 807 function Field 808 (Rank : Count; 809 Session : Session_Type) return String 810 is 811 Fields : Field_Table.Instance renames Session.Data.Fields; 812 813 begin 814 if Rank > Number_Of_Fields (Session) then 815 Raise_With_Info 816 (Field_Error'Identity, 817 "Field number" & Count'Image (Rank) & " does not exist.", 818 Session); 819 820 elsif Rank = 0 then 821 822 -- Returns the whole line, this is what $0 does under Session_Type 823 824 return To_String (Session.Data.Current_Line); 825 826 else 827 return Slice (Session.Data.Current_Line, 828 Fields.Table (Positive (Rank)).First, 829 Fields.Table (Positive (Rank)).Last); 830 end if; 831 end Field; 832 833 function Field 834 (Rank : Count) return String 835 is 836 begin 837 return Field (Rank, Cur_Session); 838 end Field; 839 840 function Field 841 (Rank : Count; 842 Session : Session_Type) return Integer 843 is 844 begin 845 return Integer'Value (Field (Rank, Session)); 846 847 exception 848 when Constraint_Error => 849 Raise_With_Info 850 (Field_Error'Identity, 851 "Field number" & Count'Image (Rank) 852 & " cannot be converted to an integer.", 853 Session); 854 end Field; 855 856 function Field 857 (Rank : Count) return Integer 858 is 859 begin 860 return Field (Rank, Cur_Session); 861 end Field; 862 863 function Field 864 (Rank : Count; 865 Session : Session_Type) return Float 866 is 867 begin 868 return Float'Value (Field (Rank, Session)); 869 870 exception 871 when Constraint_Error => 872 Raise_With_Info 873 (Field_Error'Identity, 874 "Field number" & Count'Image (Rank) 875 & " cannot be converted to a float.", 876 Session); 877 end Field; 878 879 function Field 880 (Rank : Count) return Float 881 is 882 begin 883 return Field (Rank, Cur_Session); 884 end Field; 885 886 ---------- 887 -- File -- 888 ---------- 889 890 function File 891 (Session : Session_Type) return String 892 is 893 Files : File_Table.Instance renames Session.Data.Files; 894 895 begin 896 if Session.Data.File_Index = 0 then 897 return "??"; 898 else 899 return Files.Table (Session.Data.File_Index).all; 900 end if; 901 end File; 902 903 function File 904 return String 905 is 906 begin 907 return File (Cur_Session); 908 end File; 909 910 -------------------- 911 -- For_Every_Line -- 912 -------------------- 913 914 procedure For_Every_Line 915 (Separators : String := Use_Current; 916 Filename : String := Use_Current; 917 Callbacks : Callback_Mode := None; 918 Session : Session_Type) 919 is 920 Quit : Boolean; 921 922 begin 923 Open (Separators, Filename, Session); 924 925 while not End_Of_Data (Session) loop 926 Read_Line (Session); 927 Split_Line (Session); 928 929 if Callbacks in Only .. Pass_Through then 930 declare 931 Discard : Boolean; 932 begin 933 Discard := Apply_Filters (Session); 934 end; 935 end if; 936 937 if Callbacks /= Only then 938 Quit := False; 939 Action (Quit); 940 exit when Quit; 941 end if; 942 end loop; 943 944 Close (Session); 945 end For_Every_Line; 946 947 procedure For_Every_Line_Current_Session 948 (Separators : String := Use_Current; 949 Filename : String := Use_Current; 950 Callbacks : Callback_Mode := None) 951 is 952 procedure Do_It is new For_Every_Line (Action); 953 begin 954 Do_It (Separators, Filename, Callbacks, Cur_Session); 955 end For_Every_Line_Current_Session; 956 957 -------------- 958 -- Get_Line -- 959 -------------- 960 961 procedure Get_Line 962 (Callbacks : Callback_Mode := None; 963 Session : Session_Type) 964 is 965 Filter_Active : Boolean; 966 967 begin 968 if not Text_IO.Is_Open (Session.Data.Current_File) then 969 raise File_Error; 970 end if; 971 972 loop 973 Read_Line (Session); 974 Split_Line (Session); 975 976 case Callbacks is 977 when None => 978 exit; 979 980 when Only => 981 Filter_Active := Apply_Filters (Session); 982 exit when not Filter_Active; 983 984 when Pass_Through => 985 Filter_Active := Apply_Filters (Session); 986 exit; 987 end case; 988 end loop; 989 end Get_Line; 990 991 procedure Get_Line 992 (Callbacks : Callback_Mode := None) 993 is 994 begin 995 Get_Line (Callbacks, Cur_Session); 996 end Get_Line; 997 998 ---------------------- 999 -- Number_Of_Fields -- 1000 ---------------------- 1001 1002 function Number_Of_Fields 1003 (Session : Session_Type) return Count 1004 is 1005 begin 1006 return Count (Field_Table.Last (Session.Data.Fields)); 1007 end Number_Of_Fields; 1008 1009 function Number_Of_Fields 1010 return Count 1011 is 1012 begin 1013 return Number_Of_Fields (Cur_Session); 1014 end Number_Of_Fields; 1015 1016 -------------------------- 1017 -- Number_Of_File_Lines -- 1018 -------------------------- 1019 1020 function Number_Of_File_Lines 1021 (Session : Session_Type) return Count 1022 is 1023 begin 1024 return Count (Session.Data.FNR); 1025 end Number_Of_File_Lines; 1026 1027 function Number_Of_File_Lines 1028 return Count 1029 is 1030 begin 1031 return Number_Of_File_Lines (Cur_Session); 1032 end Number_Of_File_Lines; 1033 1034 --------------------- 1035 -- Number_Of_Files -- 1036 --------------------- 1037 1038 function Number_Of_Files 1039 (Session : Session_Type) return Natural 1040 is 1041 Files : File_Table.Instance renames Session.Data.Files; 1042 begin 1043 return File_Table.Last (Files); 1044 end Number_Of_Files; 1045 1046 function Number_Of_Files 1047 return Natural 1048 is 1049 begin 1050 return Number_Of_Files (Cur_Session); 1051 end Number_Of_Files; 1052 1053 --------------------- 1054 -- Number_Of_Lines -- 1055 --------------------- 1056 1057 function Number_Of_Lines 1058 (Session : Session_Type) return Count 1059 is 1060 begin 1061 return Count (Session.Data.NR); 1062 end Number_Of_Lines; 1063 1064 function Number_Of_Lines 1065 return Count 1066 is 1067 begin 1068 return Number_Of_Lines (Cur_Session); 1069 end Number_Of_Lines; 1070 1071 ---------- 1072 -- Open -- 1073 ---------- 1074 1075 procedure Open 1076 (Separators : String := Use_Current; 1077 Filename : String := Use_Current; 1078 Session : Session_Type) 1079 is 1080 begin 1081 if Text_IO.Is_Open (Session.Data.Current_File) then 1082 raise Session_Error; 1083 end if; 1084 1085 if Filename /= Use_Current then 1086 File_Table.Init (Session.Data.Files); 1087 Add_File (Filename, Session); 1088 end if; 1089 1090 if Separators /= Use_Current then 1091 Set_Field_Separators (Separators, Session); 1092 end if; 1093 1094 Open_Next_File (Session); 1095 1096 exception 1097 when End_Error => 1098 raise File_Error; 1099 end Open; 1100 1101 procedure Open 1102 (Separators : String := Use_Current; 1103 Filename : String := Use_Current) 1104 is 1105 begin 1106 Open (Separators, Filename, Cur_Session); 1107 end Open; 1108 1109 -------------------- 1110 -- Open_Next_File -- 1111 -------------------- 1112 1113 procedure Open_Next_File 1114 (Session : Session_Type) 1115 is 1116 Files : File_Table.Instance renames Session.Data.Files; 1117 1118 begin 1119 if Text_IO.Is_Open (Session.Data.Current_File) then 1120 Text_IO.Close (Session.Data.Current_File); 1121 end if; 1122 1123 Session.Data.File_Index := Session.Data.File_Index + 1; 1124 1125 -- If there are no mores file in the table, raise End_Error 1126 1127 if Session.Data.File_Index > File_Table.Last (Files) then 1128 raise End_Error; 1129 end if; 1130 1131 Text_IO.Open 1132 (File => Session.Data.Current_File, 1133 Name => Files.Table (Session.Data.File_Index).all, 1134 Mode => Text_IO.In_File); 1135 end Open_Next_File; 1136 1137 ----------- 1138 -- Parse -- 1139 ----------- 1140 1141 procedure Parse 1142 (Separators : String := Use_Current; 1143 Filename : String := Use_Current; 1144 Session : Session_Type) 1145 is 1146 Filter_Active : Boolean; 1147 pragma Unreferenced (Filter_Active); 1148 1149 begin 1150 Open (Separators, Filename, Session); 1151 1152 while not End_Of_Data (Session) loop 1153 Get_Line (None, Session); 1154 Filter_Active := Apply_Filters (Session); 1155 end loop; 1156 1157 Close (Session); 1158 end Parse; 1159 1160 procedure Parse 1161 (Separators : String := Use_Current; 1162 Filename : String := Use_Current) 1163 is 1164 begin 1165 Parse (Separators, Filename, Cur_Session); 1166 end Parse; 1167 1168 --------------------- 1169 -- Raise_With_Info -- 1170 --------------------- 1171 1172 procedure Raise_With_Info 1173 (E : Exceptions.Exception_Id; 1174 Message : String; 1175 Session : Session_Type) 1176 is 1177 function Filename return String; 1178 -- Returns current filename and "??" if this information is not 1179 -- available. 1180 1181 function Line return String; 1182 -- Returns current line number without the leading space 1183 1184 -------------- 1185 -- Filename -- 1186 -------------- 1187 1188 function Filename return String is 1189 File : constant String := AWK.File (Session); 1190 begin 1191 if File = "" then 1192 return "??"; 1193 else 1194 return File; 1195 end if; 1196 end Filename; 1197 1198 ---------- 1199 -- Line -- 1200 ---------- 1201 1202 function Line return String is 1203 L : constant String := Natural'Image (Session.Data.FNR); 1204 begin 1205 return L (2 .. L'Last); 1206 end Line; 1207 1208 -- Start of processing for Raise_With_Info 1209 1210 begin 1211 Exceptions.Raise_Exception 1212 (E, 1213 '[' & Filename & ':' & Line & "] " & Message); 1214 raise Constraint_Error; -- to please GNAT as this is a No_Return proc 1215 end Raise_With_Info; 1216 1217 --------------- 1218 -- Read_Line -- 1219 --------------- 1220 1221 procedure Read_Line (Session : Session_Type) is 1222 1223 function Read_Line return String; 1224 -- Read a line in the current file. This implementation is recursive 1225 -- and does not have a limitation on the line length. 1226 1227 NR : Natural renames Session.Data.NR; 1228 FNR : Natural renames Session.Data.FNR; 1229 1230 --------------- 1231 -- Read_Line -- 1232 --------------- 1233 1234 function Read_Line return String is 1235 Buffer : String (1 .. 1_024); 1236 Last : Natural; 1237 1238 begin 1239 Text_IO.Get_Line (Session.Data.Current_File, Buffer, Last); 1240 1241 if Last = Buffer'Last then 1242 return Buffer & Read_Line; 1243 else 1244 return Buffer (1 .. Last); 1245 end if; 1246 end Read_Line; 1247 1248 -- Start of processing for Read_Line 1249 1250 begin 1251 if End_Of_File (Session) then 1252 Open_Next_File (Session); 1253 FNR := 0; 1254 end if; 1255 1256 Session.Data.Current_Line := To_Unbounded_String (Read_Line); 1257 1258 NR := NR + 1; 1259 FNR := FNR + 1; 1260 end Read_Line; 1261 1262 -------------- 1263 -- Register -- 1264 -------------- 1265 1266 procedure Register 1267 (Field : Count; 1268 Pattern : String; 1269 Action : Action_Callback; 1270 Session : Session_Type) 1271 is 1272 Filters : Pattern_Action_Table.Instance renames Session.Data.Filters; 1273 U_Pattern : constant Unbounded_String := To_Unbounded_String (Pattern); 1274 1275 begin 1276 Pattern_Action_Table.Increment_Last (Filters); 1277 1278 Filters.Table (Pattern_Action_Table.Last (Filters)) := 1279 (Pattern => new Patterns.String_Pattern'(U_Pattern, Field), 1280 Action => new Actions.Simple_Action'(Proc => Action)); 1281 end Register; 1282 1283 procedure Register 1284 (Field : Count; 1285 Pattern : String; 1286 Action : Action_Callback) 1287 is 1288 begin 1289 Register (Field, Pattern, Action, Cur_Session); 1290 end Register; 1291 1292 procedure Register 1293 (Field : Count; 1294 Pattern : GNAT.Regpat.Pattern_Matcher; 1295 Action : Action_Callback; 1296 Session : Session_Type) 1297 is 1298 Filters : Pattern_Action_Table.Instance renames Session.Data.Filters; 1299 1300 A_Pattern : constant Patterns.Pattern_Matcher_Access := 1301 new Regpat.Pattern_Matcher'(Pattern); 1302 begin 1303 Pattern_Action_Table.Increment_Last (Filters); 1304 1305 Filters.Table (Pattern_Action_Table.Last (Filters)) := 1306 (Pattern => new Patterns.Regexp_Pattern'(A_Pattern, Field), 1307 Action => new Actions.Simple_Action'(Proc => Action)); 1308 end Register; 1309 1310 procedure Register 1311 (Field : Count; 1312 Pattern : GNAT.Regpat.Pattern_Matcher; 1313 Action : Action_Callback) 1314 is 1315 begin 1316 Register (Field, Pattern, Action, Cur_Session); 1317 end Register; 1318 1319 procedure Register 1320 (Field : Count; 1321 Pattern : GNAT.Regpat.Pattern_Matcher; 1322 Action : Match_Action_Callback; 1323 Session : Session_Type) 1324 is 1325 Filters : Pattern_Action_Table.Instance renames Session.Data.Filters; 1326 1327 A_Pattern : constant Patterns.Pattern_Matcher_Access := 1328 new Regpat.Pattern_Matcher'(Pattern); 1329 begin 1330 Pattern_Action_Table.Increment_Last (Filters); 1331 1332 Filters.Table (Pattern_Action_Table.Last (Filters)) := 1333 (Pattern => new Patterns.Regexp_Pattern'(A_Pattern, Field), 1334 Action => new Actions.Match_Action'(Proc => Action)); 1335 end Register; 1336 1337 procedure Register 1338 (Field : Count; 1339 Pattern : GNAT.Regpat.Pattern_Matcher; 1340 Action : Match_Action_Callback) 1341 is 1342 begin 1343 Register (Field, Pattern, Action, Cur_Session); 1344 end Register; 1345 1346 procedure Register 1347 (Pattern : Pattern_Callback; 1348 Action : Action_Callback; 1349 Session : Session_Type) 1350 is 1351 Filters : Pattern_Action_Table.Instance renames Session.Data.Filters; 1352 1353 begin 1354 Pattern_Action_Table.Increment_Last (Filters); 1355 1356 Filters.Table (Pattern_Action_Table.Last (Filters)) := 1357 (Pattern => new Patterns.Callback_Pattern'(Pattern => Pattern), 1358 Action => new Actions.Simple_Action'(Proc => Action)); 1359 end Register; 1360 1361 procedure Register 1362 (Pattern : Pattern_Callback; 1363 Action : Action_Callback) 1364 is 1365 begin 1366 Register (Pattern, Action, Cur_Session); 1367 end Register; 1368 1369 procedure Register 1370 (Action : Action_Callback; 1371 Session : Session_Type) 1372 is 1373 begin 1374 Register (Always_True'Access, Action, Session); 1375 end Register; 1376 1377 procedure Register 1378 (Action : Action_Callback) 1379 is 1380 begin 1381 Register (Action, Cur_Session); 1382 end Register; 1383 1384 ----------------- 1385 -- Set_Current -- 1386 ----------------- 1387 1388 procedure Set_Current (Session : Session_Type) is 1389 begin 1390 Cur_Session.Data := Session.Data; 1391 end Set_Current; 1392 1393 -------------------------- 1394 -- Set_Field_Separators -- 1395 -------------------------- 1396 1397 procedure Set_Field_Separators 1398 (Separators : String := Default_Separators; 1399 Session : Session_Type) 1400 is 1401 begin 1402 Free (Session.Data.Separators); 1403 1404 Session.Data.Separators := 1405 new Split.Separator'(Separators'Length, Separators); 1406 1407 -- If there is a current line read, split it according to the new 1408 -- separators. 1409 1410 if Session.Data.Current_Line /= Null_Unbounded_String then 1411 Split_Line (Session); 1412 end if; 1413 end Set_Field_Separators; 1414 1415 procedure Set_Field_Separators 1416 (Separators : String := Default_Separators) 1417 is 1418 begin 1419 Set_Field_Separators (Separators, Cur_Session); 1420 end Set_Field_Separators; 1421 1422 ---------------------- 1423 -- Set_Field_Widths -- 1424 ---------------------- 1425 1426 procedure Set_Field_Widths 1427 (Field_Widths : Widths_Set; 1428 Session : Session_Type) 1429 is 1430 begin 1431 Free (Session.Data.Separators); 1432 1433 Session.Data.Separators := 1434 new Split.Column'(Field_Widths'Length, Field_Widths); 1435 1436 -- If there is a current line read, split it according to 1437 -- the new separators. 1438 1439 if Session.Data.Current_Line /= Null_Unbounded_String then 1440 Split_Line (Session); 1441 end if; 1442 end Set_Field_Widths; 1443 1444 procedure Set_Field_Widths 1445 (Field_Widths : Widths_Set) 1446 is 1447 begin 1448 Set_Field_Widths (Field_Widths, Cur_Session); 1449 end Set_Field_Widths; 1450 1451 ---------------- 1452 -- Split_Line -- 1453 ---------------- 1454 1455 procedure Split_Line (Session : Session_Type) is 1456 Fields : Field_Table.Instance renames Session.Data.Fields; 1457 begin 1458 Field_Table.Init (Fields); 1459 Split.Current_Line (Session.Data.Separators.all, Session); 1460 end Split_Line; 1461 1462 ------------- 1463 -- Get_Def -- 1464 ------------- 1465 1466 function Get_Def return Session_Data_Access is 1467 begin 1468 return Def_Session.Data; 1469 end Get_Def; 1470 1471 ------------- 1472 -- Set_Cur -- 1473 ------------- 1474 1475 procedure Set_Cur is 1476 begin 1477 Cur_Session.Data := Def_Session.Data; 1478 end Set_Cur; 1479 1480begin 1481 -- We have declared two sessions but both should share the same data. 1482 -- The current session must point to the default session as its initial 1483 -- value. So first we release the session data then we set current 1484 -- session data to point to default session data. 1485 1486 Free (Cur_Session.Data); 1487 Cur_Session.Data := Def_Session.Data; 1488end GNAT.AWK; 1489