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