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-2014, 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 978 when None => 979 exit; 980 981 when Only => 982 Filter_Active := Apply_Filters (Session); 983 exit when not Filter_Active; 984 985 when Pass_Through => 986 Filter_Active := Apply_Filters (Session); 987 exit; 988 989 end case; 990 end loop; 991 end Get_Line; 992 993 procedure Get_Line 994 (Callbacks : Callback_Mode := None) 995 is 996 begin 997 Get_Line (Callbacks, Cur_Session); 998 end Get_Line; 999 1000 ---------------------- 1001 -- Number_Of_Fields -- 1002 ---------------------- 1003 1004 function Number_Of_Fields 1005 (Session : Session_Type) return Count 1006 is 1007 begin 1008 return Count (Field_Table.Last (Session.Data.Fields)); 1009 end Number_Of_Fields; 1010 1011 function Number_Of_Fields 1012 return Count 1013 is 1014 begin 1015 return Number_Of_Fields (Cur_Session); 1016 end Number_Of_Fields; 1017 1018 -------------------------- 1019 -- Number_Of_File_Lines -- 1020 -------------------------- 1021 1022 function Number_Of_File_Lines 1023 (Session : Session_Type) return Count 1024 is 1025 begin 1026 return Count (Session.Data.FNR); 1027 end Number_Of_File_Lines; 1028 1029 function Number_Of_File_Lines 1030 return Count 1031 is 1032 begin 1033 return Number_Of_File_Lines (Cur_Session); 1034 end Number_Of_File_Lines; 1035 1036 --------------------- 1037 -- Number_Of_Files -- 1038 --------------------- 1039 1040 function Number_Of_Files 1041 (Session : Session_Type) return Natural 1042 is 1043 Files : File_Table.Instance renames Session.Data.Files; 1044 begin 1045 return File_Table.Last (Files); 1046 end Number_Of_Files; 1047 1048 function Number_Of_Files 1049 return Natural 1050 is 1051 begin 1052 return Number_Of_Files (Cur_Session); 1053 end Number_Of_Files; 1054 1055 --------------------- 1056 -- Number_Of_Lines -- 1057 --------------------- 1058 1059 function Number_Of_Lines 1060 (Session : Session_Type) return Count 1061 is 1062 begin 1063 return Count (Session.Data.NR); 1064 end Number_Of_Lines; 1065 1066 function Number_Of_Lines 1067 return Count 1068 is 1069 begin 1070 return Number_Of_Lines (Cur_Session); 1071 end Number_Of_Lines; 1072 1073 ---------- 1074 -- Open -- 1075 ---------- 1076 1077 procedure Open 1078 (Separators : String := Use_Current; 1079 Filename : String := Use_Current; 1080 Session : Session_Type) 1081 is 1082 begin 1083 if Text_IO.Is_Open (Session.Data.Current_File) then 1084 raise Session_Error; 1085 end if; 1086 1087 if Filename /= Use_Current then 1088 File_Table.Init (Session.Data.Files); 1089 Add_File (Filename, Session); 1090 end if; 1091 1092 if Separators /= Use_Current then 1093 Set_Field_Separators (Separators, Session); 1094 end if; 1095 1096 Open_Next_File (Session); 1097 1098 exception 1099 when End_Error => 1100 raise File_Error; 1101 end Open; 1102 1103 procedure Open 1104 (Separators : String := Use_Current; 1105 Filename : String := Use_Current) 1106 is 1107 begin 1108 Open (Separators, Filename, Cur_Session); 1109 end Open; 1110 1111 -------------------- 1112 -- Open_Next_File -- 1113 -------------------- 1114 1115 procedure Open_Next_File 1116 (Session : Session_Type) 1117 is 1118 Files : File_Table.Instance renames Session.Data.Files; 1119 1120 begin 1121 if Text_IO.Is_Open (Session.Data.Current_File) then 1122 Text_IO.Close (Session.Data.Current_File); 1123 end if; 1124 1125 Session.Data.File_Index := Session.Data.File_Index + 1; 1126 1127 -- If there are no mores file in the table, raise End_Error 1128 1129 if Session.Data.File_Index > File_Table.Last (Files) then 1130 raise End_Error; 1131 end if; 1132 1133 Text_IO.Open 1134 (File => Session.Data.Current_File, 1135 Name => Files.Table (Session.Data.File_Index).all, 1136 Mode => Text_IO.In_File); 1137 end Open_Next_File; 1138 1139 ----------- 1140 -- Parse -- 1141 ----------- 1142 1143 procedure Parse 1144 (Separators : String := Use_Current; 1145 Filename : String := Use_Current; 1146 Session : Session_Type) 1147 is 1148 Filter_Active : Boolean; 1149 pragma Unreferenced (Filter_Active); 1150 1151 begin 1152 Open (Separators, Filename, Session); 1153 1154 while not End_Of_Data (Session) loop 1155 Get_Line (None, Session); 1156 Filter_Active := Apply_Filters (Session); 1157 end loop; 1158 1159 Close (Session); 1160 end Parse; 1161 1162 procedure Parse 1163 (Separators : String := Use_Current; 1164 Filename : String := Use_Current) 1165 is 1166 begin 1167 Parse (Separators, Filename, Cur_Session); 1168 end Parse; 1169 1170 --------------------- 1171 -- Raise_With_Info -- 1172 --------------------- 1173 1174 procedure Raise_With_Info 1175 (E : Exceptions.Exception_Id; 1176 Message : String; 1177 Session : Session_Type) 1178 is 1179 function Filename return String; 1180 -- Returns current filename and "??" if this information is not 1181 -- available. 1182 1183 function Line return String; 1184 -- Returns current line number without the leading space 1185 1186 -------------- 1187 -- Filename -- 1188 -------------- 1189 1190 function Filename return String is 1191 File : constant String := AWK.File (Session); 1192 begin 1193 if File = "" then 1194 return "??"; 1195 else 1196 return File; 1197 end if; 1198 end Filename; 1199 1200 ---------- 1201 -- Line -- 1202 ---------- 1203 1204 function Line return String is 1205 L : constant String := Natural'Image (Session.Data.FNR); 1206 begin 1207 return L (2 .. L'Last); 1208 end Line; 1209 1210 -- Start of processing for Raise_With_Info 1211 1212 begin 1213 Exceptions.Raise_Exception 1214 (E, 1215 '[' & Filename & ':' & Line & "] " & Message); 1216 raise Constraint_Error; -- to please GNAT as this is a No_Return proc 1217 end Raise_With_Info; 1218 1219 --------------- 1220 -- Read_Line -- 1221 --------------- 1222 1223 procedure Read_Line (Session : Session_Type) is 1224 1225 function Read_Line return String; 1226 -- Read a line in the current file. This implementation is recursive 1227 -- and does not have a limitation on the line length. 1228 1229 NR : Natural renames Session.Data.NR; 1230 FNR : Natural renames Session.Data.FNR; 1231 1232 --------------- 1233 -- Read_Line -- 1234 --------------- 1235 1236 function Read_Line return String is 1237 Buffer : String (1 .. 1_024); 1238 Last : Natural; 1239 1240 begin 1241 Text_IO.Get_Line (Session.Data.Current_File, Buffer, Last); 1242 1243 if Last = Buffer'Last then 1244 return Buffer & Read_Line; 1245 else 1246 return Buffer (1 .. Last); 1247 end if; 1248 end Read_Line; 1249 1250 -- Start of processing for Read_Line 1251 1252 begin 1253 if End_Of_File (Session) then 1254 Open_Next_File (Session); 1255 FNR := 0; 1256 end if; 1257 1258 Session.Data.Current_Line := To_Unbounded_String (Read_Line); 1259 1260 NR := NR + 1; 1261 FNR := FNR + 1; 1262 end Read_Line; 1263 1264 -------------- 1265 -- Register -- 1266 -------------- 1267 1268 procedure Register 1269 (Field : Count; 1270 Pattern : String; 1271 Action : Action_Callback; 1272 Session : Session_Type) 1273 is 1274 Filters : Pattern_Action_Table.Instance renames Session.Data.Filters; 1275 U_Pattern : constant Unbounded_String := To_Unbounded_String (Pattern); 1276 1277 begin 1278 Pattern_Action_Table.Increment_Last (Filters); 1279 1280 Filters.Table (Pattern_Action_Table.Last (Filters)) := 1281 (Pattern => new Patterns.String_Pattern'(U_Pattern, Field), 1282 Action => new Actions.Simple_Action'(Proc => Action)); 1283 end Register; 1284 1285 procedure Register 1286 (Field : Count; 1287 Pattern : String; 1288 Action : Action_Callback) 1289 is 1290 begin 1291 Register (Field, Pattern, Action, Cur_Session); 1292 end Register; 1293 1294 procedure Register 1295 (Field : Count; 1296 Pattern : GNAT.Regpat.Pattern_Matcher; 1297 Action : Action_Callback; 1298 Session : Session_Type) 1299 is 1300 Filters : Pattern_Action_Table.Instance renames Session.Data.Filters; 1301 1302 A_Pattern : constant Patterns.Pattern_Matcher_Access := 1303 new Regpat.Pattern_Matcher'(Pattern); 1304 begin 1305 Pattern_Action_Table.Increment_Last (Filters); 1306 1307 Filters.Table (Pattern_Action_Table.Last (Filters)) := 1308 (Pattern => new Patterns.Regexp_Pattern'(A_Pattern, Field), 1309 Action => new Actions.Simple_Action'(Proc => Action)); 1310 end Register; 1311 1312 procedure Register 1313 (Field : Count; 1314 Pattern : GNAT.Regpat.Pattern_Matcher; 1315 Action : Action_Callback) 1316 is 1317 begin 1318 Register (Field, Pattern, Action, Cur_Session); 1319 end Register; 1320 1321 procedure Register 1322 (Field : Count; 1323 Pattern : GNAT.Regpat.Pattern_Matcher; 1324 Action : Match_Action_Callback; 1325 Session : Session_Type) 1326 is 1327 Filters : Pattern_Action_Table.Instance renames Session.Data.Filters; 1328 1329 A_Pattern : constant Patterns.Pattern_Matcher_Access := 1330 new Regpat.Pattern_Matcher'(Pattern); 1331 begin 1332 Pattern_Action_Table.Increment_Last (Filters); 1333 1334 Filters.Table (Pattern_Action_Table.Last (Filters)) := 1335 (Pattern => new Patterns.Regexp_Pattern'(A_Pattern, Field), 1336 Action => new Actions.Match_Action'(Proc => Action)); 1337 end Register; 1338 1339 procedure Register 1340 (Field : Count; 1341 Pattern : GNAT.Regpat.Pattern_Matcher; 1342 Action : Match_Action_Callback) 1343 is 1344 begin 1345 Register (Field, Pattern, Action, Cur_Session); 1346 end Register; 1347 1348 procedure Register 1349 (Pattern : Pattern_Callback; 1350 Action : Action_Callback; 1351 Session : Session_Type) 1352 is 1353 Filters : Pattern_Action_Table.Instance renames Session.Data.Filters; 1354 1355 begin 1356 Pattern_Action_Table.Increment_Last (Filters); 1357 1358 Filters.Table (Pattern_Action_Table.Last (Filters)) := 1359 (Pattern => new Patterns.Callback_Pattern'(Pattern => Pattern), 1360 Action => new Actions.Simple_Action'(Proc => Action)); 1361 end Register; 1362 1363 procedure Register 1364 (Pattern : Pattern_Callback; 1365 Action : Action_Callback) 1366 is 1367 begin 1368 Register (Pattern, Action, Cur_Session); 1369 end Register; 1370 1371 procedure Register 1372 (Action : Action_Callback; 1373 Session : Session_Type) 1374 is 1375 begin 1376 Register (Always_True'Access, Action, Session); 1377 end Register; 1378 1379 procedure Register 1380 (Action : Action_Callback) 1381 is 1382 begin 1383 Register (Action, Cur_Session); 1384 end Register; 1385 1386 ----------------- 1387 -- Set_Current -- 1388 ----------------- 1389 1390 procedure Set_Current (Session : Session_Type) is 1391 begin 1392 Cur_Session.Data := Session.Data; 1393 end Set_Current; 1394 1395 -------------------------- 1396 -- Set_Field_Separators -- 1397 -------------------------- 1398 1399 procedure Set_Field_Separators 1400 (Separators : String := Default_Separators; 1401 Session : Session_Type) 1402 is 1403 begin 1404 Free (Session.Data.Separators); 1405 1406 Session.Data.Separators := 1407 new Split.Separator'(Separators'Length, Separators); 1408 1409 -- If there is a current line read, split it according to the new 1410 -- separators. 1411 1412 if Session.Data.Current_Line /= Null_Unbounded_String then 1413 Split_Line (Session); 1414 end if; 1415 end Set_Field_Separators; 1416 1417 procedure Set_Field_Separators 1418 (Separators : String := Default_Separators) 1419 is 1420 begin 1421 Set_Field_Separators (Separators, Cur_Session); 1422 end Set_Field_Separators; 1423 1424 ---------------------- 1425 -- Set_Field_Widths -- 1426 ---------------------- 1427 1428 procedure Set_Field_Widths 1429 (Field_Widths : Widths_Set; 1430 Session : Session_Type) 1431 is 1432 begin 1433 Free (Session.Data.Separators); 1434 1435 Session.Data.Separators := 1436 new Split.Column'(Field_Widths'Length, Field_Widths); 1437 1438 -- If there is a current line read, split it according to 1439 -- the new separators. 1440 1441 if Session.Data.Current_Line /= Null_Unbounded_String then 1442 Split_Line (Session); 1443 end if; 1444 end Set_Field_Widths; 1445 1446 procedure Set_Field_Widths 1447 (Field_Widths : Widths_Set) 1448 is 1449 begin 1450 Set_Field_Widths (Field_Widths, Cur_Session); 1451 end Set_Field_Widths; 1452 1453 ---------------- 1454 -- Split_Line -- 1455 ---------------- 1456 1457 procedure Split_Line (Session : Session_Type) is 1458 Fields : Field_Table.Instance renames Session.Data.Fields; 1459 begin 1460 Field_Table.Init (Fields); 1461 Split.Current_Line (Session.Data.Separators.all, Session); 1462 end Split_Line; 1463 1464 ------------- 1465 -- Get_Def -- 1466 ------------- 1467 1468 function Get_Def return Session_Data_Access is 1469 begin 1470 return Def_Session.Data; 1471 end Get_Def; 1472 1473 ------------- 1474 -- Set_Cur -- 1475 ------------- 1476 1477 procedure Set_Cur is 1478 begin 1479 Cur_Session.Data := Def_Session.Data; 1480 end Set_Cur; 1481 1482begin 1483 -- We have declared two sessions but both should share the same data. 1484 -- The current session must point to the default session as its initial 1485 -- value. So first we release the session data then we set current 1486 -- session data to point to default session data. 1487 1488 Free (Cur_Session.Data); 1489 Cur_Session.Data := Def_Session.Data; 1490end GNAT.AWK; 1491