gcc/ada/g-awk.adb

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