mirror of
https://gitlab.com/freepascal.org/fpc/pas2js.git
synced 2025-08-18 23:49:02 +02:00
releasecreator: started
This commit is contained in:
mattias
parent
72ff01f697
commit
d484ec70a4
1
tools/releasecreator/.gitignore
vendored
Normal file
1
tools/releasecreator/.gitignore
vendored
Normal file
@ -0,0 +1 @@
|
|||||||
|
Pas2jsReleaseCreator
|
||||||
70
tools/releasecreator/Pas2jsReleaseCreator.lpi
Normal file
70
tools/releasecreator/Pas2jsReleaseCreator.lpi
Normal file
@ -0,0 +1,70 @@
|
|||||||
|
<?xml version="1.0" encoding="UTF-8"?>
|
||||||
|
<CONFIG>
|
||||||
|
<ProjectOptions>
|
||||||
|
<Version Value="12"/>
|
||||||
|
<General>
|
||||||
|
<Flags>
|
||||||
|
<MainUnitHasCreateFormStatements Value="False"/>
|
||||||
|
<MainUnitHasScaledStatement Value="False"/>
|
||||||
|
</Flags>
|
||||||
|
<SessionStorage Value="InProjectDir"/>
|
||||||
|
<Title Value="Pas2js Release Creator"/>
|
||||||
|
<UseAppBundle Value="False"/>
|
||||||
|
<ResourceType Value="res"/>
|
||||||
|
</General>
|
||||||
|
<BuildModes>
|
||||||
|
<Item Name="Default" Default="True"/>
|
||||||
|
</BuildModes>
|
||||||
|
<PublishOptions>
|
||||||
|
<Version Value="2"/>
|
||||||
|
<UseFileFilters Value="True"/>
|
||||||
|
</PublishOptions>
|
||||||
|
<RunParams>
|
||||||
|
<FormatVersion Value="2"/>
|
||||||
|
</RunParams>
|
||||||
|
<RequiredPackages>
|
||||||
|
<Item>
|
||||||
|
<PackageName Value="LazUtils"/>
|
||||||
|
</Item>
|
||||||
|
</RequiredPackages>
|
||||||
|
<Units>
|
||||||
|
<Unit>
|
||||||
|
<Filename Value="Pas2jsReleaseCreator.lpr"/>
|
||||||
|
<IsPartOfProject Value="True"/>
|
||||||
|
</Unit>
|
||||||
|
<Unit>
|
||||||
|
<Filename Value="findwriteln.pas"/>
|
||||||
|
<IsPartOfProject Value="True"/>
|
||||||
|
<UnitName Value="FindWriteln"/>
|
||||||
|
</Unit>
|
||||||
|
</Units>
|
||||||
|
</ProjectOptions>
|
||||||
|
<CompilerOptions>
|
||||||
|
<Version Value="11"/>
|
||||||
|
<Target>
|
||||||
|
<Filename Value="Pas2jsReleaseCreator"/>
|
||||||
|
</Target>
|
||||||
|
<SearchPaths>
|
||||||
|
<IncludeFiles Value="$(ProjOutDir)"/>
|
||||||
|
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
|
||||||
|
</SearchPaths>
|
||||||
|
<Linking>
|
||||||
|
<Debugging>
|
||||||
|
<DebugInfoType Value="dsDwarf2"/>
|
||||||
|
</Debugging>
|
||||||
|
</Linking>
|
||||||
|
</CompilerOptions>
|
||||||
|
<Debugging>
|
||||||
|
<Exceptions>
|
||||||
|
<Item>
|
||||||
|
<Name Value="EAbort"/>
|
||||||
|
</Item>
|
||||||
|
<Item>
|
||||||
|
<Name Value="ECodetoolError"/>
|
||||||
|
</Item>
|
||||||
|
<Item>
|
||||||
|
<Name Value="EFOpenError"/>
|
||||||
|
</Item>
|
||||||
|
</Exceptions>
|
||||||
|
</Debugging>
|
||||||
|
</CONFIG>
|
||||||
313
tools/releasecreator/Pas2jsReleaseCreator.lpr
Normal file
313
tools/releasecreator/Pas2jsReleaseCreator.lpr
Normal file
@ -0,0 +1,313 @@
|
|||||||
|
program Pas2jsReleaseCreator;
|
||||||
|
|
||||||
|
{$mode objfpc}{$H+}
|
||||||
|
|
||||||
|
uses
|
||||||
|
{$IFDEF UNIX}
|
||||||
|
cthreads,
|
||||||
|
{$ENDIF}
|
||||||
|
LazUTF8, Classes, SysUtils, CustApp, IniFiles, LazFileUtils, FileUtil,
|
||||||
|
FindWriteln;
|
||||||
|
|
||||||
|
const
|
||||||
|
DefaultCfgFilename = 'pas2jsrelease.ini';
|
||||||
|
|
||||||
|
type
|
||||||
|
TGetDefaultEvent = function(): string of object;
|
||||||
|
|
||||||
|
{ TPas2jsReleaseCreator }
|
||||||
|
|
||||||
|
TPas2jsReleaseCreator = class(TCustomApplication)
|
||||||
|
protected
|
||||||
|
procedure DoLog(EventType: TEventType; const Msg: String); override;
|
||||||
|
procedure DoRun; override;
|
||||||
|
procedure Err(const Msg: string);
|
||||||
|
public
|
||||||
|
CfgFilename: string;
|
||||||
|
Ini: TIniFile;
|
||||||
|
SourceDir: string; // cloned git release
|
||||||
|
BuildDir: string;
|
||||||
|
LazBuildFilename: string;
|
||||||
|
Verbosity: integer;
|
||||||
|
Pas2jsVersion: string;
|
||||||
|
constructor Create(TheOwner: TComponent); override;
|
||||||
|
destructor Destroy; override;
|
||||||
|
procedure WriteHelp; virtual;
|
||||||
|
procedure ReadVersion;
|
||||||
|
procedure CheckForgottenWriteln;
|
||||||
|
function GetDefaultCfgFilename: string;
|
||||||
|
function GetDefaultBuildDir: string;
|
||||||
|
function GetDefaultLazBuild: string;
|
||||||
|
function GetOption_String(ShortOption: char; const LongOption: string): string;
|
||||||
|
function GetOption_Directory(ShortOption: char; const LongOption: string; const GetDefaultFunc: TGetDefaultEvent): string;
|
||||||
|
function GetOption_Executable(ShortOption: char; const LongOption: string; const GetDefaultFunc: TGetDefaultEvent): string;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TPas2jsReleaseCreator }
|
||||||
|
|
||||||
|
procedure TPas2jsReleaseCreator.DoLog(EventType: TEventType; const Msg: String);
|
||||||
|
begin
|
||||||
|
case EventType of
|
||||||
|
etInfo: write('Info: ');
|
||||||
|
etWarning: write('Warning: ');
|
||||||
|
etError: write('Error: ');
|
||||||
|
etDebug: write('Debug: ');
|
||||||
|
else
|
||||||
|
write('Custom: ');
|
||||||
|
end;
|
||||||
|
writeln(Msg);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TPas2jsReleaseCreator.DoRun;
|
||||||
|
var
|
||||||
|
ErrorMsg: String;
|
||||||
|
begin
|
||||||
|
// quick check parameters
|
||||||
|
ErrorMsg:=CheckOptions('hb:c:s:l:qvx', ['help', 'config:', 'lazbuild:',
|
||||||
|
'builddir:', 'sourcedir:', 'quiet', 'verbose', 'execute']);
|
||||||
|
if ErrorMsg<>'' then
|
||||||
|
Err(ErrorMsg);
|
||||||
|
|
||||||
|
// parse basic parameters
|
||||||
|
if HasOption('h', 'help') then begin
|
||||||
|
WriteHelp;
|
||||||
|
Terminate;
|
||||||
|
Exit;
|
||||||
|
end;
|
||||||
|
|
||||||
|
if HasOption('q','quiet') then
|
||||||
|
dec(Verbosity);
|
||||||
|
if HasOption('v','verbose') then
|
||||||
|
inc(Verbosity);
|
||||||
|
|
||||||
|
// read config file
|
||||||
|
if HasOption('c','config') then begin
|
||||||
|
CfgFilename:=ExpandFileName(GetOptionValue('c','config'));
|
||||||
|
if not FileExists(CfgFilename) then
|
||||||
|
Err('Config file not found: "'+CfgFilename+'"');
|
||||||
|
end else begin
|
||||||
|
CfgFilename:=GetDefaultCfgFilename;
|
||||||
|
end;
|
||||||
|
if FileExists(CfgFilename) then begin
|
||||||
|
if Verbosity>=0 then
|
||||||
|
Log(etInfo,'Reading config file "'+CfgFilename+'" ...');
|
||||||
|
Ini:=TIniFile.Create(CfgFilename);
|
||||||
|
end;
|
||||||
|
|
||||||
|
BuildDir:=GetOption_Directory('b','builddir',@GetDefaultBuildDir);
|
||||||
|
LazBuildFilename:=GetOption_Executable('l','lazbuild',@GetDefaultLazBuild);
|
||||||
|
SourceDir:=GetOption_Directory('s','sourcedir',nil);
|
||||||
|
if SourceDir='' then
|
||||||
|
Err('missing source directory');
|
||||||
|
|
||||||
|
// write options
|
||||||
|
if Verbosity>=0 then begin
|
||||||
|
Log(etInfo,'BuildDir: "'+BuildDir+'"');
|
||||||
|
Log(etInfo,'LazBuild: "'+LazBuildFilename+'"');
|
||||||
|
Log(etInfo,'SourceDir: "'+SourceDir+'"');
|
||||||
|
end;
|
||||||
|
|
||||||
|
if not HasOption('x','execute') then
|
||||||
|
Log(etInfo,'Simulating...');
|
||||||
|
|
||||||
|
// preflight checks
|
||||||
|
if not DirectoryExists(BuildDir) then
|
||||||
|
Err('BuildDir missing: "'+BuildDir+'"');
|
||||||
|
if not DirectoryExists(SourceDir) then
|
||||||
|
Err('SourceDir missing: "'+SourceDir+'"');
|
||||||
|
if not FileExists(LazBuildFilename) then
|
||||||
|
Err('LazBuild missing: "'+LazBuildFilename+'"');
|
||||||
|
if not FileIsExecutable(LazBuildFilename) then
|
||||||
|
Err('LazBuild not executable: "'+LazBuildFilename+'"');
|
||||||
|
|
||||||
|
ReadVersion;
|
||||||
|
CheckForgottenWriteln;
|
||||||
|
|
||||||
|
// stop program loop
|
||||||
|
Terminate;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TPas2jsReleaseCreator.Err(const Msg: string);
|
||||||
|
begin
|
||||||
|
Log(etError,Msg);
|
||||||
|
Halt(1);
|
||||||
|
end;
|
||||||
|
|
||||||
|
constructor TPas2jsReleaseCreator.Create(TheOwner: TComponent);
|
||||||
|
begin
|
||||||
|
inherited Create(TheOwner);
|
||||||
|
StopOnException:=True;
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TPas2jsReleaseCreator.Destroy;
|
||||||
|
begin
|
||||||
|
FreeAndNil(Ini);
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TPas2jsReleaseCreator.WriteHelp;
|
||||||
|
begin
|
||||||
|
writeln('Usage: ', ExeName, ' -h');
|
||||||
|
writeln;
|
||||||
|
writeln('-h, --help: Write this help and exit');
|
||||||
|
writeln('-q, --quiet: Less verbose');
|
||||||
|
writeln('-v, --verbose: More verbose');
|
||||||
|
writeln('-b <filename>, --builddir=<filename>: Output directory where to build the zip.');
|
||||||
|
writeln(' Default: '+GetDefaultBuildDir);
|
||||||
|
writeln('-c <filename>, --config=<filename>: Path of ini file with a Main section.');
|
||||||
|
writeln(' Default: '+GetDefaultCfgFilename);
|
||||||
|
writeln('-l <filename>, --lazbuild=<filename>: Path of lazbuild executable.');
|
||||||
|
writeln(' Default: '+GetDefaultLazBuild);
|
||||||
|
writeln('-s <filename>, --sourcedir=<filename>: git directory of the pas2js release');
|
||||||
|
writeln('-x, --execute: Do not simulate, execute the commands');
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TPas2jsReleaseCreator.ReadVersion;
|
||||||
|
|
||||||
|
function CheckConstInt(const Line, Identifier: string; var aValue: integer): boolean;
|
||||||
|
var
|
||||||
|
s: String;
|
||||||
|
p, StartP: SizeInt;
|
||||||
|
begin
|
||||||
|
Result:=false;
|
||||||
|
s:=' '+Identifier+' = ';
|
||||||
|
if not SameText(LeftStr(Line,length(s)),s) then exit;
|
||||||
|
p:=length(s)+1;
|
||||||
|
StartP:=p;
|
||||||
|
aValue:=0;
|
||||||
|
while (p<=length(Line)) and (Line[p] in ['0'..'9']) do begin
|
||||||
|
aValue:=aValue*10+ord(Line[p])-ord('0');
|
||||||
|
inc(p);
|
||||||
|
end;
|
||||||
|
Result:=p>StartP;
|
||||||
|
end;
|
||||||
|
|
||||||
|
type
|
||||||
|
TVersionPart = (vMajor,vMinor,vRelease);
|
||||||
|
const
|
||||||
|
PartNames: array[TVersionPart] of string = ('VersionMajor','VersionMinor','VersionRelease');
|
||||||
|
var
|
||||||
|
Filename, Line: String;
|
||||||
|
sl: TStringList;
|
||||||
|
i: Integer;
|
||||||
|
Parts: array[TVersionPart] of integer;
|
||||||
|
PartFound: array[TVersionPart] of boolean;
|
||||||
|
p: TVersionPart;
|
||||||
|
begin
|
||||||
|
Filename:=SourceDir+'compiler'+PathDelim+'packages'+PathDelim+'pastojs'+PathDelim+'src'+PathDelim+'pas2jscompiler.pp';
|
||||||
|
if Verbosity>0 then
|
||||||
|
Log(etInfo,'Reading version from "'+Filename+'" ...');
|
||||||
|
if not FileExists(Filename) then
|
||||||
|
Err('Missing source file: "'+Filename+'"');
|
||||||
|
sl:=TStringList.Create;
|
||||||
|
try
|
||||||
|
sl.LoadFromFile(Filename);
|
||||||
|
for p in TVersionPart do begin
|
||||||
|
Parts[p]:=0;
|
||||||
|
PartFound[p]:=false;
|
||||||
|
end;
|
||||||
|
for i:=0 to sl.Count-1 do begin
|
||||||
|
Line:=sl[i];
|
||||||
|
for p in TVersionPart do
|
||||||
|
if not PartFound[p] then
|
||||||
|
PartFound[p]:=CheckConstInt(Line,PartNames[p],Parts[p]);
|
||||||
|
if PartFound[High(TVersionPart)] then begin
|
||||||
|
if Verbosity>0 then
|
||||||
|
Log(etInfo,'Found const '+PartNames[High(TVersionPart)]+' = '+IntToStr(Parts[High(TVersionPart)]));
|
||||||
|
break;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
for p in TVersionPart do
|
||||||
|
if not PartFound[p] then
|
||||||
|
Err('Missing '+PartNames[p]+' in "'+Filename+'"');
|
||||||
|
|
||||||
|
Pas2jsVersion:=IntToStr(Parts[vMajor])+'.'+IntToStr(Parts[vMinor])+'.'+IntToStr(Parts[vRelease]);
|
||||||
|
if Verbosity>=0 then
|
||||||
|
Log(etInfo,'Pas2js version is '+Pas2jsVersion);
|
||||||
|
finally
|
||||||
|
sl.Free;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TPas2jsReleaseCreator.CheckForgottenWriteln;
|
||||||
|
|
||||||
|
procedure Check(const SrcDir: string);
|
||||||
|
begin
|
||||||
|
if not DirectoryExists(SrcDir) then
|
||||||
|
Err('Missing dource directory: "'+SrcDir+'"');
|
||||||
|
if Verbosity>=0 then
|
||||||
|
Log(etInfo,'Checking for forgotten writeln: '+SrcDir+' ...');
|
||||||
|
FindWritelnInDirectory(SrcDir,false,@DoLog);
|
||||||
|
end;
|
||||||
|
|
||||||
|
begin
|
||||||
|
Check(SourceDir+'compiler'+PathDelim+'packages'+PathDelim+'fcl-js'+PathDelim+'src');
|
||||||
|
Check(SourceDir+'compiler'+PathDelim+'packages'+PathDelim+'fcl-json'+PathDelim+'src');
|
||||||
|
Check(SourceDir+'compiler'+PathDelim+'packages'+PathDelim+'fcl-passrc'+PathDelim+'src');
|
||||||
|
Check(SourceDir+'compiler'+PathDelim+'packages'+PathDelim+'pastojs'+PathDelim+'src');
|
||||||
|
Check(SourceDir+'compiler'+PathDelim+'utils'+PathDelim+'pas2js');
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TPas2jsReleaseCreator.GetDefaultCfgFilename: string;
|
||||||
|
begin
|
||||||
|
Result:=ExpandFileName(DefaultCfgFilename);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TPas2jsReleaseCreator.GetDefaultBuildDir: string;
|
||||||
|
begin
|
||||||
|
Result:=AppendPathDelim(ResolveDots(GetTempDir(false)));
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TPas2jsReleaseCreator.GetDefaultLazBuild: string;
|
||||||
|
begin
|
||||||
|
Result:='lazbuild';
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TPas2jsReleaseCreator.GetOption_String(ShortOption: char;
|
||||||
|
const LongOption: string): string;
|
||||||
|
begin
|
||||||
|
if HasOption(ShortOption,LongOption) then begin
|
||||||
|
Result:=GetOptionValue(ShortOption,LongOption);
|
||||||
|
exit;
|
||||||
|
end;
|
||||||
|
if Ini<>nil then begin
|
||||||
|
Result:=Ini.ReadString('Main',LongOption,'');
|
||||||
|
exit;
|
||||||
|
end;
|
||||||
|
Result:='';
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TPas2jsReleaseCreator.GetOption_Directory(ShortOption: char;
|
||||||
|
const LongOption: string; const GetDefaultFunc: TGetDefaultEvent): string;
|
||||||
|
begin
|
||||||
|
Result:=GetOption_String(ShortOption,LongOption);
|
||||||
|
if (Result='') and Assigned(GetDefaultFunc) then
|
||||||
|
Result:=GetDefaultFunc();
|
||||||
|
if Result<>'' then
|
||||||
|
Result:=AppendPathDelim(ExpandFileName(Result));
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TPas2jsReleaseCreator.GetOption_Executable(ShortOption: char;
|
||||||
|
const LongOption: string; const GetDefaultFunc: TGetDefaultEvent): string;
|
||||||
|
begin
|
||||||
|
Result:=GetOption_String(ShortOption,LongOption);
|
||||||
|
if Result='' then
|
||||||
|
Result:=GetDefaultFunc();
|
||||||
|
if Result='' then exit;
|
||||||
|
if FilenameIsAbsolute(Result) then exit;
|
||||||
|
if ExtractFilePath(Result)<>'' then
|
||||||
|
Result:=ExpandFileName(Result)
|
||||||
|
else
|
||||||
|
Result:=FindDefaultExecutablePath(Result);
|
||||||
|
end;
|
||||||
|
|
||||||
|
var
|
||||||
|
Application: TPas2jsReleaseCreator;
|
||||||
|
begin
|
||||||
|
Application:=TPas2jsReleaseCreator.Create(nil);
|
||||||
|
Application.Title:='Pas2js Release Creator';
|
||||||
|
Application.Run;
|
||||||
|
Application.Free;
|
||||||
|
end.
|
||||||
|
|
||||||
273
tools/releasecreator/findwriteln.pas
Normal file
273
tools/releasecreator/findwriteln.pas
Normal file
@ -0,0 +1,273 @@
|
|||||||
|
unit FindWriteln;
|
||||||
|
|
||||||
|
{$mode objfpc}{$H+}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes, SysUtils;
|
||||||
|
|
||||||
|
type
|
||||||
|
TFindWritelnLog = procedure(EventType : TEventType; const Msg: string) of object;
|
||||||
|
|
||||||
|
function FindWritelnInDirectory(Dir: string; Recurse: boolean; const Log: TFindWritelnLog): integer;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
function ReadNextToken(const Src: string; var SrcP: PChar; var Line: integer): string;
|
||||||
|
var
|
||||||
|
p, TokenStart: PChar;
|
||||||
|
begin
|
||||||
|
p:=SrcP;
|
||||||
|
while p^ in [' ',#9] do inc(p);
|
||||||
|
repeat
|
||||||
|
case p^ of
|
||||||
|
#0:
|
||||||
|
if p-PChar(Src)=length(Src) then begin
|
||||||
|
SrcP:=p;
|
||||||
|
exit('');
|
||||||
|
end
|
||||||
|
else
|
||||||
|
inc(p);
|
||||||
|
#10,#13:
|
||||||
|
begin
|
||||||
|
inc(Line);
|
||||||
|
if (p[1] in [#10,#13]) and (p^<>p[1]) then
|
||||||
|
inc(p,2)
|
||||||
|
else
|
||||||
|
inc(p);
|
||||||
|
end;
|
||||||
|
' ',#9:
|
||||||
|
inc(p);
|
||||||
|
else
|
||||||
|
break;
|
||||||
|
end;
|
||||||
|
until false;
|
||||||
|
TokenStart:=p;
|
||||||
|
case p^ of
|
||||||
|
'a'..'z','A'..'Z','_':
|
||||||
|
while p^ in ['a'..'z','A'..'Z','_','0'..'9'] do inc(p);
|
||||||
|
'0'..'9':
|
||||||
|
while p^ in ['0'..'9'] do inc(p);
|
||||||
|
'''':
|
||||||
|
begin
|
||||||
|
inc(p);
|
||||||
|
repeat
|
||||||
|
case p^ of
|
||||||
|
#0,#10,#13: break;
|
||||||
|
'''':
|
||||||
|
begin
|
||||||
|
inc(p);
|
||||||
|
break;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
inc(p);
|
||||||
|
until false;
|
||||||
|
end;
|
||||||
|
'/':
|
||||||
|
if p[1]='/' then begin
|
||||||
|
inc(p,2);
|
||||||
|
while not (p^ in [#0,#10,#13]) do inc(p);
|
||||||
|
end else
|
||||||
|
inc(p);
|
||||||
|
'{':
|
||||||
|
begin
|
||||||
|
inc(p);
|
||||||
|
repeat
|
||||||
|
case p^ of
|
||||||
|
#0:
|
||||||
|
if p-PChar(Src)=length(Src) then begin
|
||||||
|
SrcP:=p;
|
||||||
|
exit('');
|
||||||
|
end;
|
||||||
|
#10,#13:
|
||||||
|
begin
|
||||||
|
inc(Line);
|
||||||
|
if (p[1] in [#10,#13]) and (p^<>p[1]) then
|
||||||
|
inc(p);
|
||||||
|
end;
|
||||||
|
'}': break;
|
||||||
|
end;
|
||||||
|
inc(p);
|
||||||
|
until false;
|
||||||
|
inc(p);
|
||||||
|
end;
|
||||||
|
'(':
|
||||||
|
if p[1]='*' then begin
|
||||||
|
inc(p,2);
|
||||||
|
repeat
|
||||||
|
case p^ of
|
||||||
|
#0:
|
||||||
|
if p-PChar(Src)=length(Src) then begin
|
||||||
|
SrcP:=p;
|
||||||
|
exit('');
|
||||||
|
end;
|
||||||
|
#10,#13:
|
||||||
|
begin
|
||||||
|
inc(Line);
|
||||||
|
if (p[1] in [#10,#13]) and (p^<>p[1]) then
|
||||||
|
inc(p);
|
||||||
|
end;
|
||||||
|
'*':
|
||||||
|
if p[1]=')' then break;
|
||||||
|
end;
|
||||||
|
inc(p);
|
||||||
|
until false;
|
||||||
|
inc(p,2);
|
||||||
|
end else
|
||||||
|
inc(p);
|
||||||
|
else
|
||||||
|
inc(p);
|
||||||
|
end;
|
||||||
|
SetLength(Result,p-TokenStart);
|
||||||
|
Move(TokenStart^,Result[1],length(Result));
|
||||||
|
SrcP:=P;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure GetLineStartEndAtPosition(const Source:string; Position:integer;
|
||||||
|
out LineStart,LineEnd:integer);
|
||||||
|
begin
|
||||||
|
if Position<1 then begin
|
||||||
|
LineStart:=0;
|
||||||
|
LineEnd:=0;
|
||||||
|
exit;
|
||||||
|
end;
|
||||||
|
if Position>length(Source)+1 then begin
|
||||||
|
LineStart:=length(Source)+1;
|
||||||
|
LineEnd:=LineStart;
|
||||||
|
exit;
|
||||||
|
end;
|
||||||
|
LineStart:=Position;
|
||||||
|
while (LineStart>1) and (not (Source[LineStart-1] in [#10,#13])) do
|
||||||
|
dec(LineStart);
|
||||||
|
LineEnd:=Position;
|
||||||
|
while (LineEnd<=length(Source)) and (not (Source[LineEnd] in [#10,#13])) do
|
||||||
|
inc(LineEnd);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetLineInSrc(const Source: string; Position: integer): string;
|
||||||
|
var
|
||||||
|
LineStart, LineEnd: integer;
|
||||||
|
begin
|
||||||
|
GetLineStartEndAtPosition(Source,Position,LineStart,LineEnd);
|
||||||
|
Result:=copy(Source,LineStart,LineEnd-LineStart);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function CheckFile(Filename: string; const Log: TFindWritelnLog): integer;
|
||||||
|
var
|
||||||
|
Token, LastToken, Src: String;
|
||||||
|
ms: TMemoryStream;
|
||||||
|
p: PChar;
|
||||||
|
Line, LastIFDEF, AllowWriteln: Integer;
|
||||||
|
Lvl, VerboseLvl: integer;
|
||||||
|
begin
|
||||||
|
Result:=0;
|
||||||
|
ms:=TMemoryStream.Create;
|
||||||
|
try
|
||||||
|
ms.LoadFromFile(Filename);
|
||||||
|
if ms.Size=0 then exit;
|
||||||
|
Src:='';
|
||||||
|
SetLength(Src,ms.Size);
|
||||||
|
Move(ms.Memory^,Src[1],length(Src));
|
||||||
|
p:=PChar(Src);
|
||||||
|
AllowWriteln:=0;
|
||||||
|
Line:=1;
|
||||||
|
LastIFDEF:=-1;
|
||||||
|
Token:='';
|
||||||
|
Lvl:=0;
|
||||||
|
VerboseLvl:=-1;
|
||||||
|
repeat
|
||||||
|
LastToken:=Token;
|
||||||
|
Token:=ReadNextToken(Src,p,Line);
|
||||||
|
if Token='' then break;
|
||||||
|
if Token[1]='{' then begin
|
||||||
|
Token:=lowercase(Token);
|
||||||
|
if Token='{allowwriteln}' then begin
|
||||||
|
if AllowWriteln>0 then begin
|
||||||
|
inc(Result);
|
||||||
|
Log(etError,Filename+'('+IntToStr(Line)+'): writeln already allowed at '+IntToStr(AllowWriteln)+': '+GetLineInSrc(Src,p-PChar(Src)+1));
|
||||||
|
end;
|
||||||
|
AllowWriteln:=Line;
|
||||||
|
end
|
||||||
|
else if Token='{allowwriteln-}' then begin
|
||||||
|
if AllowWriteln<1 then begin
|
||||||
|
inc(Result);
|
||||||
|
Log(etError,Filename+'('+IntToStr(Line)+'): writeln was not allowed: '+GetLineInSrc(Src,p-PChar(Src)+1));
|
||||||
|
end;
|
||||||
|
AllowWriteln:=0;
|
||||||
|
end
|
||||||
|
else if SameText(LeftStr(Token,4),'{$if') then begin
|
||||||
|
inc(Lvl);
|
||||||
|
LastIFDEF:=Line;
|
||||||
|
if SameText(LeftStr(Token,15),'{$ifdef Verbose') then begin
|
||||||
|
if VerboseLvl<0 then VerboseLvl:=Lvl;
|
||||||
|
end;
|
||||||
|
end else if SameText(LeftStr(Token,6),'{$else') then begin
|
||||||
|
if Lvl=VerboseLvl then
|
||||||
|
VerboseLvl:=-1;
|
||||||
|
LastIFDEF:=Line;
|
||||||
|
end else if SameText(LeftStr(Token,7),'{$endif') then begin
|
||||||
|
if Lvl=VerboseLvl then begin
|
||||||
|
VerboseLvl:=-1;
|
||||||
|
end;
|
||||||
|
dec(Lvl);
|
||||||
|
end;
|
||||||
|
end
|
||||||
|
else begin
|
||||||
|
if (CompareText(Token,'str')=0) and (LastToken<>'.') then begin
|
||||||
|
if byte(Line-LastIFDEF) in [0,1] then begin
|
||||||
|
// ignore writeln just behind IFDEF
|
||||||
|
LastIFDEF:=Line;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
if (CompareText(Token,'writeln')=0)
|
||||||
|
and (LastToken<>'.')
|
||||||
|
and (LastToken<>':=')
|
||||||
|
and (LastToken<>'=')
|
||||||
|
and (LastToken<>'+')
|
||||||
|
and not SameText(LastToken,'function')
|
||||||
|
and not SameText(LastToken,'procedure') then begin
|
||||||
|
if Lvl=VerboseLvl then begin
|
||||||
|
// ignore writeln inside $IFDEF VerboseX
|
||||||
|
end else if byte(Line-LastIFDEF) in [0,1] then begin
|
||||||
|
// ignore writeln just behind IFDEF
|
||||||
|
LastIFDEF:=Line;
|
||||||
|
end else if AllowWriteln<1 then begin
|
||||||
|
inc(Result);
|
||||||
|
Log(etError,Filename+'('+IntToStr(Line)+'): '+GetLineInSrc(Src,p-PChar(Src)+1));
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
until false;
|
||||||
|
finally
|
||||||
|
ms.Free;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function FindWritelnInDirectory(Dir: string; Recurse: boolean; const Log: TFindWritelnLog): integer;
|
||||||
|
var
|
||||||
|
Info: TRawByteSearchRec;
|
||||||
|
Ext: String;
|
||||||
|
begin
|
||||||
|
Result:=0;
|
||||||
|
Dir:=IncludeTrailingPathDelimiter(Dir);
|
||||||
|
if FindFirst(Dir+AllFilesMask,faAnyFile,Info)=0 then begin
|
||||||
|
repeat
|
||||||
|
if (Info.Name='') or (Info.Name='.') or (Info.Name='..') then continue;
|
||||||
|
if (Info.Attr and faDirectory)>0 then begin
|
||||||
|
if Recurse then
|
||||||
|
Result+=FindWritelnInDirectory(Dir+Info.Name,true,Log);
|
||||||
|
end
|
||||||
|
else begin
|
||||||
|
Ext:=lowercase(ExtractFileExt(Info.Name));
|
||||||
|
case Ext of
|
||||||
|
'.p','.pp','.pas','.inc': Result+=CheckFile(Dir+Info.Name,Log);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
until FindNext(Info)<>0;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
||||||
|
|
||||||
|
|
||||||
Loading…
Reference in New Issue
Block a user