procedure TClassesTree.SkanDirExt(Dir:string);
var F:TSearchRec;
dirlist,filelist:TStringList;
i:integer;
begin
if Dir[Length(Dir)] <> '\' then Dir:=Dir+'\';
dirlist := TStringList.Create;
filelist := TStringList.Create;
dirlist.Add(Dir);
try
repeat
Dir := dirlist.Strings[0];
dirlist.Delete(0);
if FindFirst(Dir+'*.*',faAnyFile,F) = 0 then
repeat
if ((F.Attr and faDirectory) = faDirectory) and (F.Name <> '.') and (F.Name <> '..') then
dirlist.Add(Dir+F.Name+'\')
else
if ((F.Attr and faDirectory) = 0) and ( LowerCase(ExtractFileExt(F.Name)) = '.pas' ) then
filelist.Add(Dir+F.Name);
until FindNext(F) <> 0;
FindClose(F);
until dirlist.Count = 0;
for i:=0 to filelist.Count-1 do SkanFile(filelist[i]);
finally
dirlist.Free;
filelist.Free;
end;
end;
function TClassesTree.ExcludeStringsAndComments(vs:string; var st:TAnalysisState):string;
var i:integer;
rl:integer;
// Комментарии:
// //..... - type 1 or type Slash ( SL )
// {.....} - type 2 or type Figure Brackets ( FB )
// (*...*) - type 3 or type Compound Brackets ( CB )
// sNorm - обычный код
// sStr - строка
// sSLfirst - встретился первый символ slash / , ждём второй /
// sSLcom - встретили второй символ slash / , идет комментарий типа 1
// sFB - встретили символ Figure Brackets { , идёт комментарий типа 2
// sCBfirst - встретился первый символ ( , ждём *
// sCBcom - встретился символ * , идёт комментарий типа 3
// sCBend - встретился символ * , ждём )
begin
SetLength(Result,Length(vs));
rl := 0;
for i:=1 to Length(vs) do
begin
Case st of
sNorm : begin
Case vs[i] of
'''': st:=sStr;
'/': st:=sSLfirst;
'{': st:=sFB;
'(': st:=sCBfirst;
else begin
Inc(rl); Result[rl]:=vs[i];
end;
End;
end;
sStr : begin
if vs[i]='''' then st:=sNorm;
Continue;
end;
sSLfirst : begin
if vs[i]='/' then begin st:=sSLcom; Break; end
else
begin
Inc(rl); Result[rl]:='/';
Case vs[i] of
'''': st:=sStr;
'{': st:=sFB;
'(': st:=sCBfirst;
else begin
st:=sNorm;
Inc(rl); Result[rl]:=vs[i];
end;
End;
end;
end;
//sSLcom : ;
sFB : begin
if vs[i]='}' then st:=sNorm;
Continue;
end;
sCBfirst : begin
if vs[i]='*' then begin st:=sCbcom; Continue; end
else
begin
Inc(rl); Result[rl]:='(';
Case vs[i] of
'''': st:=sStr;
'/': st:=sSLfirst;
'{': st:=sFB;
'(': st:=sCBfirst;
else begin
st:=sNorm;
Inc(rl); Result[rl]:=vs[i];
end;
End;
end;
end;
sCBcom : begin
if vs[i]='*' then st:=sCBend;
Continue;
end;
sCBend : begin
if vs[i]=')' then st:=sNorm
else if vs[i]<>'*' then st:=sCBcom;
Continue;
end;
End;
end;
Case st of
sSLfirst: begin Inc(rl); Result[rl]:='/'; st:=sNorm; end;
sCBfirst: begin Inc(rl); Result[rl]:='('; st:=sNorm; end;
sCBend: begin st:=sCBCom; end;
sSLcom: begin st:=sNorm; end;
End;
SetLength(Result,rl);
end;
procedure TClassesTree.SkanFile(FileName:string);
const _sf01 = '= class of';
_sf02 = '=class of';
_sf1 = '= class';
_sf2 = '=class';
var s:string;
ln,p:integer;
state:TAnalysisState;
function GetCname:string;
var p1,p2:integer;
begin
p2 := p-1;
while (s[p2]=' ') do Dec(p2);
p1 := p2;
if p1 <> 1 then
begin
while (s[p1]<>' ') and (p1>1) do Dec(p1);
Result := Copy(s,p1+1,p2-p1);
end
else Result := s[p1];
end;
function GetCparent:string;
var p1,p2,p3:integer;
begin
p1 := PosEx('(',s,p);
if p1 > 0 then
begin
p2 := PosEx(')',s,p1);
p3 := PosEx(',',s,p1);
// note: may be construction: TInterfacedPersistent = class(TPersistent, IInterface)
// and if pos(',') < pos(')')
// we take only name of class ( in this case: TPersistent )
if (p3 > 0) and (p3 < p2) then
Result := StringReplace(Copy(s,p1+1,p3-p1-1),#32,'',[rfReplaceAll])
else Result := StringReplace(Copy(s,p1+1,p2-p1-1),#32,'',[rfReplaceAll]);
end
else Result := '';
end;
function GetCLparent(sflen:integer):string;
var p1,p2:integer;
begin
p1 := p + sflen + 1;
if p1 > Length(s) then
begin
Result := '';
Exit;
end;
p2 := PosEx(';',s,p1);
if p2 > 0 then
begin
Result := StringReplace(Copy(s,p1,p2-p1),#32,'',[rfReplaceAll]);
end
else Result := '';
end;
function IsCorrect(sflen:integer):integer;
var p1:integer;
begin
if p-1>0 then
begin
if s[p-1] = ':' then Result := 0
else
begin
p1 := p + sflen;
if p1 > Length(s) then Result := p
else
begin
if (s[p1] <> ' ') and (s[p1] <> '(') then Result := 0
else Result := p;
end;
end;
end
else Result := 0;
end;
begin
Assign(FTF,FileName);
Reset(FTF);
ln := 0;
state := sNorm;
while not EOF(FTF) do
begin
Readln(FTF,s);
Inc(ln);
s := StringReplace(s,#9,#32,[rfReplaceAll]);
s := StringReplace(s,#32#32,#32,[rfReplaceAll]);
s := ExcludeStringsAndComments(s,state);
if s = '' then Continue;
// find
p := Pos(_sf01,LowerCase(s));
if p = 0 then
begin
p := Pos(_sf02,LowerCase(s));
if p > 0 then
begin
if FIncludeClassLinks then Self.AddClass(GetCname,GetCLparent(Length(_sf02)),FileName,ln);
Continue;
end;
end
else
begin
if FIncludeClassLinks then Self.AddClass(GetCname,GetCLparent(Length(_sf01)),FileName,ln);
Continue;
end;
//
p := Pos(_sf1,LowerCase(s));
if p = 0 then
begin
p := Pos(_sf2,LowerCase(s));
if p > 0 then p := IsCorrect(Length(_sf2));
end
else p := IsCorrect(Length(_sf1));
// add
if p > 0 then Self.AddClass(GetCname,GetCparent,FileName,ln)
end;
Close(FTF);
end;
procedure TClassesTree.GetClassesFromDir(Dir:string; IncludeSubFolders:boolean=false);
begin
if DirectoryExists(Dir) then
begin
if IncludeSubFolders then SkanDirExt(Dir)
else SkanDir(Dir);
MakeLinks;
end;
end;
end.