paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-11-03 16:59:41 +01:00
Code Issues Packages Projects Releases Wiki Activity

codetools: started test tool for fpc src rules

Browse Source 
git-svn-id: trunk@26813 -
This commit is contained in:
mattias 2010-07-24 16:07:31 +00:00
parent 62bc8849e3
commit 8100a2780c
3 changed files with 259 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -511,6 +511,8 @@ components/codetools/examples/setincludepath.lpi svneol=native#text/plain
components/codetools/examples/setincludepath.pas svneol=native#text/plain
components/codetools/examples/testexpreval.lpi svneol=native#text/plain
components/codetools/examples/testexpreval.pas svneol=native#text/plain
components/codetools/examples/testfpcsrcunitrules.lpi svneol=native#text/plain
components/codetools/examples/testfpcsrcunitrules.lpr svneol=native#text/plain
components/codetools/examples/testscompleteblock/beginwithoutindent1.inc svneol=native#text/plain
components/codetools/examples/testscompleteblock/beginwithoutindent1_result1.inc svneol=native#text/plain
components/codetools/examples/testscompleteblock/beginwithoutindent1_result2.inc svneol=native#text/plain

80
components/codetools/examples/testfpcsrcunitrules.lpi Normal file
View File

@ -0,0 +1,80 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<Version Value="8"/>
<General>
<Flags>
<MainUnitHasCreateFormStatements Value="False"/>
<MainUnitHasTitleStatement Value="False"/>
<UseDefaultCompilerOptions Value="True"/>
</Flags>
<SessionStorage Value="InIDEConfig"/>
<MainUnit Value="0"/>
<TargetFileExt Value=""/>
<UseAppBundle Value="False"/>
<ResourceType Value="res"/>
<Icon Value="0"/>
</General>
<i18n>
<EnableI18N LFM="False"/>
</i18n>
<VersionInfo>
<Language Value=""/>
<CharSet Value=""/>
<StringTable Comments="" CompanyName="" FileDescription="" FileVersion="" InternalName="" LegalCopyright="" LegalTrademarks="" OriginalFilename="" ProductName="" ProductVersion=""/>
</VersionInfo>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="/usr/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<RequiredPackages Count="1">
<Item1>
<PackageName Value="CodeTools"/>
</Item1>
</RequiredPackages>
<Units Count="1">
<Unit0>
<Filename Value="testfpcsrcunitrules.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="testfpcsrcunitrules"/>
</Unit0>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="9"/>
<Target>
<Filename Value="testfpcsrcunitrules"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)/"/>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Other>
<CompilerMessages>
<UseMsgFile Value="True"/>
</CompilerMessages>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

177
components/codetools/examples/testfpcsrcunitrules.lpr Normal file
View File

@ -0,0 +1,177 @@
{
***************************************************************************
* *
* This source is free software; you can redistribute it and/or modify *
* it under the terms of the GNU General Public License as published by *
* the Free Software Foundation; either version 2 of the License, or *
* (at your option) any later version. *
* *
* This code 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. *
* *
* A copy of the GNU General Public License is available on the World *
* Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
* obtain it by writing to the Free Software Foundation, *
* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *
* *
***************************************************************************
Author: Mattias Gaertner
Abstract:
Write all duplicate ppu files and all duplicate unit source files.
}
program TestFPCSrcUnitRules;
{$mode objfpc}{$H+}
uses
Classes, SysUtils, CustApp, CodeToolManager, DefineTemplates, FileProcs;
const
ConfigFilename = 'codetools.config';
type
{ TTestFPCSourceUnitRules }
TTestFPCSourceUnitRules = class(TCustomApplication)
protected
procedure DoRun; override;
public
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
procedure WriteHelp; virtual;
procedure Error(Msg: string; DoWriteHelp: Boolean);
procedure WriteCompilerInfo(ConfigCache: TFPCTargetConfigCache);
end;
{ TMyApplication }
procedure TTestFPCSourceUnitRules.DoRun;
var
ErrorMsg: String;
CompilerFilename: String;
TargetOS: String;
TargetCPU: String;
FPCSrcDir: String;
UnitSet: TFPCUnitSetCache;
ConfigCache: TFPCTargetConfigCache;
SourceCache: TFPCSourceCache;
begin
// quick check parameters
ErrorMsg:=CheckOptions('hcTPF','help compiler targetos targetcpu fpcsrcdir');
if ErrorMsg<>'' then begin
ShowException(Exception.Create(ErrorMsg));
Terminate;
Exit;
end;
// parse parameters
if HasOption('h','help') then begin
WriteHelp;
Halt;
end;
if not HasOption('F','fpcsrcdir') then
Error('fpc source directory missing',true);
if HasOption('c','compiler') then begin
CompilerFilename:=GetOptionValue('c','compiler');
CompilerFilename:=CleanAndExpandFilename(CompilerFilename);
end else begin
CompilerFilename:=GetDefaultCompilerFilename;
CompilerFilename:=SearchFileInPath(CompilerFilename,'',
GetEnvironmentVariable('PATH'), PathSeparator,ctsfcDefault);
end;
TargetOS:=GetOptionValue('T','targetos');
TargetCPU:=GetOptionValue('P','targetcpu');
FPCSrcDir:=GetOptionValue('F','fpcsrcdir');
FPCSrcDir:=CleanAndExpandDirectory(FPCSrcDir);
if not FileExistsUTF8(CompilerFilename) then
Error('compiler file not found: '+CompilerFilename,false);
if not DirPathExists(FPCSrcDir) then
Error('FPC source directory not found: '+FPCSrcDir,false);
CodeToolBoss.SimpleInit(ConfigFilename);
UnitSet:=CodeToolBoss.FPCDefinesCache.FindUnitSet(CompilerFilename,
TargetOS,TargetCPU,'',FPCSrcDir,true);
ConfigCache:=UnitSet.GetConfigCache(true);
WriteCompilerInfo(ConfigCache);
SourceCache:=UnitSet.GetSourceCache(true);
// stop program loop
Terminate;
end;
constructor TTestFPCSourceUnitRules.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
StopOnException:=True;
end;
destructor TTestFPCSourceUnitRules.Destroy;
begin
inherited Destroy;
end;
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>');
end;
procedure TTestFPCSourceUnitRules.Error(Msg: string; DoWriteHelp: Boolean);
begin
writeln('Error: ',Msg);
if DoWriteHelp then begin
writeln;
WriteHelp;
end;
Halt;
end;
procedure TTestFPCSourceUnitRules.WriteCompilerInfo(
ConfigCache: TFPCTargetConfigCache);
var
i: Integer;
CfgFile: TFPCConfigFileState;
begin
writeln('Compiler=',ConfigCache.Compiler);
writeln('TargetOS=',ConfigCache.TargetOS);
writeln('TargetCPU=',ConfigCache.TargetCPU);
writeln('Options=',ConfigCache.CompilerOptions);
writeln('RealCompiler=',ConfigCache.RealCompiler);
writeln('RealTargetOS=',ConfigCache.RealTargetOS);
writeln('RealTargetCPU=',ConfigCache.RealTargetCPU);
if ConfigCache.ConfigFiles<>nil then begin
for i:=0 to ConfigCache.ConfigFiles.Count-1 do begin
CfgFile:=ConfigCache.ConfigFiles[i];
writeln('Config=',CfgFile.Filename,' Exists=',CfgFile.FileExists);
end;
end;
end;
var
Application: TTestFPCSourceUnitRules;
begin
Application:=TTestFPCSourceUnitRules.Create(nil);
Application.Title:='TestFPCSrcUnitRules';
Application.Run;
Application.Free;
end.