ClassOverview: per vederci chiaro

Capita spesso di scrivere librerie o programmi molto complessi, soprattutto classi molto complesse. Ad un certo punto ci si può ritrovare a perdere un po' di vista il flusso generale del codice. L'obiettivo di ClasseOverview è quello di mostrare graficamente uno schema generale del progetto. Per il momento, essendo un prototipo, è in grado di analizzare un singolo. pass alla volta. Una volta caricato il sorgente vengono mostrate tutte le procedure,le funcion, i constructor e i destructor. Queste quattro definizioni sono i metodi che vengono gestiti da una lista. E' possibile spostare con il drag and drop del mouse i nomi dei metodi sulla form. Questi posizionamenti vengono salvati nella sottocartella Methods. Facendo clic sul singolo metodo la memo mostrerà quella porzione di codice solitamente compresa tra un begin e un end. I due pulsanti mostrano i metodi in memoria e quando questi metodi chiamano altri metodi.

Puoi scaricare il progetto completo qui.


unit Unit1;
interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StrUtils, StdCtrls, Generics.Collections ,Generics.Defaults,
  Inifiles, Math, Vcl.ComCtrls ;

type TRecordClassMethod = record
  Classe : string;    // nome della Classe
  Method : string;    // nome della procedure o function
  pas: string         // unit.pas in cui è dichiarata
end;

type TPasClass = Class
  Classe : string;    // nome della Classe
  pas: string         // unit.pas in cui è dichiarata
end;

type TClassMethod = Class
  posBegin: integer;  // riga del sorgente.pas ( di solito suito sotto si trova 'begin')
  posEnd: integer;    // riga del sorgente.pas dove si trova 'end;' che conclude il begin
  Classe : string;    // nome della Classe
  Method : string;    // nome della procedure o function
  pas: string         // unit.pas in cui è dichiarata
end;

type TmyLabel = Class
  FormLabel: TLabel;
  Classe : string; // nome della Classe
  Method : string;    // nome della procedure o function
  constructor create ( aClass, aMethod: string; X,Y: integer; aCol:TColor );
end;

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    aBox1: TComboBox;
    Button1: TButton;
    Button2: TButton;
    ProgressBar1: TProgressBar;
    ProgressBar2: TProgressBar;
    Button3: TButton;
    OpenDialog1: TOpenDialog;
    Label1: TLabel;
    ListBox1: TListBox;
    procedure FormCreate(Sender: TObject);
    procedure LabelClick(Sender: TObject);
    procedure LabelDblClick(Sender: TObject);
    procedure LabelMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure LabelMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormPaint(Sender: TObject);

    procedure TsCopyToLower;
    function FindNextEnd ( StartRow: integer ) : integer;
    function GetMethod ( S: string): TClassMethod;
    procedure FindReferences ( S: string);
    procedure FindEveryCall ( Index, b,e: integer ; apasFile:string );

    function FindValidMethod ( MainClassMethod, aClassMethod:TclassMethod; row: integer): TRecordClassMethod;
    function GetClassFromVariable ( aMethod,aRowString: string; StartMethod, StartAfterMethod,Row: integer): string;

    procedure aBox1Select(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure aBox1KeyPress(Sender: TObject; var Key: Char);
    procedure Button3Click(Sender: TObject);
  private
    { Private declarations }
    procedure SaveIni;

    procedure ExtractClassMethods ( aPasClass: TPasClass );
    function MyLabelExists ( aClass, aMethod: string): boolean;
    function MethodExist ( aClass, aMethod: string): boolean;
    function ClassesExist ( aClass: string): boolean;
    procedure AddClassMethod ( aPasClass, aClassName , aMethodName: string ; i: integer);
    function JustClassName ( S: string; Index: integer ) : string; overload;  // JustClassName + '.' + JustMethodName;
    function JustMethodName ( S: string; Index, endm: integer ) : string; overload; // JustClassName + '.' + JustMethodName;
    function ValidLeftMethod ( aRowString: string; StartMethod, StartAfterMethod, row: integer ): TRecordClassMethod;
    function ValidRightMethod ( aRowString: string; StartMethod, StartAfterMethod: integer ): TRecordClassMethod;
    function ValidRightVariable ( aRowString: string; StartVar, StartAfterVar, row: integer ): string;
    function ValidLeftVariable ( aRowString: string; StartVar, StartAfterVar, row: integer ): string;
    Function GetClass  (aVariable,aRowString: string; StartVar: integer ): string;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  DIR_APP: string;
  DIR_METHODS :string;
  px,py:integer;
  tsLink: TStringList;
  tsPasLower : Tstringlist;                // tutto il sorgente .pas attuale in formato LowerCase
  tsPasOriginal : Tstringlist;             // tutto il sorgente .pas attuale

  lstLabels: TobjectList<TmyLabel>;   // lista delle Tlabel
  lstClassMethods: TobjectList<TClassMethod>;   // lista di tutte le classi e metodi globale
  lstPasClasses: TobjectList<TPasClass>;   // lista di tutte le classi globale
implementation
function GetAppVersionStr: string;
var
  Exe: string;
  Size, Handle: DWORD;
  Buffer: TBytes;
  FixedPtr: PVSFixedFileInfo;
begin
  Exe := ParamStr(0);
  Size := GetFileVersionInfoSize(PChar(Exe), Handle);
  if Size = 0 then
    RaiseLastOSError;
  SetLength(Buffer, Size);
  if not GetFileVersionInfo(PChar(Exe), Handle, Size, Buffer) then
    RaiseLastOSError;
  if not VerQueryValue(Buffer, '\', Pointer(FixedPtr), Size) then
    RaiseLastOSError;
  Result := Format('%d.%d.%d.%d',
    [LongRec(FixedPtr.dwFileVersionMS).Hi,  //major
     LongRec(FixedPtr.dwFileVersionMS).Lo,  //minor
     LongRec(FixedPtr.dwFileVersionLS).Hi,  //release
     LongRec(FixedPtr.dwFileVersionLS).Lo]) //build
end;
{$R *.dfm}
constructor TmyLabel.create ( aClass, aMethod: string; X,Y: integer; aCol:TColor );
begin
  classe:= aClass;
  Method:= aMethod;
  FormLabel:= TLabel.Create(Form1);
  FormLabel.Parent := Form1;
  FormLabel.Name:= lowercase(aClass + aMethod);
  if aCol <> clBlue then
    FormLabel.Caption := '-->' + aClass+'.' + aMethod
  else
    FormLabel.Caption := aMethod;

  FormLabel.Width:=100;
  FormLabel.height:=20;
  FormLabel.Left := X;
  FormLabel.Top := Y;
  FormLabel.Font.Color := aCol;
  FormLabel.autosize:=true;
  FormLabel.OnMouseDown:= form1.LabelMouseDown;
  FormLabel.OnMouseMove := form1.LabelMouseMove;
  FormLabel.OnClick := form1.LabelClick;
  FormLabel.OnDblClick := form1.LabelDblClick;
  FormLabel.Visible:=true;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Caption:= 'ClassOverview ' + GetAppVersionStr;
  DIR_APP:=   extractfilepath(application.exename) ;
  DIR_METHODS := extractfilepath(application.exename) + 'methods\';
  if not DirectoryExists(DIR_METHODS) then CreateDir (DIR_METHODS);


  TsPasOriginal:= TStringList.Create ;
  TsPasLower:= TStringList.Create ;

  lstClassMethods:= TobjectList<TClassMethod>.create (true);
  lstPasClasses:= TobjectList<TPasClass>.create (true);

  lstLabels:=  TobjectList<TMyLabel>.create (true);

  tsLink:= TStringList.Create ;
  tsLink.Duplicates := dupIgnore;
  tsLink.Sorted := true;


end;
function Tform1.GetMethod ( s: string ): TClassMethod;
var
i: integer;
begin
   result:=nil;
   for I := 0 to lstClassMethods.count -1 do begin
    if lowercase(aBox1.Text)  = lowercase(lstClassMethods[i].Classe) then begin    // solo la classe selezionata dalla combobox
      if S = lowercase(lstClassMethods[i].Method) then begin
       Result := lstClassMethods[i];
       exit;
      end;
    end;
   end;
end;

procedure TForm1.LabelClick(Sender: TObject);
var
aClassMethod: TClassMethod;
c: integer;
begin
   memo1.Lines.Clear;
   //advMemo1.lines.Clear ;
   aClassMethod := GetMethod (TLabel(sender).Caption);
   if aClassMethod <> nil then begin
      for c:= aClassMethod.posBegin -1 to aClassMethod.posEnd do begin
        memo1.Lines.Add(tsPasLower[c]);
       // advMemo1.lines.Add(tsPas[c]);
      end;
   end;

end;
procedure TForm1.LabelDblClick(Sender: TObject);
var
  I: Integer;
begin
    SaveIni;
   for I := 0 to aBox1.Items.Count -1  do begin
    if lowercase(aBox1.Items[i]) = (JustClassName (TLabel(sender).Caption,4) )  then begin // 4 per le frecce -->
      aBox1.ItemIndex := i;
      aBox1Select(aBox1);
      invalidate;
      exit;
    end;

   end;

end;

procedure TForm1.LabelMouseDown(Sender: TObject;  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
i: integer;
hide: string;
begin
    px:=x;
    py:=y;
    if Button = mbRight then begin
      // dalla TLabel risalgo a tsLink per settare le LineTo !HIDE, ma TLabel rimane visibile;
      tsLink.Sorted := false;
      if Leftstr(tLabel(Sender).Caption,3) = '-->' then begin  // qui Label di un'altra classe
        // Cerco nella tsLink dove il valore Classe.metodo=Classe.metodo è uguale a Classe+punto+metodo
        for I := 0 to tsLink.Count -1 do begin
          Hide:= LeftStr(tsLink.Names [i],5 );
          if Hide <> '!HIDE' then begin
            if ((tsLink.ValueFromIndex [i] ) = JustClassName (tLabel(Sender).Caption,4) +
                                              '.' +
                                              JustMethodName(tLabel(Sender).Caption ,4, Length(tLabel(Sender).Caption)+1))
            or (tsLink.Names [i] = lowercase(JustClassName (tLabel(Sender).Caption,4) +
                                              '.' +
                                              JustMethodName(tLabel(Sender).Caption ,4, Length(tLabel(Sender).Caption)+1)))
            then begin
                // Inserisco !HIDE
                tslink[i]:= '!HIDE' + tsLink.Names [i] + '=' + tsLink.ValueFromIndex [i];// <-- nella Form.paint evita di tirare le linee
            end;
          end
          else if LeftStr(tsLink.Names [i],5 ) = '!HIDE' then begin
                // Elimino !HIDE
                tslink[i]:=  RightStr(tsLink.Names [i],length(tsLink.Names [i])-5 ) + '=' + tsLink.ValueFromIndex [i];// <-- nella Form.paint evita di tirare le linee
          end;
        end
      end
      else begin // qui Label di questa Classe // NO frecce -->
        // Creco nella tsLink dove il valore Classe.metodo=Classe.metodo è uguale a Classe+punto+metodo
        for I := 0 to tsLink.Count -1 do begin
          Hide:= LeftStr(tsLink.Names [i],5 );
          if Hide <> '!HIDE' then begin
              if (  tsLink.ValueFromIndex [i] = lowercase(aBox1.Items [aBox1.ItemIndex ] + '.' + tLabel(Sender).Caption ))
              or (  tsLink.Names [i] = lowercase(aBox1.Items [aBox1.ItemIndex ]) +  '.' + tLabel(Sender).Caption )
              then begin
                  // Inserisco !HIDE
                  tslink[i]:= '!HIDE' + tsLink.Names [i] + '=' + tsLink.ValueFromIndex [i];// <-- nella Form.paint evita di tirare le linee
              end;
          end
          else if LeftStr(tsLink.Names [i],5 ) = '!HIDE' then begin
                // Elimino !HIDE
                tslink[i]:=  RightStr(tsLink.Names [i],length(tsLink.Names [i])-5 ) + '=' + tsLink.ValueFromIndex [i];// <-- nella Form.paint evita di tirare le linee
          end;
        end;
      end;
      tsLink.Sorted := true;
      invalidate;
  end;
end;

procedure TForm1.LabelMouseMove(Sender: TObject;  Shift: TShiftState; X, Y: Integer);
begin
  if ssLeft in Shift then
  with Sender as TControl do
  begin
    SetBounds(Left+X-PX,Top+Y-PY,Width,Height);
  if sender is TLabel then
  begin
    form1.Repaint;
  end;
  end;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  SaveIni;
  lstClassmethods.free;
  lstPasClasses.free;
  tsLink.free;

end;
procedure Tform1.SaveIni;
var
i: integer;
b:TLabel;
ini: Tinifile;
begin
  ini:= TIniFile.Create(DIR_METHODS +  aBox1.Text + '.ini') ;
  // salvo le TLabel solo della classe selezionata dalla combobox e le relative call esterne -->
  for i := 0 to lstClassMethods.Count-1 do begin
    if lowercase(aBox1.Text)  = lowercase(lstClassMethods[i].Classe) then begin
      B := FindComponent (lowercase(lstClassMethods[i].classe) + lowercase(lstClassMethods[i].Method)) as TLabel;
      ini.WriteInteger(lstClassMethods[i].Classe + lstClassMethods[i].Method , 'x',b.left);
      ini.WriteInteger(lstClassMethods[i].Classe + lstClassMethods[i].Method , 'y',b.top);
    end
    else begin
      B := FindComponent ( lowercase(lstClassMethods[i].classe) + lowercase(lstClassMethods[i].Method)) as TLabel;
      if B <> nil then begin
        if leftStr(B.Caption,3) ='-->' then begin
          ini.WriteInteger(lstClassMethods[i].Classe + lstClassMethods[i].Method , 'x',b.left);
          ini.WriteInteger(lstClassMethods[i].Classe + lstClassMethods[i].Method , 'y',b.top);
        end;
      end;
    end;
  end;

  ini.Free;
end;
procedure TForm1.FormPaint(Sender: TObject);
var
i: integer;
b: TLabel;
S: string;
begin
//  exit;
  Canvas.Pen.Style := psSolid;
  Canvas.Pen.Color := clBlack;
  Canvas.Pen.Width :=1;

  for i := 0 to tsLink.Count-1 do begin
    if leftStr(tsLink.Names [i],5 ) <> '!HIDE' then

    S:= StringReplace (tsLink.Names [i],'.','',[rfReplaceAll]);
    b:=FindComponent (S) as TLabel;
    if b= nil then continue; // le !HIDE non esistono come Tlabel, la caption della Tlabel rimane invariata

    Canvas.MoveTo(b.Left,b.top);
    Canvas.Rectangle (b.Left,b.Top,b.Left-5,b.Top-5);
    S:= StringReplace (tsLink.ValueFromIndex [i],'.','',[rfReplaceAll]);

    // Possono comunque esistere delle Tlabel aasenti generate da inherited alla classe astratta. Non conoscendo la classe
    // da cui deriva skippo l'errore.
    b:=FindComponent (S) as TLabel;;
    if b= nil then continue;


    Canvas.LineTo(b.Left,b.top);
    Canvas.Rectangle (b.Left,b.Top,b.Left-2,b.Top-2);

         // Tlabel che iniziano con i la freccia --> appartenenti ad un'altra classe
         // Possiamo vedere solo una classe alla volta
    end;
end;



procedure TForm1.Button1Click(Sender: TObject);
var
  I: Integer;
begin
  memo1.Lines.Clear ;
  for I := 0 to tsLink.Count -1 do begin
    memo1.Lines.Add(tsLink[i]);
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
i:integer;
begin
  memo1.Lines.Clear ;
  for I := 0 to lstClassMethods.Count -1 do begin
    memo1.Lines.Add(lstClassMethods[i].Classe + '.' + lstClassMethods[i].Method ) ;
  end;

end;
procedure TForm1.Button3Click(Sender: TObject);
var
Classmarker, i,y: integer;
aPasClass: TPasClass;
label NextClass;
begin
if OpenDialog1.Execute then begin
    if FileExists(OpenDialog1.FileName) then
      TsPasOriginal.LoadFromFile(OpenDialog1.filename);

      TsCopyToLower;


      for I := 0 to tsPasLower.Count -1 do begin

        classMarker := pos ( 'class', tsPasLower[i],1 );
        if ClassMarker <> 0 then begin
         // showMessage(tsPasLower.Strings[i]);
          for y := Classmarker -1 downto 0 do begin
            if tsPasLower[i][y] = '=' then begin
              if Not ClassesExist (trim ( leftstr (tsPasLower[i],y-1))) then begin  // check duplicati
                aPasClass := TPasClass.Create;
                aPasClass.pas := OpenDialog1.filename;
                aPasClass.Classe := trim ( leftstr (tsPasLower[i],y-1));
                lstPasClasses.Add(aPasClass);
              end;
            end
            else if (tsPasLower[i][y] <> '=') and (tsPasLower[i][y] <> ' ')  then goto NextClass; // sono un bad programmer...

          end;
        end;
NextClass:
      end;


      aBox1.Clear ;

      for I := 0 to lstPasClasses.Count -1 do begin
        aBox1.AddItem (lstPasClasses[i].Classe ,nil );
        ExtractClassMethods ( lstPasClasses[i] );
      end;
      ListBox1.AddItem( extractfilename(aPasClass.pas),nil);
end
else
      raise Exception.Create('File does not exist.');

end;

procedure TForm1.ExtractClassMethods ( aPasClass: TPasClass);
var
  c,endm,i: integer;
  tmpS: string;
begin

  for i := 0 to tsPasLower.count -1 do begin    // tutto il sorgente .pas
    tmpS := StringReplace ( tsPasLower[i] ,' ', '', [rfReplaceAll]);
    c:= pos ( lowercase ( aPasClass.Classe ) + '.' , tmpS, 1);  // es.= 'TSomeClass.'
    if c <> 0 then begin

      // Qui sotto posso trovare TSomeClass.SomeMethod (  oppure TSomeClass.SomeMethod e la riga inizia con function o procedure ecc...
      // Se trovo TSomeClass.SomeMethod verifico che sia function, procedure, constructor, destructor
      // quindi se elimino tutti gli spazi troverò ad esempio procedureTSomeClass.SomeMethod( oppure procedureTSomeClass.SomeMethod;
      // oppure functionTSomeClass.SomeMethod: oppure functionTSomeClass.SomeMethod(
      // non mi servono i parametri ma solo il nome del metodo
      if (leftstr (  trim ( tsPasLower[i] ),8 ) = 'function')  then begin
      // cerco da c in poi il carattere  ( che determina la fine della function. A questo punto non devo cercare i :
         endm:= pos (  '(', tmpS , c + length(aPasClass.Classe  + '.') ); // prima cerco la parentesi (
         if endm <> 0 then
              AddClassMethod ( aPasClass.pas, JustClassName  (tmpS, c), JustMethodName (tmpS, c, endm), i  )
         else begin // non ho trovato parentesi, è una function senza params, allora cerco i :
           endm:= pos (  ':', tmpS , c + length(aPasClass.Classe  + '.') );
         // cerco da almeno a partire dal . che divide class.method in poi il carattere  : che determina la fine della function
         if endm <> 0 then
              AddClassMethod ( aPasClass.pas, JustClassName  (tmpS, c), JustMethodName (tmpS, c, endm), i  )
         end;
      end
      else if (leftstr (  trim ( tsPasLower[i]) ,9 ) = 'procedure') or
            (leftstr (  trim ( tsPasLower[i] ),11 ) = 'constructor') or
            (leftstr (  trim ( tsPasLower[i]),10 ) = 'destructor') then begin
      // cerco da c in poi il carattere  ( che determina la fine della procedure. A questo punto non devo cercare ;
//         if leftstr (  trim ( lowercase(tsPas[i]) ),11 ) = 'constructor' then asm int 3 end;
         endm:= pos (  '(', tmpS , c + length(aPasClass.Classe  + '.') ); // prima cerco la parentesi (
         if endm <> 0 then
              AddClassMethod ( aPasClass.pas, JustClassName  (tmpS, c), JustMethodName (tmpS, c, endm), i  )
         else begin // non ho trovato parentesi, è una procedure senza params, allora cerco il punto e virgola ;
           endm:= pos (  ';', tmpS , c + length(aPasClass.Classe  + '.') );
         // cerco da almeno a partire dal . che divide class.method in poi il carattere  : che determina la fine della function
         if endm <> 0 then
              AddClassMethod ( aPasClass.pas, JustClassName  (tmpS, c), JustMethodName (tmpS, c, endm), i  )
         end;

         end;


      end;
    end;
end;


(* Trova il numero di riga che contiene 'end;' . In realtà trova il prossimo method *)
 { TODO : non sono ammesse nested routines }
 { TODO : bug sulle property nel getvariables}
function Tform1.FindNextEnd ( StartRow: integer ) : integer;
var
i: integer;
begin
  Result:= StartRow;
  for I := StartRow+1 to tsPasLower.Count -1 do begin
    if  (leftstr (  trim ( tsPasLower[i] ),8  ) = 'function' ) or
        (leftstr (  trim ( tsPasLower[i] ),9  ) = 'procedure') or
        (leftstr (  trim ( tsPasLower[i] ),11 ) = 'constructor') or
        (leftstr (  trim ( tsPasLower[i] ),10 ) = 'destructor') or
        (leftstr (  trim ( tsPasLower[i] ),10 ) = 'end.')
    then begin
      result := i-1;
      exit;
    end;

  end;
end;


(* estrae il nome deella function o procedure da una stringa più complessa *)
function Tform1.JustMethodName ( S: string; Index,endm: integer ) : string;
var
c: integer;
begin
  // Index indica la posizione di inizio Classe , la tipica T
  // esempio di S: 'functionTMyClass.SomeMethod'
  c:= pos ( '.', S, Index);
  Result := MidStr ( S, c +1 , endm -c-1 );
end;

(* estrae il nome deella classe da una stringa più complessa *)
function Tform1.JustClassName ( S: string; Index: integer  ) : string;
var
c: integer;
begin
  // Index indica la posizione di inizio Classe , la tipica T
  // esempio di S: 'functionTMyClass.SomeMethod'
  c:= pos ( '.', S, Index);
  Result := MidStr ( S,  Index , c-Index );
end;

procedure Tform1.FindReferences ( S: string );
var
i,c: integer;
begin
  tsLink.Clear; // una Tstringlist con index e value

  ProgressBar1.Position :=0;

  for i := 0 to lstClassMethods.Count -1 do begin
    if lowercase(S) = lowercase(lstClassMethods[i].Classe) then begin    // solo la classe selezionata dalla combobox
      // mi posiziono alla riga di begin e cerco fino alla riga di 'end;' call ad altri metodi
      ProgressBar2.Position := 0;
      for c := lstClassMethods[i].posBegin to lstClassMethods[i].posEnd do begin
        FindEveryCall (  i, lstClassMethods[i].posBegin, lstClassMethods[i].posEnd,lstClassMethods[i].pas  );
        ProgressBar2.Position := trunc( (100 * c) / (lstClassMethods[i].posEnd-lstClassMethods[i].posBegin));
      //  memo1.Lines.Add(lstClassMethods[i].Classe + '.'+lstClassMethods[i].Method );
      end;
    end;
        ProgressBar1.Position := trunc( (100 * i) / lstClassMethods.Count);
        memo1.Lines.Add(lstClassMethods[i].Classe + '.'+lstClassMethods[i].Method );
  end;

  ProgressBar2.Position := 0;
  ProgressBar1.Position :=0;
end;
procedure TForm1.aBox1KeyPress(Sender: TObject; var Key: Char);
begin
key:=#0;
end;

procedure TForm1.aBox1Select(Sender: TObject);
var
  B: TLabel;
  i,X,Y: integer;
  ini:TIniFile;
  aLabel: tMyLabel;

begin
  // In memoria ho tutte le classi.metodo in lstMethods
  // ora devo ciclare per la classe selezionata ogni Method, e trovare tra posBegin e posEnd altri Method chiamati
  // anche appartenenti ad altri classi della stesso sorgente .pas

  // delete manuale di tutte le Tlabel nella form
  for i := 0 to lstClassMethods.Count -1 do begin
    B := FindComponent (lstClassMethods[i].classe + lstClassMethods[i].Method) as TLabel;
    if B <> nil then B.Destroy ;
  end;
  // ora che ho distrutto le TLabel distruggo anche i puntatori della lista
  lstLabels.Clear ;
  ini:= TIniFile.Create(DIR_METHODS + aBox1.Text + '.ini') ;

  for i := 0 to lstClassMethods.Count -1 do begin
    if lowercase(aBox1.Items [aBox1.ItemIndex ]) = lowercase(lstClassMethods[i].Classe) then begin  // solo la classe selezionata dalla combobox
      X :=   ini.ReadInteger( lstClassMethods[i].Classe + lstClassMethods[i].Method  , 'x', randomrange (20,800));
      Y :=   ini.ReadInteger( lstClassMethods[i].Classe + lstClassMethods[i].Method  , 'y', randomrange (20,600));

      if not MyLabelExists( lstClassMethods[i].Classe , lstClassMethods[i].Method ) then begin
        aLabel:= TmyLabel.Create ( lstClassMethods[i].Classe , lstClassMethods[i].Method,  X, Y ,clblue); // creo a video la TLabel
        lstLabels.Add(aLabel);
      end;
    end;
  end;

  ini.Free;

  FindReferences ( aBox1.Items [aBox1.ItemIndex ] ) ; // riempe tsLink, lista definitiva delle caption a video
  Form1.Paint ;

end;
procedure Tform1.FindEveryCall ( Index, b,e: integer; aPasFile:string );
var
XX,YY,i,y: integer;
aLabel:TmyLabel;
ini: Tinifile;
aValidClassMethod: TRecordClassMethod;
begin
  ini:= TIniFile.Create(DIR_METHODS +  aBox1.Text + '.ini') ;
  tsPasOriginal.LoadFromFile(aPasFile);

  TsCopyToLower;
  // lstSource = lstMethods è globale ma la passo comunque per modifiche future
  for i := b to e do begin
    if (Trim (LeftStr (TsPasLower[i],2)) = '//') or (trim(TsPasLower[i])='') then continue;

    for y := 0 to lstClassMethods.Count -1 do begin

      aValidClassMethod:= FindValidMethod ( lstClassMethods[Index], lstClassMethods[y], i);
      if (aValidClassMethod.classe <> '') and (aValidClassMethod.Method <> '') then begin // classe e method trovati
        tsLink.Add(lowercase(lstClassMethods[Index].Classe + '.' + lstClassMethods[Index].Method + '=' +
                            // lstClassMethods[y].Classe +'.' + lstClassMethods[y].Method)  );  //<---- tsLink
                            aValidClassMethod.Classe +'.' + aValidClassMethod.Method)  );  //<---- tsLink

         if lstClassMethods[Index].Classe <>  lstClassMethods[y].Classe then begin
          if not MyLabelExists( lstClassMethods[y].Classe , lstClassMethods[y].Method ) then begin
            // se non esiste la myLabel la creo. Sono labels di altra classe
            XX :=   ini.ReadInteger( lstClassMethods[y].Classe + lstClassMethods[y].Method  , 'x', randomrange (20,800));
            YY :=   ini.ReadInteger( lstClassMethods[y].Classe + lstClassMethods[y].Method  , 'y', randomrange (20,600));
            aLabel:= TmyLabel.Create ( lstClassMethods[y].Classe , lstClassMethods[y].Method,  XX, YY ,clred); // creo a video la TLabel
            lstLabels.Add(aLabel);
          end;
        end;


      end



    end;
  end;
ini.Free;
end;

(* Ritorna true se esiste la MyLabel e quindi Tlabel con Name = classe + method *)
function Tform1.MyLabelExists ( aClass, aMethod: string): boolean;
var
i: integer;
begin
  result:= false;
  for I := 0 to lstLabels.count -1 do begin
    if (lstLabels[i].Classe = aClass ) and (lstLabels[i].Method  = aMethod  )then begin
      result := true;
      exit;
    end;

  end;

end;
(* Ritorna true se classe + method sono già nella lista per evitare duplicati di overload*)
function TForm1.MethodExist ( aClass, aMethod: string): boolean;
var
i: integer;
begin
  result:= false;
  for I := 0 to lstClassMethods.count -1 do begin
    if (lstClassMethods[i].Classe = aClass ) and (lstClassMethods[i].Method  = aMethod  )then begin
      result := true;
      exit;
    end;

  end;
end;
(* Ritorna true se classe è già nella lista per evitare duplicati*)
function TForm1.ClassesExist ( aClass: string): boolean;
var
i: integer;
begin
  result:= false;
  for I := 0 to lstPasClasses.count -1 do begin
    if lowercase(lstPasClasses[i].Classe) = lowercase(aClass)  then begin
      result := true;
      exit;
    end;

  end;
end;
procedure Tform1.AddClassMethod ( aPasClass, aClassName , aMethodName: string ; i: integer);
var
aClassMethod: TClassMethod;
begin
  if Not MethodExist ( aClassName, aMethodName ) then begin
    aClassMethod:= TClassMethod.Create ;
    aClassMethod.Classe := aClassName;
    aClassMethod.Method := aMethodName;
    aClassMethod.posBegin := i+1;              // di solito begin è la riga subito sotto. Da migliorare!
    aClassMethod.posEnd := FindNextEnd (i);
    aClassMethod.pas := aPasClass;
    lstClassMethods.Add(aClassMethod);
  end;
end;
function Tform1.ValidLeftMethod ( aRowString: string; StartMethod, StartAfterMethod, row: integer ): TRecordClassMethod;
const
  PrefixAllowed = '(;+-*/.,@{='; // attenzione particolare a @
var
  aPossibleMethod: string;
  i: integer;
begin
  // qui ho trovato per esempio MyGame.CreateMapCoord ( a, b ); e sia Create, Map e Coord possono essere il nostro metodo
  // quindi devo distinguere metodi come Create Map CreateMapCoord  SetCoords enucleando il nome del metodo
  // il metodo può essere .map .map(  map
  // ValidLeftMethod a differenza di ValidRightMethod torna anche la classe (se presente) verificando eventuali inherited
  aPossibleMethod := MidStr (aRowString  , StartMethod, StartAfterMethod - StartMethod);
  if StartMethod = 1 then exit;

  // qui minimo StartMethod è 2
  for i := StartMethod-1 downto 1 do begin
    if pos ( aRowString [i], PrefixAllowed, 1 ) > 0 then begin
      Result.Method := aPossibleMethod;
      { il punto determina la ricerca di un typecast o di una variabile }
      if aRowString [i]='.' then Result.classe:= GetClassFromVariable (aPossibleMethod,aRowString,StartMethod, StartAfterMethod,row);
      exit;
    end
    else if pos ( aRowString [i], ' ', 1 ) > 0 then begin   { TODO : potrebbe essere Myclass. myMethod }
      Result.Method := aPossibleMethod;
      exit;
    end
    else begin // qualsiasi altro carattere
      Result.classe :='';
      Result.Method :='';
      exit;
    end;

  end;
  { TODO : gestione inherited }
end;
function Tform1.ValidRightMethod ( aRowString: string; StartMethod, StartAfterMethod: integer ): TRecordClassMethod;
const
  SuffixAllowed = '(;+-*/),{:';
var
  i: integer;
begin
  // qui ho trovato per esempio MyGame.CreateMapCoord ( a, b ); e sia Create, Map e Coord possono essere il nostro metodo
  // quindi devo distinguere metodi come Create Map CreateMapCoord  SetCoords enucleando il nome del metodo
  Result.Method := MidStr (aRowString  , StartMethod, StartAfterMethod - StartMethod);
  if StartAfterMethod = length (aRowString) then exit;

  for i := StartAfterMethod to length (aRowString) do begin
    if pos ( aRowString [i], SuffixAllowed, 1 ) > 0 then begin
  //    Result.Method := aPossibleMethod;
      exit;
    end
    else begin // qualsiasi altro carattere, anche lo spazio
      Result.classe :='';
      Result.Method :='';
      exit;
    end;
  end;
end;

function Tform1.FindValidMethod ( MainClassMethod, aClassMethod:TclassMethod; row: integer): TRecordClassMethod;
var
StartMethod, StartAfterMethod: integer;
begin
 // if (MainClassMethod.Method ='refreshsurface' ) and  (aClassMethod.Method ='rendersprites')
//     and  (pos ( 'rendersprites' , tsPasLower[Row] , 1 ) <> 0)
//  then asm int 3 end;

  result.classe:=''; result.Method :='';
  StartMethod:= pos ( lowercase(aClassMethod.Method) , tsPasLower[Row] , 1 ); // se trovo quel metodo tra begin e end
  if StartMethod = 0 then
    exit;

  StartAfterMethod := StartMethod + length (aClassMethod.Method );

  result.Classe := MainClassMethod.Classe; // di default
  Result:= ValidRightMethod ( tsPasLower[Row] , StartMethod, StartAfterMethod );
  if Result.Method = '' then exit;

  Result:= ValidLeftMethod ( tsPasLower[Row] , StartMethod, StartAfterMethod , row);

end;

function Tform1.GetClassFromVariable ( aMethod,aRowString: string; StartMethod, StartAfterMethod, Row: integer): string;
const
Alphabet = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789[]<>';
var
i,R,c,b,e: integer;
aPossibleVariable: string;
begin
  // qui aMtehod è sicuramente un Method di un'altra classe prechè preceduto da un punto.
  // adesso cerco a ritroso la variabile se esiste. Può essere locale o globale. Oppure è
  // direttamente il Typecast della classe.
  //es.1 TmyClass(a).aMethod
  //es.2 MyVariable.aMethod
  // es.3 a:= TMyClass.create
  Result:='';
  for i := StartMethod-2 downto 1 do begin  // -2 perchè -1 c'è per forza il punto
    if pos ( aRowString [i], Alphabet, 1 ) > 0 then begin
      // prendo caratteri fino a quando non trovo uno spazio
      // a questo punto ho il nome della variabile
      Result:= aRowString [i] + result;
    end
    else if (pos ( aRowString [i], ' ', 1 ) > 0)
     or (pos ( aRowString [i], '=', 1 ) > 0) then begin
      // es=   myvariable   .myvariable  :=Myvariable := Myvariable
      Break;
    end
    else if (pos ( aRowString [i], '.', 1 ) > 0) then begin
        { TODO : potrebbe essere un array o una TlistObject ... la classe è dopo OF }
        Result:='';
    end;

  end;

  // Prima vedo se il nome della variabile è la classe stessa.
  for I := 0 to lstPasClasses.Count -1 do begin
    if lowercase(lstPasClasses[i].Classe) = trim(Result) then
      exit;
  end;

  // se non era la classe stessa cerco na variabile



  // cerco in tutto il codice a ritroso nelle righe la dichiarazione della variabile
  // es=  myvariable: TsomeClass
  // Poi cerco se la classe esiste. Se esiste la aggiungo. In questo modo evito
  // cose come canvas.fill che non dovrebbe essere mostrata, cioè classi note a tutti
  for R := Row-1 Downto 0 do begin
    c:= pos( Result, tsPasLower[R], 1) ;
    if c > 0 then begin
      // devo trovare, al netto di tutto, Myvariable:TSomeClass
        aPossibleVariable:= ValidRightVariable  ( tsPasLower[R], c, c + Length( Result), R );
        if aPossibleVariable = '' then Continue;
        aPossibleVariable:= ValidLeftVariable( tsPasLower[R], c , c + Length( Result),R);
        // adesso ho la variabile, trovo la classe che dovrebbe essere di fianco dopo i due punti
        // es Myabriable:Tsome;
        if aPossibleVariable = '' then Continue;
        result:= GetClass  (aPossibleVariable,tsPasLower[R], c );
        if Result <> '' then break;

    end;
   end;

   // Potrebbe essere TobjectList<TMyClass>
    b:= pos( 'tobjectlist', Result, 1) ;
    if b > 0 then begin
      Result:= StringReplace (Result,' ','',[rfReplaceAll]);
      b:=  pos( '<', Result, 1) ;
      if b > 0 then e:=  pos( '>',Result, b) ;
      if e > 0 then Result:= midStr (Result, b+1, e - b -1);

    end;

end;
Function Tform1.GetClass  (aVariable,aRowString: string; StartVar: integer ): string;
var
  i,x:integer;
begin
  Result:='';
  for I := StartVar + Length(aVariable) to length(aRowString) do begin
    if aRowString [i] = ' ' then continue;
    if aRowString[i] = ':' then begin
      for x:= i+1 to length(aRowString) do begin  // cerco direttamente il punto e virgola
        if aRowString[x] = ';' then begin
          Result:= MidStr ( aRowString, i+1, x-i-1 );
          exit;
        end;
      end;
    end;
  end;
end;

procedure Tform1.TsCopyToLower;
var
i: integer;
begin
  TsPasLower.Clear ;
  for I := 0 to TsPasOriginal.Count -1 do begin
    TsPasLower.Add(lowercase(tsPasoriginal[i]));
  end;
end;
function Tform1.ValidLeftVariable ( aRowString: string; StartVar, StartAfterVar, row: integer ): string;
const
  PrefixAllowed = ', ';
var
  i: integer;
begin
//  if Pos ('<fs>tiratheater.bitmap', arowstring,1) > 0 then asm int 3 end;

  Result := MidStr (aRowString  , StartVar, StartAfterVar - StartVar);
  if StartVar = 1 then exit;

  // qui minimo StartVar è 2
  for i := StartVar -1 downto 1 do begin
    if pos ( aRowString [i], PrefixAllowed, 1 ) > 0 then begin // è permesso solo lo spazio e una virgola
      exit;
    end
    else begin // qualsiasi altro carattere invalida la variabile
      Result :='';
    end;

  end;
end;
function Tform1.ValidRightVariable ( aRowString: string; StartVar, StartAfterVar, row: integer ): string;
const
  SuffixAllowed = ',:';
var
  i: integer;
begin
  // di solito Myvariable:TSome;
  Result := MidStr (aRowString  , StartVar, StartAfterVar - StartVar );
  if StartVar = length (aRowString) then exit;

  for i := StartAfterVar to length (aRowString) do begin
    if aRowString [i] = ' ' then continue;
    if pos ( aRowString [i], SuffixAllowed, 1 ) > 0 then begin
      // se dopo i due punti c'è un uguale non è una dichiarazione  es= myvariable:=  altrimenti è la dichiarazione
      if aRowString [i+1] ='=' then begin
        Result:='';
        exit;
      end
      else
      exit;
    end
    else begin // qualsiasi altro carattere
      Result :='';
      exit;
    end;
  end;
end;
end.