unit ClassesTree;
interface
uses SysUtils,StrUtils,ComCtrls,Classes;
type
TClassNode = record
parentid:integer;
previd:integer;
nextid:integer;
fchildid:integer;
lchildid:integer;
name:string;
parent:string;
// debug info
fullpath:string;
line:integer;
end;
TAnalysisState = (sNorm,sStr,sSLfirst,sSLcom,sFB,sCBfirst,sCBcom,sCBend);
TClassesTree = class
private
FTF:Text;
FNodes: array of TClassNode;
FCount: integer;
FTabChar:string;
FIncludeClassLinks:boolean;
FIncludeDebugInfo:boolean;
IsLinked:boolean;
function GetClass(Id:Integer): TClassNode;
procedure SetClass(Id:integer; Value: TClassNode);
procedure DeleteLinks;
procedure SkanDir(Dir:string);
procedure SkanDirExt(Dir:string);
procedure SkanFile(FileName:string);
function ExcludeStringsAndComments(vs:string; var st:TAnalysisState):string;
public
// include constructions: TClass2 = class of TClass1;
property IncludeClassLinks:boolean read FIncludeClassLinks write FIncludeClassLinks;
// if true - at use methods SaveAsTree and SaveAsSortList will add debug info ( TClassNode.fullpath and TClassNode.line )
property IncludeDebugInfo:boolean read FIncludeDebugInfo write FIncludeDebugInfo;
// TabChar using in method SaveAsTree
property TabChar:string read FTabChar write FTabChar;
property Count:integer read FCount;
property Classes[Id:Integer]:TClassNode read GetClass write SetClass; default;
function AddClass(AName, AParent: string):integer; overload;
function AddClass(AName, AParent, AFullPath: string; ALine:integer):integer; overload;
function IndexOf(AName:string):integer;
procedure MakeLinks;
procedure MakeTree(tree:TTreeView);
// at use method SaveAsTree, the results file may be load into TTreeView using method LoadFromFile
// ( only if TabChar = #9 )
procedure SaveAsTree(FileName:string);
procedure SaveAsSortList(FileName:string);
// if flag IncludeSubFolders is true , we also find *.pas files in subfolders
procedure GetClassesFromDir(Dir:string; IncludeSubFolders:boolean=false);
procedure Clear;
constructor Create; overload;
destructor Destroy; override;
end;
implementation
{ TClassesTree }
constructor TClassesTree.Create;
begin
IsLinked := false;
FTabChar := #9;
FCount := 0;
FIncludeClassLinks := true;
FIncludeDebugInfo := false;
SetLength(FNodes,1);
FNodes[0].name := '';
FNodes[0].parent := '';
end;
destructor TClassesTree.Destroy;
begin
SetLength(FNodes,0);
FNodes := nil;
inherited;
end;
procedure TClassesTree.Clear;
begin
IsLinked := false;
FCount := 0;
SetLength(FNodes,1);
FNodes[0].name := '';
FNodes[0].parent := '';
end;
function TClassesTree.GetClass(Id: Integer): TClassNode;
begin
if Id in [1..FCount] then Result := FNodes[Id]
else Result := FNodes[0];
end;
procedure TClassesTree.SetClass(Id: integer; Value: TClassNode);
begin
if Id in [1..FCount] then FNodes[Id] := Value;
end;
function TClassesTree.AddClass(AName, AParent: string): integer;
begin
IsLinked := false;
Inc(FCount);
SetLength(FNodes,FCount+1);
FNodes[FCount].name := AName;
FNodes[FCount].parent := AParent;
Result := FCount;
end;
function TClassesTree.AddClass(AName, AParent, AFullPath: string; ALine:integer):integer;
begin
IsLinked := false;
Inc(FCount);
SetLength(FNodes,FCount+1);
FNodes[FCount].name := AName;
FNodes[FCount].parent := AParent;
FNodes[FCount].fullpath := AFullPath;
FNodes[FCount].line := ALine;
Result := FCount;
end;
function TClassesTree.IndexOf(AName: string): integer;
var i:integer;
begin
Result := 0;
AName := LowerCase(AName);
for i:=1 to FCount do
if AName = LowerCase(FNodes[i].name) then
begin
Result := i;
Break;
end;
end;
procedure TClassesTree.DeleteLinks;
var i:integer;
begin
for i:=0 to FCount do
with FNodes[i] do
begin
parentid := -1;
previd := -1;
nextid := -1;
fchildid := -1;
lchildid := -1;
end;
IsLinked := false;
end;
procedure TClassesTree.MakeLinks;
var i,pid:integer;
begin
DeleteLinks;
for i:=1 to FCount do
begin
pid := Self.IndexOf(FNodes[i].parent);
FNodes[i].parentid := pid;
if FNodes[pid].fchildid = -1 then
begin
FNodes[pid].fchildid := i;
FNodes[pid].lchildid := i;
end
else
begin
FNodes[i].previd := FNodes[pid].lchildid;
FNodes[FNodes[pid].lchildid].nextid := i;
FNodes[pid].lchildid := i;
end;
end;
end;
procedure TClassesTree.MakeTree(tree: TTreeView);
var i:integer;
function recadd(id:integer; itemto:TTreeNode):integer;
var i:integer;
begin
i := FNodes[id].fchildid;
while (i<>-1) do i := recadd(i,tree.Items.AddChild(itemto,FNodes[i].name));
Result := FNodes[id].nextid;
end;
begin
if not IsLinked then MakeLinks;
i := FNodes[0].fchildid;
while (i<>-1) do i := recadd(i,tree.Items.Add(nil,FNodes[i].name));
end;
procedure TClassesTree.SaveAsTree(FileName: string);
var i:integer;
function recsave(id:integer; pref:string):integer;
var i:integer;
begin
if FIncludeDebugInfo then Writeln(FTF,pref+FNodes[id].name+' ',FNodes[id].line,' ',FNodes[id].fullpath)
else Writeln(FTF,pref+FNodes[id].name);
i := FNodes[id].fchildid;
while (i<>-1) do i:=recsave(i,pref+FTabChar);
Result := FNodes[id].nextid;
end;
begin
if not IsLinked then MakeLinks;
Assign(FTF,FileName);
Rewrite(FTF);
i := FNodes[0].fchildid;
while (i<>-1) do i:=recsave(i,'');
Close(FTF);
end;
procedure TClassesTree.SaveAsSortList(FileName: string);
var sl:TStringList;
i:integer;
begin
sl := TStringList.Create;
try
if FIncludeDebugInfo then
for i:=1 to FCount do sl.Add(FNodes[i].name+' '+IntToStr(FNodes[i].line)+' '+FNodes[i].fullpath)
else
for i:=1 to FCount do sl.Add(FNodes[i].name);
sl.Sort;
sl.SaveToFile(FileName);
finally
sl.Free;
end;
end;
procedure TClassesTree.SkanDir(Dir:string);
var F:TSearchRec;
begin
if Dir[Length(Dir)] <> '\' then Dir:=Dir+'\';
if FindFirst(Dir+'*.*',faAnyFile,F) = 0 then
repeat
if ((F.Attr and faDirectory) = 0) and ( LowerCase(ExtractFileExt(F.Name)) = '.pas' ) then
begin
SkanFile(Dir+F.Name);
end;
until FindNext(F) <> 0;
FindClose(F);
end;