+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- G N A T . A W K --
--- --
--- B o d y --
--- --
--- $Revision: 1.2 $
--- --
--- Copyright (C) 2000-2001 Ada Core Technologies, Inc. --
--- --
--- 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 2, 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. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
--- --
-------------------------------------------------------------------------------
-
-pragma Style_Checks (All_Checks);
--- Turn off alpha ordering check for subprograms, since we cannot
--- Put Finalize and Initialize in alpha order (see comments).
-
-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;
-
- ----------------
- -- 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 Session's current line using split mode.
-
- ------------------------
- -- 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 filename 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);
-
- ----------------
- -- 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 --
- -----------------------
-
- -- These must come after the body of Initialize, since they make
- -- implicit calls to Initialize at elaboration time.
-
- Def_Session : Session_Type;
- Cur_Session : Session_Type;
-
- --------------
- -- Finalize --
- --------------
-
- -- Note: Finalize must come after Initialize and the definition
- -- of the Def_Session and Cur_Session variables, since it references
- -- the latter.
-
- 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 /= Def_Session.Data then
- Free (Session.Data);
-
- -- Since we have closed the current session, set it to point
- -- now to the default session.
-
- Cur_Session.Data := Def_Session.Data;
- end if;
- end Finalize;
-
- ----------------------
- -- Private Services --
- ----------------------
-
- function Always_True return Boolean;
- -- A function that always returns True.
-
- function Apply_Filters
- (Session : Session_Type := Current_Session)
- 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 := Current_Session);
- 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
- 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
- begin
- return P.Pattern.all;
- end Match;
-
- -------------
- -- Release --
- -------------
-
- procedure Release (P : in out Pattern) is
- 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;
-
- Start : Positive;
- Stop : Natural;
-
- Seps : Maps.Character_Set := Maps.To_Set (S.Separators);
-
- 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);
- 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 := Current_Session)
- 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;
-
- ---------------
- -- Add_Files --
- ---------------
-
- procedure Add_Files
- (Directory : String;
- Filenames : String;
- Number_Of_Files_Added : out Natural;
- Session : Session_Type := Current_Session)
- 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 scaning directory " & Directory
- & " for files " & Filenames & '.',
- 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 := Current_Session)
- 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 separators
-
- Free (Session.Data.Separators);
-
- -- 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 Session_Type is
- begin
- return Cur_Session;
- end Current_Session;
-
- ---------------------
- -- Default_Session --
- ---------------------
-
- function Default_Session return Session_Type is
- begin
- return Def_Session;
- end Default_Session;
-
- --------------------
- -- Discrete_Field --
- --------------------
-
- function Discrete_Field
- (Rank : Count;
- Session : Session_Type := Current_Session)
- return Discrete
- is
- begin
- return Discrete'Value (Field (Rank, Session));
- end Discrete_Field;
-
- -----------------
- -- End_Of_Data --
- -----------------
-
- function End_Of_Data
- (Session : Session_Type := Current_Session)
- 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;
-
- -----------------
- -- End_Of_File --
- -----------------
-
- function End_Of_File
- (Session : Session_Type := Current_Session)
- return Boolean
- is
- begin
- return Text_IO.End_Of_File (Session.Data.Current_File);
- end End_Of_File;
-
- -----------
- -- Field --
- -----------
-
- function Field
- (Rank : Count;
- Session : Session_Type := Current_Session)
- 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;
- Session : Session_Type := Current_Session)
- 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;
- Session : Session_Type := Current_Session)
- 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;
-
- ----------
- -- File --
- ----------
-
- function File
- (Session : Session_Type := Current_Session)
- 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;
-
- --------------------
- -- For_Every_Line --
- --------------------
-
- procedure For_Every_Line
- (Separators : String := Use_Current;
- Filename : String := Use_Current;
- Callbacks : Callback_Mode := None;
- Session : Session_Type := Current_Session)
- is
- Filter_Active : Boolean;
- 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
- Filter_Active := Apply_Filters (Session);
- end if;
-
- if Callbacks /= Only then
- Quit := False;
- Action (Quit);
- exit when Quit;
- end if;
- end loop;
-
- Close (Session);
- end For_Every_Line;
-
- --------------
- -- Get_Line --
- --------------
-
- procedure Get_Line
- (Callbacks : Callback_Mode := None;
- Session : Session_Type := Current_Session)
- 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);
-
- if Callbacks in Only .. Pass_Through then
- Filter_Active := Apply_Filters (Session);
- end if;
-
- exit when Callbacks = None
- or else Callbacks = Pass_Through
- or else (Callbacks = Only and then not Filter_Active);
-
- end loop;
- end Get_Line;
-
- ----------------------
- -- Number_Of_Fields --
- ----------------------
-
- function Number_Of_Fields
- (Session : Session_Type := Current_Session)
- return Count
- is
- begin
- return Count (Field_Table.Last (Session.Data.Fields));
- end Number_Of_Fields;
-
- --------------------------
- -- Number_Of_File_Lines --
- --------------------------
-
- function Number_Of_File_Lines
- (Session : Session_Type := Current_Session)
- return Count
- is
- begin
- return Count (Session.Data.FNR);
- end Number_Of_File_Lines;
-
- ---------------------
- -- Number_Of_Files --
- ---------------------
-
- function Number_Of_Files
- (Session : Session_Type := Current_Session)
- return Natural
- is
- Files : File_Table.Instance renames Session.Data.Files;
-
- begin
- return File_Table.Last (Files);
- end Number_Of_Files;
-
- ---------------------
- -- Number_Of_Lines --
- ---------------------
-
- function Number_Of_Lines
- (Session : Session_Type := Current_Session)
- return Count
- is
- begin
- return Count (Session.Data.NR);
- end Number_Of_Lines;
-
- ----------
- -- Open --
- ----------
-
- procedure Open
- (Separators : String := Use_Current;
- Filename : String := Use_Current;
- Session : Session_Type := Current_Session)
- 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;
-
- --------------------
- -- Open_Next_File --
- --------------------
-
- procedure Open_Next_File
- (Session : Session_Type := Current_Session)
- 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 := Current_Session)
- is
- Filter_Active : Boolean;
- 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;
-
- ---------------------
- -- 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 the informations 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;
-
- 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 := Current_Session)
- 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 : GNAT.Regpat.Pattern_Matcher;
- Action : Action_Callback;
- Session : Session_Type := Current_Session)
- is
- Filters : Pattern_Action_Table.Instance renames Session.Data.Filters;
-
- A_Pattern : 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 : Match_Action_Callback;
- Session : Session_Type := Current_Session)
- is
- Filters : Pattern_Action_Table.Instance renames Session.Data.Filters;
-
- A_Pattern : 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
- (Pattern : Pattern_Callback;
- Action : Action_Callback;
- Session : Session_Type := Current_Session)
- 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
- (Action : Action_Callback;
- Session : Session_Type := Current_Session)
- is
- begin
- Register (Always_True'Access, Action, 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 := Current_Session)
- 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;
-
- ----------------------
- -- Set_Field_Widths --
- ----------------------
-
- procedure Set_Field_Widths
- (Field_Widths : Widths_Set;
- Session : Session_Type := Current_Session) 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;
-
- ----------------
- -- 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;
-
-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;
projects / msp430-gcc.git / blobdiff