ada/aws
0
0
Fork 0
mirror of https://github.com/AdaCore/aws.git synced 2026-02-12 12:29:46 -08:00
Code Issues Packages Projects Releases Wiki Activity
Files
master
aws/tools/webxref.adb
Pascal Obry d7735b587b Use Ada 2022 @ short hand syntax. 
Motivated by eng/toolchain/aws#74
2025-01-21 07:56:55 +01:00

1016 lines
28 KiB
Ada
Raw Permalink Blame History

------------------------------------------------------------------------------
-- Ada Web Server --
-- --
-- Copyright (C) 2007-2024, AdaCore --
-- --
-- This is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the --
-- Free Software Foundation; either version 3, or (at your option) any --
-- later version. This software is distributed in the hope that it will --
-- be useful, but WITHOUT 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 this software; see file COPYING3. If not, go --
-- to http://www.gnu.org/licenses for a complete copy of the license. --
------------------------------------------------------------------------------
-- This tools is to help tracking down unused or undefined entities in Ajax
-- Web development as it is very difficult to ensure that a referenced Id does
-- actually exist in Web pages for example.
with Ada.Characters.Handling;
with Ada.Command_Line;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Containers.Indefinite_Vectors;
with Ada.Directories;
with Ada.Strings.Fixed;
with Ada.Strings.Hash;
with Ada.Strings.Maps.Constants;
with Ada.Strings.Unbounded;
with Ada.Text_IO;
with GNAT.Command_Line;
with AWS.Utils;
procedure Webxref is
use Ada;
use Ada.Strings;
use Ada.Strings.Unbounded;
use AWS;
Syntax_Error : exception;
Version : constant String := "1.0";
Max_Line_Length : constant := 1_024;
-- Reader record is the file iterator context
type Reader is record
File : Text_IO.File_Type;
Line : Natural;
Content : String (1 .. Max_Line_Length);
Last : Natural;
Buffer : String (1 .. Max_Line_Length * 5);
Blast : Natural;
end record;
procedure Open (Filename : String; Iterator : in out Reader);
-- Open filename and initialize the file iterator
procedure Close (Iterator : in out Reader);
-- Close file iterator
procedure Next (Iterator : in out Reader);
-- Read next line
procedure Clear_Content (Iterator : in out Reader);
-- Clear content from the iterator context
function Index
(Iterator : Reader;
Pattern : String;
From : Positive := 1) return Natural;
-- Returns the position of Pattern starting at From in iterator content
function Eof (Iterator : Reader) return Boolean;
-- Returns True if end of file reached
function Is_Id_Ignored (Name : String) return Boolean;
-- Returns True if this name is to be ignored
type Name_Kind is
(Def_CSS, -- a definition in a CSS
Ref_CSS, -- a reference to a CSS definition (in HTML, XML... documents)
Def_ML, -- a definition in an HTML, XML... document
Ref_ML); -- a reference to an HTML definition (Found in Ajax response)
type Kind_Set is array (Name_Kind) of Boolean;
Null_Kind_Set : constant Kind_Set := [others => False];
CSS_Kind : constant Kind_Set :=
[Def_CSS => True, others => False];
Web_Kind : constant Kind_Set :=
[Ref_CSS | Def_ML => True, others => False];
Ajax_Response_Kind : constant Kind_Set :=
[Ref_ML => True, others => False];
Def_Kind : constant Kind_Set :=
[Def_CSS | Def_ML => True, others => False];
Ref_Kind : constant Kind_Set :=
[Ref_CSS | Ref_ML => True, others => False];
No_Kind : constant Kind_Set := [others => False];
procedure Process_CSS (Filename : String);
-- Process a CSS file
procedure Process_ML (Filename : String; Kinds : Kind_Set);
-- Process a Meta Language file HTML, XML
procedure Process (Filename : String);
-- Process any file, dispatch to Process_ML or Process_CSS depending on the
-- file extension.
type Occurence is record
Filename : Unbounded_String;
Line, Column : Natural;
Kind : Kind_Set;
end record;
package Occurences is
new Containers.Indefinite_Vectors (Natural, Occurence);
package Id_Maps is new Containers.Indefinite_Hashed_Maps
(String, Boolean, Strings.Hash, "=");
procedure Parse_Command_Line;
procedure Record_Id (Name : String; Location : Occurence);
-- Record Id name into Id_Dict
procedure Record_Class (Name : String; Location : Occurence);
-- Record Class name into Class_Dict
procedure Log_Error (Location : Occurence; Message : String);
-- Log error message
procedure Check_Prefix
(Name, Prefix : String;
Location : Occurence);
-- Check if Name has the right prefix
Global_Prefix : constant String := "global_";
-- Prefix used for global Ids. Such Ids are not checked for prefix
-- convention.
-- Options
type Mode is (Xref, Unused, Undefined);
function Is_Mode (Kind : Kind_Set; Check_Mode : Mode) return Boolean;
-- Returns True if Kind conform to Check_Mode
Check : Mode := Xref;
Dump_Classes : Boolean := True;
Dump_Ids : Boolean := True;
Verbose : Boolean := False;
Id_Prefix : Unbounded_String;
Class_Prefix : Unbounded_String;
Id_File : Boolean := False;
Has_Error : Boolean := False;
Killed_Id : Id_Maps.Map;
generic
package Dict is
type Id is new Positive;
function Get (Name : String) return Id;
-- Returns a uniq Id for Name
procedure Add (Id : Dict.Id; Occ : Occurence);
-- Adds given occurence for Id
function Get (Id : Dict.Id) return String;
-- Returns Id's name
type Node is record
Name : Unbounded_String;
Kinds : Kind_Set;
Occ : Occurences.Vector;
end record;
function Get (Id : Dict.Id) return Node;
-- Returns node for the given Id
procedure Dump (Filter : Mode);
-- Dump dictionary content on the console
end Dict;
------------------
-- Check_Prefix --
------------------
procedure Check_Prefix
(Name, Prefix : String;
Location : Occurence) is
begin
if Fixed.Index (Name, Global_Prefix) /= Name'First then
if Prefix'Length >= Name'Length
or else
Name (Name'First .. Name'First + Prefix'Length - 1) /= Prefix
then
Log_Error
(Location, Name & " has wrong prefix, expecting "
& Prefix & '_' & Name);
end if;
end if;
end Check_Prefix;
-------------------
-- Clear_Content --
-------------------
procedure Clear_Content (Iterator : in out Reader) is
begin
Iterator.Last := 0;
Iterator.Blast := 0;
end Clear_Content;
-----------
-- Close --
-----------
procedure Close (Iterator : in out Reader) is
begin
Text_IO.Close (Iterator.File);
Clear_Content (Iterator);
end Close;
----------
-- Dict --
----------
package body Dict is
package Name_Id is
new Containers.Indefinite_Hashed_Maps (String, Id, Strings.Hash, "=");
package Id_Name is
new Containers.Indefinite_Vectors (Id, Node);
NId : Name_Id.Map;
IdN : Id_Name.Vector;
Current : Id := 1;
---------
-- Add --
---------
procedure Add
(Id : Dict.Id;
Occ : Occurence)
is
procedure Process (Element : in out Node);
-------------
-- Process --
-------------
procedure Process (Element : in out Node) is
begin
Element.Occ.Append (Occ);
Element.Kinds := Element.Kinds or Occ.Kind;
end Process;
begin
IdN.Update_Element (Id, Process'Access);
end Add;
----------
-- Dump --
----------
procedure Dump (Filter : Mode) is
procedure Dump (Position : Id_Name.Cursor);
-- Dump name and iterates through all occurences
----------
-- Dump --
----------
procedure Dump (Position : Id_Name.Cursor) is
procedure Dump (Position : Occurences.Cursor);
-- Dump the pointed occurence
Element : constant Node := Id_Name.Element (Position);
----------
-- Dump --
----------
procedure Dump (Position : Occurences.Cursor) is
Def_Ref : Unbounded_String;
begin
declare
O : constant Occurence := Occurences.Element (Position);
begin
Text_IO.Put
(To_String (O.Filename) & ":"
& Utils.Image (O.Line) & ":"
& Utils.Image (O.Column) & ": ");
if (O.Kind and Def_Kind) /= No_Kind then
Append (Def_Ref, "definition");
end if;
if (O.Kind and Ref_Kind) /= No_Kind then
if Def_Ref /= Null_Unbounded_String then
Append (Def_Ref, " and ");
end if;
Append (Def_Ref, "reference");
end if;
Text_IO.Put (To_String (Def_Ref) & " of ");
Text_IO.Put_Line (To_String (Element.Name));
end;
end Dump;
begin
if Is_Mode (Element.Kinds, Filter) then
if Verbose then
Text_IO.Put (To_String (Element.Name));
for K in Name_Kind loop
if Element.Kinds (K) then
Text_IO.Put (" " & Name_Kind'Image (K));
end if;
end loop;
Text_IO.New_Line;
end if;
Element.Occ.Iterate (Dump'Access);
end if;
end Dump;
begin
IdN.Iterate (Dump'Access);
end Dump;
---------
-- Get --
---------
function Get (Name : String) return Id is
begin
if NId.Contains (Name) then
return NId.Element (Name);
else
NId.Insert (Name, Current);
IdN.Append
(Node'(To_Unbounded_String (Name), Null_Kind_Set, Occ => <>));
Current := @ + 1;
return Current - 1;
end if;
end Get;
function Get (Id : Dict.Id) return String is
begin
if Natural (IdN.Length) >= Natural (Id) then
return To_String (IdN.Element (Id).Name);
else
raise Constraint_Error with "Id not found.";
end if;
end Get;
function Get (Id : Dict.Id) return Node is
begin
if Natural (IdN.Length) >= Natural (Id) then
return IdN.Element (Id);
else
raise Constraint_Error with "Id not found.";
end if;
end Get;
end Dict;
package Class_Dict is new Dict;
package Id_Dict is new Dict;
---------
-- Eof --
---------
function Eof (Iterator : Reader) return Boolean is
begin
return Text_IO.End_Of_File (Iterator.File);
end Eof;
-----------
-- Index --
-----------
function Index
(Iterator : Reader;
Pattern : String;
From : Positive := 1) return Natural is
begin
return Fixed.Index
(Iterator.Content (From .. Iterator.Last), Pattern);
end Index;
-------------------
-- Is_Id_Ignored --
-------------------
function Is_Id_Ignored (Name : String) return Boolean is
use type Strings.Maps.Character_Set;
begin
-- Ignore if it is a number
return Strings.Fixed.Index
(Name, not Strings.Maps.Constants.Decimal_Digit_Set) = 0
or else Killed_Id.Contains (Name);
end Is_Id_Ignored;
-------------
-- Is_Mode --
-------------
function Is_Mode
(Kind : Kind_Set; Check_Mode : Mode) return Boolean is
begin
case Check_Mode is
when Xref =>
return True;
when Unused =>
return Kind = Kind_Set'(Def_ML => True, others => False)
or else Kind = Kind_Set'(Def_CSS => True, others => False)
or else Kind =
Kind_Set'(Def_ML | Def_CSS => True, others => False)
or else Kind =
Kind_Set'(Def_ML | Ref_CSS => True, others => False);
when Undefined =>
return Kind = Kind_Set'(Ref_ML => True, others => False)
or else Kind = Kind_Set'(Ref_CSS => True, others => False)
or else Kind =
Kind_Set'(Ref_ML | Ref_CSS => True, others => False);
end case;
end Is_Mode;
---------------
-- Log_Error --
---------------
procedure Log_Error (Location : Occurence; Message : String) is
begin
Has_Error := True;
Text_IO.Put_Line
(To_String (Location.Filename) & ":" & Utils.Image (Location.Line)
& ":" & Utils.Image (Location.Column) & ": " & Message);
end Log_Error;
----------
-- Next --
----------
procedure Next (Iterator : in out Reader) is
begin
Text_IO.Get_Line (Iterator.File, Iterator.Content, Iterator.Last);
Iterator.Buffer
(Iterator.Blast + 1 .. Iterator.Blast + Iterator.Last) :=
Iterator.Content (1 .. Iterator.Last);
Iterator.Blast := @ + Iterator.Last;
Iterator.Line := @ + 1;
end Next;
----------
-- Open --
----------
procedure Open (Filename : String; Iterator : in out Reader) is
begin
Text_IO.Open (Iterator.File, Text_IO.In_File, Filename);
Clear_Content (Iterator);
Iterator.Line := 0;
end Open;
------------------------
-- Parse_Command_Line --
------------------------
procedure Parse_Command_Line is
begin
GNAT.Command_Line.Initialize_Option_Scan
(Stop_At_First_Non_Switch => True);
loop
case GNAT.Command_Line.Getopt ("x u d c C i I v h pi: pc: ki:") is
when ASCII.NUL =>
exit;
when 'u' =>
Check := Unused;
when 'x' =>
Check := Xref;
when 'd' =>
Check := Undefined;
when 'c' =>
Dump_Classes := True;
when 'C' =>
Dump_Classes := False;
when 'i' =>
Dump_Ids := True;
when 'I' =>
Dump_Ids := False;
when 'v' =>
Verbose := True;
when 'k' =>
if GNAT.Command_Line.Full_Switch = "ki" then
Killed_Id.Include (GNAT.Command_Line.Parameter, True);
else
raise Syntax_Error;
end if;
when 'p' =>
if GNAT.Command_Line.Full_Switch = "pi" then
if GNAT.Command_Line.Parameter = "file_based" then
Id_File := True;
else
Id_Prefix := To_Unbounded_String
(GNAT.Command_Line.Parameter);
end if;
elsif GNAT.Command_Line.Full_Switch = "pc" then
Class_Prefix :=
To_Unbounded_String (GNAT.Command_Line.Parameter);
else
raise Syntax_Error;
end if;
when 'h' =>
raise Syntax_Error;
when others =>
raise Syntax_Error;
end case;
end loop;
end Parse_Command_Line;
-------------
-- Process --
-------------
procedure Process (Filename : String) is
Ext : constant String :=
Characters.Handling.To_Lower (Directories.Extension (Filename));
begin
if Verbose then
Text_IO.Put_Line ("Process file : " & Filename & " as " & Ext);
end if;
if Ext = "css" or else Ext = "tcss" then
Process_CSS (Filename);
elsif Ext = "xml" or else Ext = "html" or else Ext = "thtml" then
Process_ML (Filename, Web_Kind);
elsif Ext = "txml" then
Process_ML (Filename, Ajax_Response_Kind);
end if;
end Process;
-----------------
-- Process_CSS --
-----------------
procedure Process_CSS (Filename : String) is
Seps : constant Maps.Character_Set := Maps.To_Set (" ,{");
procedure Register_CSS_Path (Iterator : Reader; Pos : Natural);
-- Parse and register a CSS path, we just want to extract the classes
-- and ids.
-----------------------
-- Register_CSS_Path --
-----------------------
procedure Register_CSS_Path (Iterator : Reader; Pos : Natural) is
Path : constant String :=
Iterator.Buffer (1 .. Iterator.Blast - Iterator.Last + Pos);
S, E : Natural := 1;
begin
-- First look for classes
loop
S := Fixed.Index (Path, ".", S);
exit when S = 0;
E := Fixed.Index (Path, Seps, S);
if E = 0 then
E := Path'Last + 1;
end if;
declare
Name : constant String := Path (S + 1 .. E - 1);
Id : constant Class_Dict.Id := Class_Dict.Get (Name);
begin
Class_Dict.Add
(Id, Occurence'(To_Unbounded_String (Filename),
Iterator.Line, S + 1, CSS_Kind));
end;
S := E + 1;
end loop;
-- First look for ids
S := 1;
E := 1;
loop
S := Fixed.Index (Path, "#", S);
exit when S = 0;
E := Fixed.Index (Path, Seps, S);
if E = 0 then
E := Path'Last + 1;
end if;
declare
Name : constant String := Path (S + 1 .. E - 1);
Id : constant Id_Dict.Id := Id_Dict.Get (Name);
begin
Id_Dict.Add
(Id, Occurence'(To_Unbounded_String (Filename),
Iterator.Line, S + 1, CSS_Kind));
end;
S := E + 1;
end loop;
end Register_CSS_Path;
Iterator : Reader;
Pos : Natural;
begin
Open (Filename, Iterator);
loop
Next (Iterator);
if Iterator.Last = 0 then
Clear_Content (Iterator);
else
Pos := Index (Iterator, "{");
if Pos /= 0 then
Register_CSS_Path (Iterator, Pos);
end if;
if Index (Iterator, "}") /= 0 then
Clear_Content (Iterator);
end if;
end if;
exit when Eof (Iterator);
end loop;
Close (Iterator);
end Process_CSS;
----------------
-- Process_ML --
----------------
procedure Process_ML (Filename : String; Kinds : Kind_Set) is
procedure Find
(Iterator : Reader;
Attribute : String;
Process : not null access procedure
(Iterator : Reader;
Name : String;
Column : Positive));
-- Call process for value of the given attribute name
procedure Process_Id
(Iterator : Reader; Name : String; Column : Positive);
procedure Process_Class
(Iterator : Reader; Name : String; Column : Positive);
procedure Check_Include (Iterator : Reader);
-- Check template include. We want here to include as id reference all
-- parameters to the aws_*.tjs includes.
-------------------
-- Check_Include --
-------------------
procedure Check_Include (Iterator : Reader) is
use type Strings.Maps.Character_Set;
Blank : constant Strings.Maps.Character_Set :=
Strings.Maps.To_Set (" " & ASCII.HT);
Identifier : constant Strings.Maps.Character_Set :=
Strings.Maps.Constants.Alphanumeric_Set
or Strings.Maps.To_Set ("_");
First, Last : Natural := 1;
begin
First := Index (Iterator, "@@INCLUDE@@");
if First /= 0 then
First := Strings.Fixed.Index
(Iterator.Content (First .. Iterator.Last), Blank);
First := Strings.Fixed.Index
(Iterator.Content (First .. Iterator.Last), not Blank);
Last := Strings.Fixed.Index
(Iterator.Content (First .. Iterator.Last), Blank);
if Last = 0 then
-- Last is end-of-line
Last := Iterator.Last;
else
Last := Last - 1;
end if;
-- First .. Last is filename
declare
I_Filename : constant String :=
Iterator.Content (First .. Last);
Is_First : Boolean := True;
begin
-- Check only aws_*.tjs
if Strings.Fixed.Index (I_Filename, "aws_") /= 0
and then Directories.Extension (I_Filename) = "tjs"
then
loop
First := Last + 1;
Strings.Fixed.Find_Token
(Iterator.Content (First .. Iterator.Last),
Identifier,
Test => Strings.Inside,
First => First,
Last => Last);
exit when Last = 0;
if Is_First then
Is_First := False;
elsif not Is_Id_Ignored
(Iterator.Content (First .. Last))
then
declare
Id : constant Id_Dict.Id := Id_Dict.Get
(Iterator.Content (First .. Last));
begin
Id_Dict.Add
(Id,
(To_Unbounded_String (Filename),
Iterator.Line,
First,
Ajax_Response_Kind));
end;
end if;
end loop;
end if;
end;
end if;
end Check_Include;
----------
-- Find --
----------
procedure Find
(Iterator : Reader;
Attribute : String;
Process : not null access procedure
(Iterator : Reader;
Name : String;
Column : Positive))
is
procedure Check (C : Character);
-----------
-- Check --
-----------
procedure Check (C : Character) is
First, Last : Natural := 1;
begin
loop
First := Index (Iterator, Attribute & '=' & C, First);
exit when First = 0;
Last := Index
(Iterator, String'[C], First + Attribute'Length + 2);
if Last = 0 then
First := Iterator.Last;
else
Process
(Iterator,
Iterator.Content
(First + Attribute'Length + 2 .. Last - 1),
First + Attribute'Length + 2);
First := Last + 1;
end if;
end loop;
end Check;
begin
Check (''');
Check ('"');
end Find;
-------------------
-- Process_Class --
-------------------
procedure Process_Class
(Iterator : Reader; Name : String; Column : Positive) is
begin
Record_Class
(Name,
(To_Unbounded_String (Filename), Iterator.Line, Column, Kinds));
end Process_Class;
----------------
-- Process_Id --
----------------
procedure Process_Id
(Iterator : Reader; Name : String; Column : Positive) is
begin
if not Is_Id_Ignored (Name) then
Record_Id
(Name,
(To_Unbounded_String (Filename), Iterator.Line, Column, Kinds));
end if;
end Process_Id;
Iterator : Reader;
begin
Open (Filename, Iterator);
loop
Next (Iterator);
Find (Iterator, "id", Process_Id'Access);
Find (Iterator, "class", Process_Class'Access);
Check_Include (Iterator);
Clear_Content (Iterator);
exit when Eof (Iterator);
end loop;
Close (Iterator);
end Process_ML;
------------------
-- Record_Class --
------------------
procedure Record_Class (Name : String; Location : Occurence) is
Id : constant Class_Dict.Id := Class_Dict.Get (Name);
begin
if Class_Prefix /= Null_Unbounded_String then
Check_Prefix (Name, To_String (Class_Prefix), Location);
end if;
Class_Dict.Add (Id, Location);
end Record_Class;
---------------
-- Record_Id --
---------------
procedure Record_Id (Name : String; Location : Occurence) is
function Prefix_From_File (Filename : String) return String;
-- Returns the expected prefix for Ids declared in Filename
----------------------
-- Prefix_From_File --
----------------------
function Prefix_From_File (Filename : String) return String is
Prefix : Unbounded_String;
Get_Next : Boolean := True;
begin
for K in Filename'Range loop
if Get_Next then
Append (Prefix, Filename (K));
Get_Next := False;
elsif Filename (K) = '_' then
Get_Next := True;
end if;
end loop;
return To_String (Prefix);
end Prefix_From_File;
Id : constant Id_Dict.Id := Id_Dict.Get (Name);
begin
-- Only check the naming convention for a definition
if (Location.Kind and Def_Kind) /= No_Kind then
if Id_Prefix /= Null_Unbounded_String then
Check_Prefix (Name, To_String (Id_Prefix), Location);
elsif Id_File then
Check_Prefix
(Name,
Prefix_From_File
(Directories.Base_Name (To_String (Location.Filename))),
Location);
end if;
end if;
Id_Dict.Add (Id, Location);
end Record_Id;
begin
Parse_Command_Line;
-- Parse all files
loop
declare
S : constant String :=
GNAT.Command_Line.Get_Argument (Do_Expansion => True);
begin
exit when S'Length = 0;
Process (S);
end;
end loop;
if Dump_Classes then
Text_IO.New_Line;
Text_IO.Put_Line ("*** Class dictionary");
Class_Dict.Dump (Check);
end if;
if Dump_Ids then
Text_IO.New_Line;
Text_IO.Put_Line ("*** Id dictionary");
Id_Dict.Dump (Check);
end if;
if Has_Error then
Command_Line.Set_Exit_Status (Command_Line.Failure);
else
Command_Line.Set_Exit_Status (Command_Line.Success);
end if;
exception
when Syntax_Error | GNAT.Command_Line.Invalid_Switch =>
Text_IO.Put_Line ("webxref - Web Cross-References v" & Version);
Text_IO.New_Line;
Text_IO.Put_Line ("Usage : webxref [-huxcCiIv] file1 file2...");
Text_IO.New_Line;
Text_IO.Put_Line
(" -h : display help");
Text_IO.Put_Line
(" -x : output all cross-references (default)");
Text_IO.Put_Line
(" -u : output unused entities only");
Text_IO.Put_Line
(" -d : output referenced but undefined entities only");
Text_IO.Put_Line
(" -i : handle id elements");
Text_IO.Put_Line
(" -I : do not handle id elements");
Text_IO.Put_Line
(" -c : handle class elements");
Text_IO.Put_Line
(" -C : do not handle class elements");
Text_IO.Put_Line
(" -pi prefix : id must have the given prefix");
Text_IO.Put_Line
(" 'file_based' to use filename based prefix");
Text_IO.Put_Line
(" -pc prefix : class must have the given prefix");
Text_IO.Put_Line
(" -ki name : kill id, do not handle this specific id");
Command_Line.Set_Exit_Status (Command_Line.Failure);
end Webxref;
Reference in New Issue View Git Blame Copy Permalink