blob: 6f58e46a584d4e94f00e5f53f712514da85d2b96 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . A W K --
-- --
-- B o d y --
-- --
-- Copyright (C) 2000-2014, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Exceptions;
with Ada.Text_IO;
with Ada.Strings.Unbounded;
with Ada.Strings.Fixed;
with Ada.Strings.Maps;
with Ada.Unchecked_Deallocation;
with GNAT.Directory_Operations;
with GNAT.Dynamic_Tables;
with GNAT.OS_Lib;
package body GNAT.AWK is
use Ada;
use Ada.Strings.Unbounded;
-----------------------
-- Local subprograms --
-----------------------
-- The following two subprograms provide a functional interface to the
-- two special session variables, that are manipulated explicitly by
-- Finalize, but must be declared after Finalize to prevent static
-- elaboration warnings.
function Get_Def return Session_Data_Access;
procedure Set_Cur;
----------------
-- Split mode --
----------------
package Split is
type Mode is abstract tagged null record;
-- This is the main type which is declared abstract. This type must be
-- derived for each split style.
type Mode_Access is access Mode'Class;
procedure Current_Line (S : Mode; Session : Session_Type)
is abstract;
-- Split current line of Session using split mode S
------------------------
-- Split on separator --
------------------------
type Separator (Size : Positive) is new Mode with record
Separators : String (1 .. Size);
end record;
procedure Current_Line
(S : Separator;
Session : Session_Type);
---------------------
-- Split on column --
---------------------
type Column (Size : Positive) is new Mode with record
Columns : Widths_Set (1 .. Size);
end record;
procedure Current_Line (S : Column; Session : Session_Type);
end Split;
procedure Free is new Unchecked_Deallocation
(Split.Mode'Class, Split.Mode_Access);
----------------
-- File_Table --
----------------
type AWK_File is access String;
package File_Table is
new Dynamic_Tables (AWK_File, Natural, 1, 5, 50);
-- List of file names associated with a Session
procedure Free is new Unchecked_Deallocation (String, AWK_File);
-----------------
-- Field_Table --
-----------------
type Field_Slice is record
First : Positive;
Last : Natural;
end record;
-- This is a field slice (First .. Last) in session's current line
package Field_Table is
new Dynamic_Tables (Field_Slice, Natural, 1, 10, 100);
-- List of fields for the current line
--------------
-- Patterns --
--------------
-- Define all patterns style: exact string, regular expression, boolean
-- function.
package Patterns is
type Pattern is abstract tagged null record;
-- This is the main type which is declared abstract. This type must be
-- derived for each patterns style.
type Pattern_Access is access Pattern'Class;
function Match
(P : Pattern;
Session : Session_Type) return Boolean
is abstract;
-- Returns True if P match for the current session and False otherwise
procedure Release (P : in out Pattern);
-- Release memory used by the pattern structure
--------------------------
-- Exact string pattern --
--------------------------
type String_Pattern is new Pattern with record
Str : Unbounded_String;
Rank : Count;
end record;
function Match
(P : String_Pattern;
Session : Session_Type) return Boolean;
--------------------------------
-- Regular expression pattern --
--------------------------------
type Pattern_Matcher_Access is access Regpat.Pattern_Matcher;
type Regexp_Pattern is new Pattern with record
Regx : Pattern_Matcher_Access;
Rank : Count;
end record;
function Match
(P : Regexp_Pattern;
Session : Session_Type) return Boolean;
procedure Release (P : in out Regexp_Pattern);
------------------------------
-- Boolean function pattern --
------------------------------
type Callback_Pattern is new Pattern with record
Pattern : Pattern_Callback;
end record;
function Match
(P : Callback_Pattern;
Session : Session_Type) return Boolean;
end Patterns;
procedure Free is new Unchecked_Deallocation
(Patterns.Pattern'Class, Patterns.Pattern_Access);
-------------
-- Actions --
-------------
-- Define all action style : simple call, call with matches
package Actions is
type Action is abstract tagged null record;
-- This is the main type which is declared abstract. This type must be
-- derived for each action style.
type Action_Access is access Action'Class;
procedure Call
(A : Action;
Session : Session_Type) is abstract;
-- Call action A as required
-------------------
-- Simple action --
-------------------
type Simple_Action is new Action with record
Proc : Action_Callback;
end record;
procedure Call
(A : Simple_Action;
Session : Session_Type);
-------------------------
-- Action with matches --
-------------------------
type Match_Action is new Action with record
Proc : Match_Action_Callback;
end record;
procedure Call
(A : Match_Action;
Session : Session_Type);
end Actions;
procedure Free is new Unchecked_Deallocation
(Actions.Action'Class, Actions.Action_Access);
--------------------------
-- Pattern/Action table --
--------------------------
type Pattern_Action is record
Pattern : Patterns.Pattern_Access; -- If Pattern is True
Action : Actions.Action_Access; -- Action will be called
end record;
package Pattern_Action_Table is
new Dynamic_Tables (Pattern_Action, Natural, 1, 5, 50);
------------------
-- Session Data --
------------------
type Session_Data is record
Current_File : Text_IO.File_Type;
Current_Line : Unbounded_String;
Separators : Split.Mode_Access;
Files : File_Table.Instance;
File_Index : Natural := 0;
Fields : Field_Table.Instance;
Filters : Pattern_Action_Table.Instance;
NR : Natural := 0;
FNR : Natural := 0;
Matches : Regpat.Match_Array (0 .. 100);
-- Latest matches for the regexp pattern
end record;
procedure Free is
new Unchecked_Deallocation (Session_Data, Session_Data_Access);
--------------
-- Finalize --
--------------
procedure Finalize (Session : in out Session_Type) is
begin
-- We release the session data only if it is not the default session
if Session.Data /= Get_Def then
-- Release separators
Free (Session.Data.Separators);
Free (Session.Data);
-- Since we have closed the current session, set it to point now to
-- the default session.
Set_Cur;
end if;
end Finalize;
----------------
-- Initialize --
----------------
procedure Initialize (Session : in out Session_Type) is
begin
Session.Data := new Session_Data;
-- Initialize separators
Session.Data.Separators :=
new Split.Separator'(Default_Separators'Length, Default_Separators);
-- Initialize all tables
File_Table.Init (Session.Data.Files);
Field_Table.Init (Session.Data.Fields);
Pattern_Action_Table.Init (Session.Data.Filters);
end Initialize;
-----------------------
-- Session Variables --
-----------------------
Def_Session : Session_Type;
Cur_Session : Session_Type;
----------------------
-- Private Services --
----------------------
function Always_True return Boolean;
-- A function that always returns True
function Apply_Filters
(Session : Session_Type) return Boolean;
-- Apply any filters for which the Pattern is True for Session. It returns
-- True if a least one filters has been applied (i.e. associated action
-- callback has been called).
procedure Open_Next_File
(Session : Session_Type);
pragma Inline (Open_Next_File);
-- Open next file for Session closing current file if needed. It raises
-- End_Error if there is no more file in the table.
procedure Raise_With_Info
(E : Exceptions.Exception_Id;
Message : String;
Session : Session_Type);
pragma No_Return (Raise_With_Info);
-- Raises exception E with the message prepended with the current line
-- number and the filename if possible.
procedure Read_Line (Session : Session_Type);
-- Read a line for the Session and set Current_Line
procedure Split_Line (Session : Session_Type);
-- Split session's Current_Line according to the session separators and
-- set the Fields table. This procedure can be called at any time.
----------------------
-- Private Packages --
----------------------
-------------
-- Actions --
-------------
package body Actions is
----------
-- Call --
----------
procedure Call
(A : Simple_Action;
Session : Session_Type)
is
pragma Unreferenced (Session);
begin
A.Proc.all;
end Call;
----------
-- Call --
----------
procedure Call
(A : Match_Action;
Session : Session_Type)
is
begin
A.Proc (Session.Data.Matches);
end Call;
end Actions;
--------------
-- Patterns --
--------------
package body Patterns is
-----------
-- Match --
-----------
function Match
(P : String_Pattern;
Session : Session_Type) return Boolean
is
begin
return P.Str = Field (P.Rank, Session);
end Match;
-----------
-- Match --
-----------
function Match
(P : Regexp_Pattern;
Session : Session_Type) return Boolean
is
use type Regpat.Match_Location;
begin
Regpat.Match
(P.Regx.all, Field (P.Rank, Session), Session.Data.Matches);
return Session.Data.Matches (0) /= Regpat.No_Match;
end Match;
-----------
-- Match --
-----------
function Match
(P : Callback_Pattern;
Session : Session_Type) return Boolean
is
pragma Unreferenced (Session);
begin
return P.Pattern.all;
end Match;
-------------
-- Release --
-------------
procedure Release (P : in out Pattern) is
pragma Unreferenced (P);
begin
null;
end Release;
-------------
-- Release --
-------------
procedure Release (P : in out Regexp_Pattern) is
procedure Free is new Unchecked_Deallocation
(Regpat.Pattern_Matcher, Pattern_Matcher_Access);
begin
Free (P.Regx);
end Release;
end Patterns;
-----------
-- Split --
-----------
package body Split is
use Ada.Strings;
------------------
-- Current_Line --
------------------
procedure Current_Line (S : Separator; Session : Session_Type) is
Line : constant String := To_String (Session.Data.Current_Line);
Fields : Field_Table.Instance renames Session.Data.Fields;
Seps : constant Maps.Character_Set := Maps.To_Set (S.Separators);
Start : Natural;
Stop : Natural;
begin
-- First field start here
Start := Line'First;
-- Record the first field start position which is the first character
-- in the line.
Field_Table.Increment_Last (Fields);
Fields.Table (Field_Table.Last (Fields)).First := Start;
loop
-- Look for next separator
Stop := Fixed.Index
(Source => Line (Start .. Line'Last),
Set => Seps);
exit when Stop = 0;
Fields.Table (Field_Table.Last (Fields)).Last := Stop - 1;
-- If separators are set to the default (space and tab) we skip
-- all spaces and tabs following current field.
if S.Separators = Default_Separators then
Start := Fixed.Index
(Line (Stop + 1 .. Line'Last),
Maps.To_Set (Default_Separators),
Outside,
Strings.Forward);
if Start = 0 then
Start := Stop + 1;
end if;
else
Start := Stop + 1;
end if;
-- Record in the field table the start of this new field
Field_Table.Increment_Last (Fields);
Fields.Table (Field_Table.Last (Fields)).First := Start;
end loop;
Fields.Table (Field_Table.Last (Fields)).Last := Line'Last;
end Current_Line;
------------------
-- Current_Line --
------------------
procedure Current_Line (S : Column; Session : Session_Type) is
Line : constant String := To_String (Session.Data.Current_Line);
Fields : Field_Table.Instance renames Session.Data.Fields;
Start : Positive := Line'First;
begin
-- Record the first field start position which is the first character
-- in the line.
for C in 1 .. S.Columns'Length loop
Field_Table.Increment_Last (Fields);
Fields.Table (Field_Table.Last (Fields)).First := Start;
Start := Start + S.Columns (C);
Fields.Table (Field_Table.Last (Fields)).Last := Start - 1;
end loop;
-- If there is some remaining character on the line, add them in a
-- new field.
if Start - 1 < Line'Length then
Field_Table.Increment_Last (Fields);
Fields.Table (Field_Table.Last (Fields)).First := Start;
Fields.Table (Field_Table.Last (Fields)).Last := Line'Last;
end if;
end Current_Line;
end Split;
--------------
-- Add_File --
--------------
procedure Add_File
(Filename : String;
Session : Session_Type)
is
Files : File_Table.Instance renames Session.Data.Files;
begin
if OS_Lib.Is_Regular_File (Filename) then
File_Table.Increment_Last (Files);
Files.Table (File_Table.Last (Files)) := new String'(Filename);
else
Raise_With_Info
(File_Error'Identity,
"File " & Filename & " not found.",
Session);
end if;
end Add_File;
procedure Add_File
(Filename : String)
is
begin
Add_File (Filename, Cur_Session);
end Add_File;
---------------
-- Add_Files --
---------------
procedure Add_Files
(Directory : String;
Filenames : String;
Number_Of_Files_Added : out Natural;
Session : Session_Type)
is
use Directory_Operations;
Dir : Dir_Type;
Filename : String (1 .. 200);
Last : Natural;
begin
Number_Of_Files_Added := 0;
Open (Dir, Directory);
loop
Read (Dir, Filename, Last);
exit when Last = 0;
Add_File (Filename (1 .. Last), Session);
Number_Of_Files_Added := Number_Of_Files_Added + 1;
end loop;
Close (Dir);
exception
when others =>
Raise_With_Info
(File_Error'Identity,
"Error scanning directory " & Directory
& " for files " & Filenames & '.',
Session);
end Add_Files;
procedure Add_Files
(Directory : String;
Filenames : String;
Number_Of_Files_Added : out Natural)
is
begin
Add_Files (Directory, Filenames, Number_Of_Files_Added, Cur_Session);
end Add_Files;
-----------------
-- Always_True --
-----------------
function Always_True return Boolean is
begin
return True;
end Always_True;
-------------------
-- Apply_Filters --
-------------------
function Apply_Filters
(Session : Session_Type) return Boolean
is
Filters : Pattern_Action_Table.Instance renames Session.Data.Filters;
Results : Boolean := False;
begin
-- Iterate through the filters table, if pattern match call action
for F in 1 .. Pattern_Action_Table.Last (Filters) loop
if Patterns.Match (Filters.Table (F).Pattern.all, Session) then
Results := True;
Actions.Call (Filters.Table (F).Action.all, Session);
end if;
end loop;
return Results;
end Apply_Filters;
-----------
-- Close --
-----------
procedure Close (Session : Session_Type) is
Filters : Pattern_Action_Table.Instance renames Session.Data.Filters;
Files : File_Table.Instance renames Session.Data.Files;
begin
-- Close current file if needed
if Text_IO.Is_Open (Session.Data.Current_File) then
Text_IO.Close (Session.Data.Current_File);
end if;
-- Release Filters table
for F in 1 .. Pattern_Action_Table.Last (Filters) loop
Patterns.Release (Filters.Table (F).Pattern.all);
Free (Filters.Table (F).Pattern);
Free (Filters.Table (F).Action);
end loop;
for F in 1 .. File_Table.Last (Files) loop
Free (Files.Table (F));
end loop;
File_Table.Set_Last (Session.Data.Files, 0);
Field_Table.Set_Last (Session.Data.Fields, 0);
Pattern_Action_Table.Set_Last (Session.Data.Filters, 0);
Session.Data.NR := 0;
Session.Data.FNR := 0;
Session.Data.File_Index := 0;
Session.Data.Current_Line := Null_Unbounded_String;
end Close;
---------------------
-- Current_Session --
---------------------
function Current_Session return not null access Session_Type is
begin
return Cur_Session.Self;
end Current_Session;
---------------------
-- Default_Session --
---------------------
function Default_Session return not null access Session_Type is
begin
return Def_Session.Self;
end Default_Session;
--------------------
-- Discrete_Field --
--------------------
function Discrete_Field
(Rank : Count;
Session : Session_Type) return Discrete
is
begin
return Discrete'Value (Field (Rank, Session));
end Discrete_Field;
function Discrete_Field_Current_Session
(Rank : Count) return Discrete is
function Do_It is new Discrete_Field (Discrete);
begin
return Do_It (Rank, Cur_Session);
end Discrete_Field_Current_Session;
-----------------
-- End_Of_Data --
-----------------
function End_Of_Data
(Session : Session_Type) return Boolean
is
begin
return Session.Data.File_Index = File_Table.Last (Session.Data.Files)
and then End_Of_File (Session);
end End_Of_Data;
function End_Of_Data
return Boolean
is
begin
return End_Of_Data (Cur_Session);
end End_Of_Data;
-----------------
-- End_Of_File --
-----------------
function End_Of_File
(Session : Session_Type) return Boolean
is
begin
return Text_IO.End_Of_File (Session.Data.Current_File);
end End_Of_File;
function End_Of_File
return Boolean
is
begin
return End_Of_File (Cur_Session);
end End_Of_File;
-----------
-- Field --
-----------
function Field
(Rank : Count;
Session : Session_Type) return String
is
Fields : Field_Table.Instance renames Session.Data.Fields;
begin
if Rank > Number_Of_Fields (Session) then
Raise_With_Info
(Field_Error'Identity,
"Field number" & Count'Image (Rank) & " does not exist.",
Session);
elsif Rank = 0 then
-- Returns the whole line, this is what $0 does under Session_Type
return To_String (Session.Data.Current_Line);
else
return Slice (Session.Data.Current_Line,
Fields.Table (Positive (Rank)).First,
Fields.Table (Positive (Rank)).Last);
end if;
end Field;
function Field
(Rank : Count) return String
is
begin
return Field (Rank, Cur_Session);
end Field;
function Field
(Rank : Count;
Session : Session_Type) return Integer
is
begin
return Integer'Value (Field (Rank, Session));
exception
when Constraint_Error =>
Raise_With_Info
(Field_Error'Identity,
"Field number" & Count'Image (Rank)
& " cannot be converted to an integer.",
Session);
end Field;
function Field
(Rank : Count) return Integer
is
begin
return Field (Rank, Cur_Session);
end Field;
function Field
(Rank : Count;
Session : Session_Type) return Float
is
begin
return Float'Value (Field (Rank, Session));
exception
when Constraint_Error =>
Raise_With_Info
(Field_Error'Identity,
"Field number" & Count'Image (Rank)
& " cannot be converted to a float.",
Session);
end Field;
function Field
(Rank : Count) return Float
is
begin
return Field (Rank, Cur_Session);
end Field;
----------
-- File --
----------
function File
(Session : Session_Type) return String
is
Files : File_Table.Instance renames Session.Data.Files;
begin
if Session.Data.File_Index = 0 then
return "??";
else
return Files.Table (Session.Data.File_Index).all;
end if;
end File;
function File
return String
is
begin
return File (Cur_Session);
end File;
--------------------
-- For_Every_Line --
--------------------
procedure For_Every_Line
(Separators : String := Use_Current;
Filename : String := Use_Current;
Callbacks : Callback_Mode := None;
Session : Session_Type)
is
Quit : Boolean;
begin
Open (Separators, Filename, Session);
while not End_Of_Data (Session) loop
Read_Line (Session);
Split_Line (Session);
if Callbacks in Only .. Pass_Through then
declare
Discard : Boolean;
begin
Discard := Apply_Filters (Session);
end;
end if;
if Callbacks /= Only then
Quit := False;
Action (Quit);
exit when Quit;
end if;
end loop;
Close (Session);
end For_Every_Line;
procedure For_Every_Line_Current_Session
(Separators : String := Use_Current;
Filename : String := Use_Current;
Callbacks : Callback_Mode := None)
is
procedure Do_It is new For_Every_Line (Action);
begin
Do_It (Separators, Filename, Callbacks, Cur_Session);
end For_Every_Line_Current_Session;
--------------
-- Get_Line --
--------------
procedure Get_Line
(Callbacks : Callback_Mode := None;
Session : Session_Type)
is
Filter_Active : Boolean;
begin
if not Text_IO.Is_Open (Session.Data.Current_File) then
raise File_Error;
end if;
loop
Read_Line (Session);
Split_Line (Session);
case Callbacks is
when None =>
exit;
when Only =>
Filter_Active := Apply_Filters (Session);
exit when not Filter_Active;
when Pass_Through =>
Filter_Active := Apply_Filters (Session);
exit;
end case;
end loop;
end Get_Line;
procedure Get_Line
(Callbacks : Callback_Mode := None)
is
begin
Get_Line (Callbacks, Cur_Session);
end Get_Line;
----------------------
-- Number_Of_Fields --
----------------------
function Number_Of_Fields
(Session : Session_Type) return Count
is
begin
return Count (Field_Table.Last (Session.Data.Fields));
end Number_Of_Fields;
function Number_Of_Fields
return Count
is
begin
return Number_Of_Fields (Cur_Session);
end Number_Of_Fields;
--------------------------
-- Number_Of_File_Lines --
--------------------------
function Number_Of_File_Lines
(Session : Session_Type) return Count
is
begin
return Count (Session.Data.FNR);
end Number_Of_File_Lines;
function Number_Of_File_Lines
return Count
is
begin
return Number_Of_File_Lines (Cur_Session);
end Number_Of_File_Lines;
---------------------
-- Number_Of_Files --
---------------------
function Number_Of_Files
(Session : Session_Type) return Natural
is
Files : File_Table.Instance renames Session.Data.Files;
begin
return File_Table.Last (Files);
end Number_Of_Files;
function Number_Of_Files
return Natural
is
begin
return Number_Of_Files (Cur_Session);
end Number_Of_Files;
---------------------
-- Number_Of_Lines --
---------------------
function Number_Of_Lines
(Session : Session_Type) return Count
is
begin
return Count (Session.Data.NR);
end Number_Of_Lines;
function Number_Of_Lines
return Count
is
begin
return Number_Of_Lines (Cur_Session);
end Number_Of_Lines;
----------
-- Open --
----------
procedure Open
(Separators : String := Use_Current;
Filename : String := Use_Current;
Session : Session_Type)
is
begin
if Text_IO.Is_Open (Session.Data.Current_File) then
raise Session_Error;
end if;
if Filename /= Use_Current then
File_Table.Init (Session.Data.Files);
Add_File (Filename, Session);
end if;
if Separators /= Use_Current then
Set_Field_Separators (Separators, Session);
end if;
Open_Next_File (Session);
exception
when End_Error =>
raise File_Error;
end Open;
procedure Open
(Separators : String := Use_Current;
Filename : String := Use_Current)
is
begin
Open (Separators, Filename, Cur_Session);
end Open;
--------------------
-- Open_Next_File --
--------------------
procedure Open_Next_File
(Session : Session_Type)
is
Files : File_Table.Instance renames Session.Data.Files;
begin
if Text_IO.Is_Open (Session.Data.Current_File) then
Text_IO.Close (Session.Data.Current_File);
end if;
Session.Data.File_Index := Session.Data.File_Index + 1;
-- If there are no mores file in the table, raise End_Error
if Session.Data.File_Index > File_Table.Last (Files) then
raise End_Error;
end if;
Text_IO.Open
(File => Session.Data.Current_File,
Name => Files.Table (Session.Data.File_Index).all,
Mode => Text_IO.In_File);
end Open_Next_File;
-----------
-- Parse --
-----------
procedure Parse
(Separators : String := Use_Current;
Filename : String := Use_Current;
Session : Session_Type)
is
Filter_Active : Boolean;
pragma Unreferenced (Filter_Active);
begin
Open (Separators, Filename, Session);
while not End_Of_Data (Session) loop
Get_Line (None, Session);
Filter_Active := Apply_Filters (Session);
end loop;
Close (Session);
end Parse;
procedure Parse
(Separators : String := Use_Current;
Filename : String := Use_Current)
is
begin
Parse (Separators, Filename, Cur_Session);
end Parse;
---------------------
-- Raise_With_Info --
---------------------
procedure Raise_With_Info
(E : Exceptions.Exception_Id;
Message : String;
Session : Session_Type)
is
function Filename return String;
-- Returns current filename and "??" if this information is not
-- available.
function Line return String;
-- Returns current line number without the leading space
--------------
-- Filename --
--------------
function Filename return String is
File : constant String := AWK.File (Session);
begin
if File = "" then
return "??";
else
return File;
end if;
end Filename;
----------
-- Line --
----------
function Line return String is
L : constant String := Natural'Image (Session.Data.FNR);
begin
return L (2 .. L'Last);
end Line;
-- Start of processing for Raise_With_Info
begin
Exceptions.Raise_Exception
(E,
'[' & Filename & ':' & Line & "] " & Message);
raise Constraint_Error; -- to please GNAT as this is a No_Return proc
end Raise_With_Info;
---------------
-- Read_Line --
---------------
procedure Read_Line (Session : Session_Type) is
function Read_Line return String;
-- Read a line in the current file. This implementation is recursive
-- and does not have a limitation on the line length.
NR : Natural renames Session.Data.NR;
FNR : Natural renames Session.Data.FNR;
---------------
-- Read_Line --
---------------
function Read_Line return String is
Buffer : String (1 .. 1_024);
Last : Natural;
begin
Text_IO.Get_Line (Session.Data.Current_File, Buffer, Last);
if Last = Buffer'Last then
return Buffer & Read_Line;
else
return Buffer (1 .. Last);
end if;
end Read_Line;
-- Start of processing for Read_Line
begin
if End_Of_File (Session) then
Open_Next_File (Session);
FNR := 0;
end if;
Session.Data.Current_Line := To_Unbounded_String (Read_Line);
NR := NR + 1;
FNR := FNR + 1;
end Read_Line;
--------------
-- Register --
--------------
procedure Register
(Field : Count;
Pattern : String;
Action : Action_Callback;
Session : Session_Type)
is
Filters : Pattern_Action_Table.Instance renames Session.Data.Filters;
U_Pattern : constant Unbounded_String := To_Unbounded_String (Pattern);
begin
Pattern_Action_Table.Increment_Last (Filters);
Filters.Table (Pattern_Action_Table.Last (Filters)) :=
(Pattern => new Patterns.String_Pattern'(U_Pattern, Field),
Action => new Actions.Simple_Action'(Proc => Action));
end Register;
procedure Register
(Field : Count;
Pattern : String;
Action : Action_Callback)
is
begin
Register (Field, Pattern, Action, Cur_Session);
end Register;
procedure Register
(Field : Count;
Pattern : GNAT.Regpat.Pattern_Matcher;
Action : Action_Callback;
Session : Session_Type)
is
Filters : Pattern_Action_Table.Instance renames Session.Data.Filters;
A_Pattern : constant Patterns.Pattern_Matcher_Access :=
new Regpat.Pattern_Matcher'(Pattern);
begin
Pattern_Action_Table.Increment_Last (Filters);
Filters.Table (Pattern_Action_Table.Last (Filters)) :=
(Pattern => new Patterns.Regexp_Pattern'(A_Pattern, Field),
Action => new Actions.Simple_Action'(Proc => Action));
end Register;
procedure Register
(Field : Count;
Pattern : GNAT.Regpat.Pattern_Matcher;
Action : Action_Callback)
is
begin
Register (Field, Pattern, Action, Cur_Session);
end Register;
procedure Register
(Field : Count;
Pattern : GNAT.Regpat.Pattern_Matcher;
Action : Match_Action_Callback;
Session : Session_Type)
is
Filters : Pattern_Action_Table.Instance renames Session.Data.Filters;
A_Pattern : constant Patterns.Pattern_Matcher_Access :=
new Regpat.Pattern_Matcher'(Pattern);
begin
Pattern_Action_Table.Increment_Last (Filters);
Filters.Table (Pattern_Action_Table.Last (Filters)) :=
(Pattern => new Patterns.Regexp_Pattern'(A_Pattern, Field),
Action => new Actions.Match_Action'(Proc => Action));
end Register;
procedure Register
(Field : Count;
Pattern : GNAT.Regpat.Pattern_Matcher;
Action : Match_Action_Callback)
is
begin
Register (Field, Pattern, Action, Cur_Session);
end Register;
procedure Register
(Pattern : Pattern_Callback;
Action : Action_Callback;
Session : Session_Type)
is
Filters : Pattern_Action_Table.Instance renames Session.Data.Filters;
begin
Pattern_Action_Table.Increment_Last (Filters);
Filters.Table (Pattern_Action_Table.Last (Filters)) :=
(Pattern => new Patterns.Callback_Pattern'(Pattern => Pattern),
Action => new Actions.Simple_Action'(Proc => Action));
end Register;
procedure Register
(Pattern : Pattern_Callback;
Action : Action_Callback)
is
begin
Register (Pattern, Action, Cur_Session);
end Register;
procedure Register
(Action : Action_Callback;
Session : Session_Type)
is
begin
Register (Always_True'Access, Action, Session);
end Register;
procedure Register
(Action : Action_Callback)
is
begin
Register (Action, Cur_Session);
end Register;
-----------------
-- Set_Current --
-----------------
procedure Set_Current (Session : Session_Type) is
begin
Cur_Session.Data := Session.Data;
end Set_Current;
--------------------------
-- Set_Field_Separators --
--------------------------
procedure Set_Field_Separators
(Separators : String := Default_Separators;
Session : Session_Type)
is
begin
Free (Session.Data.Separators);
Session.Data.Separators :=
new Split.Separator'(Separators'Length, Separators);
-- If there is a current line read, split it according to the new
-- separators.
if Session.Data.Current_Line /= Null_Unbounded_String then
Split_Line (Session);
end if;
end Set_Field_Separators;
procedure Set_Field_Separators
(Separators : String := Default_Separators)
is
begin
Set_Field_Separators (Separators, Cur_Session);
end Set_Field_Separators;
----------------------
-- Set_Field_Widths --
----------------------
procedure Set_Field_Widths
(Field_Widths : Widths_Set;
Session : Session_Type)
is
begin
Free (Session.Data.Separators);
Session.Data.Separators :=
new Split.Column'(Field_Widths'Length, Field_Widths);
-- If there is a current line read, split it according to
-- the new separators.
if Session.Data.Current_Line /= Null_Unbounded_String then
Split_Line (Session);
end if;
end Set_Field_Widths;
procedure Set_Field_Widths
(Field_Widths : Widths_Set)
is
begin
Set_Field_Widths (Field_Widths, Cur_Session);
end Set_Field_Widths;
----------------
-- Split_Line --
----------------
procedure Split_Line (Session : Session_Type) is
Fields : Field_Table.Instance renames Session.Data.Fields;
begin
Field_Table.Init (Fields);
Split.Current_Line (Session.Data.Separators.all, Session);
end Split_Line;
-------------
-- Get_Def --
-------------
function Get_Def return Session_Data_Access is
begin
return Def_Session.Data;
end Get_Def;
-------------
-- Set_Cur --
-------------
procedure Set_Cur is
begin
Cur_Session.Data := Def_Session.Data;
end Set_Cur;
begin
-- We have declared two sessions but both should share the same data.
-- The current session must point to the default session as its initial
-- value. So first we release the session data then we set current
-- session data to point to default session data.
Free (Cur_Session.Data);
Cur_Session.Data := Def_Session.Data;
end GNAT.AWK;