paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-12-02 19:24:46 +01:00
Code Issues Packages Projects Releases Wiki Activity

codetools: testfpcsrcunitrules: added flag to check a unit

Browse Source 
git-svn-id: trunk@26837 -
This commit is contained in:
mattias 2010-07-26 10:45:26 +00:00
parent 288d85bcae
commit 47a231cc35
2 changed files with 69 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
components/codetools/definetemplates.pas
View File

@ -1667,14 +1667,14 @@ begin
// add or update unitlink
Unit_Name:=ExtractFileNameOnly(Filename);
Node:=Links.FindKey(Pointer(Unit_Name),@CompareUnitNameWithUnitNameLink);
if (DebugUnitName<>'') and (SysUtils.CompareText(Unit_Name,DebugUnitName)=0)
then
debugln(['GatherUnitsInFPCSources Unit_Name=',Unit_Name,' File=',Filename,' Node=',Node<>nil,' Score=',Score]);
if Node<>nil then begin
// duplicate unit
Link:=TUnitNameLink(Node.Data);
if Link.Score<Score then begin
// found a better unit
if (DebugUnitName<>'') and (SysUtils.CompareText(Unit_Name,DebugUnitName)=0)
then
debugln(['GatherUnitsInFPCSources UnitName=',Unit_Name,' File=',Filename,' Score=',Score,' => better than ',Link.Score]);
Link.Unit_Name:=Unit_Name;
Link.Filename:=Filename;
Link.ConflictFilename:='';
@ -1682,6 +1682,9 @@ begin
end else if Link.Score=Score then begin
// unit with same Score => maybe a conflict
// be deterministic and choose the highest
if (DebugUnitName<>'') and (SysUtils.CompareText(Unit_Name,DebugUnitName)=0)
then
debugln(['GatherUnitsInFPCSources UnitName=',Unit_Name,' File=',Filename,' Score=',Score,' => duplicate']);
if CompareStr(Filename,Link.Filename)>0 then begin
if Link.ConflictFilename<>'' then
Link.ConflictFilename:=Link.ConflictFilename+';'+Link.Filename
@ -1694,6 +1697,9 @@ begin
end;
end else begin
// new unit source found => add to list
if (DebugUnitName<>'') and (SysUtils.CompareText(Unit_Name,DebugUnitName)=0)
then
debugln(['GatherUnitsInFPCSources UnitName=',Unit_Name,' File=',Filename,' Score=',Score]);
Link:=TUnitNameLink.Create;
Link.Unit_Name:=Unit_Name;
Link.Filename:=Filename;

69
components/codetools/examples/testfpcsrcunitrules.lpr
View File

@ -38,6 +38,8 @@ type
{ TTestFPCSourceUnitRules }
TTestFPCSourceUnitRules = class(TCustomApplication)
private
FCheckUnitName: string;
protected
procedure DoRun; override;
public
@ -49,6 +51,8 @@ type
procedure WriteDuplicatesInPPUPath(ConfigCache: TFPCTargetConfigCache);
procedure WriteMissingPPUSources(UnitSet: TFPCUnitSetCache);
procedure WriteDuplicateSources(UnitSet: TFPCUnitSetCache);
procedure WriteUnitReport(UnitSet: TFPCUnitSetCache; const AnUnitName: string);
property CheckUnitName: string read FCheckUnitName write FCheckUnitName;
end;
{ TMyApplication }
@ -65,7 +69,7 @@ var
Options: TCodeToolsOptions;
begin
// quick check parameters
ErrorMsg:=CheckOptions('hcTPF','help compiler targetos targetcpu fpcsrcdir');
ErrorMsg:=CheckOptions('hc:T:P:F:u:','help compiler: targetos: targetcpu: fpcsrcdir: checkunit:');
if ErrorMsg<>'' then begin
ShowException(Exception.Create(ErrorMsg));
Terminate;
@ -93,6 +97,7 @@ begin
TargetCPU:=GetOptionValue('P','targetcpu');
FPCSrcDir:=GetOptionValue('F','fpcsrcdir');
FPCSrcDir:=CleanAndExpandDirectory(FPCSrcDir);
CheckUnitName:=GetOptionValue('u','checkunit');
if not FileExistsUTF8(CompilerFilename) then
Error('compiler file not found: '+CompilerFilename,false);
@ -123,6 +128,8 @@ begin
WriteDuplicatesInPPUPath(ConfigCache);
WriteMissingPPUSources(UnitSet);
WriteDuplicateSources(UnitSet);
if CheckUnitName<>'' then
WriteUnitReport(UnitSet,CheckUnitName);
// stop program loop
Terminate;
@ -143,14 +150,24 @@ procedure TTestFPCSourceUnitRules.WriteHelp;
begin
writeln('Usage: ',ExeName,' -h');
writeln;
writeln(' -c <compiler file name>');
writeln(' --compiler=<compiler file name>');
writeln(' -T <target OS>');
writeln(' --targetos=<target OS>');
writeln(' -P <target CPU>');
writeln(' --targetcpu=<target CPU>');
writeln(' -F <FPC source directory>');
writeln(' --fpcsrcdir=<FPC source directory>');
writeln(' -c <compiler file name>, --compiler=<compiler file name>');
writeln(' Default is to use environment variable PP.');
writeln(' If this is not set, search for '+GetDefaultCompilerFilename);
writeln;
writeln(' -T <target OS>, --targetos=<target OS>');
writeln(' Default is to use environment variable FPCTARGET.');
writeln(' If this is not set, use the default of the compiler.');
writeln;
writeln(' -P <target CPU>, --targetcpu=<target CPU>');
writeln(' Default is to use environment variable FPCTARGETCPU.');
writeln(' If this is not set, use the default of the compiler.');
writeln;
writeln(' -F <FPC source directory>, --fpcsrcdir=<FPC source directory>');
writeln(' Default is to use environment variable FPCDIR.');
writeln(' There is no default.');
writeln;
writeln(' -u <unit name>, --checkunit=<unit name>');
writeln(' Write a detailed report about this unit.');
end;
procedure TTestFPCSourceUnitRules.Error(Msg: string; DoWriteHelp: Boolean);
@ -357,6 +374,40 @@ begin
if Cnt>0 then writeln;
end;
procedure TTestFPCSourceUnitRules.WriteUnitReport(UnitSet: TFPCUnitSetCache;
const AnUnitName: string);
var
ConfigCache: TFPCTargetConfigCache;
PPUFile: String;
SourceCache: TFPCSourceCache;
aTree: TStringToStringTree;
SrcRules: TFPCSourceRules;
begin
writeln;
writeln('Unit report for ',AnUnitName);
ConfigCache:=UnitSet.GetConfigCache(false);
// in ppu search path
PPUFile:='';
if ConfigCache.Units<>nil then
PPUFile:=ConfigCache.Units[AnUnitName];
if PPUFile='' then
writeln(' WARNING: ',AnUnitName,' is not in PPU search path')
else if CompareFileExt(PPUFile,'ppu',false)=0 then
writeln(' WARNING: fpc ppu search path has a source and not a ppu for ',AnUnitName,': ',PPUFile)
else
writeln(' in PPU search path: ',PPUFile);
SourceCache:=UnitSet.GetSourceCache(false);
SrcRules:=UnitSet.GetSourceRules(false);
if SourceCache.Files<>nil then begin
aTree:=GatherUnitsInFPCSources(SourceCache.Files,
ConfigCache.RealTargetOS,ConfigCache.RealTargetCPU,nil,
SrcRules,AnUnitName);
aTree.Free;
end;
end;
var
Application: TTestFPCSourceUnitRules;
begin