mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-05 17:47:58 +02:00
507 lines
12 KiB
ObjectPascal
507 lines
12 KiB
ObjectPascal
{ ---------------------------------------------------------------------
|
|
utility functions, shared by several programs of the test suite
|
|
---------------------------------------------------------------------}
|
|
|
|
{$mode objfpc}
|
|
{$modeswitch advancedrecords}
|
|
{$h+}
|
|
|
|
unit tsutils;
|
|
|
|
Interface
|
|
|
|
uses
|
|
classes, sysutils, tstypes;
|
|
|
|
Type
|
|
TOnVerboseEvent = procedure(lvl:TVerboseLevel; const aMsg : String) of object;
|
|
|
|
var
|
|
OnVerbose : TOnVerboseEvent = Nil;
|
|
IsCGI : boolean = false;
|
|
DoVerbose : boolean = false;
|
|
DoSQL : boolean = false;
|
|
MaxLogSize : LongInt = 50000;
|
|
|
|
|
|
procedure TrimB(var s:string);
|
|
procedure TrimE(var s:string);
|
|
function upper(const s : string) : string;
|
|
procedure Verbose(lvl:TVerboseLevel; const s:string);
|
|
function GetConfig(const logprefix,fn:string;out aConfig:TConfig):boolean;
|
|
function GetUnitTestConfig(const logprefix,fn,SrcDir: string; out aConfig : TConfig) : Boolean;
|
|
Function GetFileContents (FN : String) : String;
|
|
|
|
const
|
|
{ Constants used in IsAbsolute function }
|
|
TargetHasDosStyleDirectories : boolean = false;
|
|
TargetAmigaLike : boolean = false;
|
|
TargetIsMacOS : boolean = false;
|
|
TargetIsUnix : boolean = false;
|
|
|
|
{ File path helper functions }
|
|
function SplitPath(const s:string):string;
|
|
function SplitBasePath(const s:string): string;
|
|
Function SplitFileName(const s:string):string;
|
|
Function SplitFileBase(const s:string):string;
|
|
Function SplitFileExt(const s:string):string;
|
|
Function FileExists (Const F : String) : Boolean;
|
|
Function PathExists (Const F : String) : Boolean;
|
|
Function IsAbsolute (Const F : String) : boolean;
|
|
function GetToken(var s: string; Delims: TCharSet = [' ']):string;
|
|
|
|
Implementation
|
|
|
|
function posr(c : Char; const s : AnsiString) : integer;
|
|
var
|
|
i : integer;
|
|
begin
|
|
i := length(s);
|
|
while (i>0) and (s[i] <> c) do dec(i);
|
|
Result := i;
|
|
end;
|
|
|
|
|
|
function GetToken(var s: string; Delims: TCharSet = [' ']):string;
|
|
var
|
|
i : longint;
|
|
p: PChar;
|
|
begin
|
|
p:=PChar(s);
|
|
i:=0;
|
|
while (p^ <> #0) and not (p^ in Delims) do begin
|
|
Inc(p);
|
|
Inc(i);
|
|
end;
|
|
GetToken:=Copy(s,1,i);
|
|
Delete(s,1,i+1);
|
|
end;
|
|
|
|
function SplitPath(const s:string):string;
|
|
var
|
|
i : longint;
|
|
begin
|
|
i:=Length(s);
|
|
while (i>0) and not(s[i] in ['/','\'{$IFDEF MACOS},':'{$ENDIF}]) do
|
|
dec(i);
|
|
SplitPath:=Copy(s,1,i);
|
|
end;
|
|
|
|
|
|
function SplitBasePath(const s:string): string;
|
|
var
|
|
i : longint;
|
|
begin
|
|
i:=1;
|
|
while (i<length(s)) and not(s[i] in ['/','\'{$IFDEF MACOS},':'{$ENDIF}]) do
|
|
inc(i);
|
|
if s[i] in ['/','\'{$IFDEF MACOS},':'{$ENDIF}] then
|
|
dec(i);
|
|
SplitBasePath:=Copy(s,1,i);
|
|
end;
|
|
|
|
Function SplitFileName(const s:string):string;
|
|
|
|
begin
|
|
Result:=ExtractFileName(S);
|
|
end;
|
|
|
|
Function SplitFileBase(const s:string):string;
|
|
|
|
begin
|
|
Result:=ChangeFileExt(ExtractFileName(S),'');
|
|
end;
|
|
|
|
Function SplitFileExt(const s:string):string;
|
|
begin
|
|
Result:=ExtractFileExt(S);
|
|
end;
|
|
|
|
|
|
Function FileExists (Const F : String) : Boolean;
|
|
|
|
begin
|
|
Result:=SysUtils.FileExists(F);
|
|
end;
|
|
|
|
|
|
Function PathExists (Const F : String) : Boolean;
|
|
{
|
|
Returns True if the file exists, False if not.
|
|
}
|
|
|
|
begin
|
|
Result:=DirectoryExists(F);
|
|
end;
|
|
|
|
{ extracted from rtl/macos/macutils.inc }
|
|
|
|
function IsMacFullPath (const path: string): Boolean;
|
|
begin
|
|
if Pos(':', path) = 0 then {its partial}
|
|
IsMacFullPath := false
|
|
else if path[1] = ':' then
|
|
IsMacFullPath := false
|
|
else
|
|
IsMacFullPath := true
|
|
end;
|
|
|
|
|
|
Function IsAbsolute (Const F : String) : boolean;
|
|
{
|
|
Returns True if the name F is a absolute file name
|
|
}
|
|
begin
|
|
IsAbsolute:=false;
|
|
if TargetHasDosStyleDirectories then
|
|
begin
|
|
if (F[1]='/') or (F[1]='\') then
|
|
IsAbsolute:=true;
|
|
if (Length(F)>2) and (F[2]=':') and ((F[3]='\') or (F[3]='/')) then
|
|
IsAbsolute:=true;
|
|
end
|
|
else if TargetAmigaLike then
|
|
begin
|
|
if (length(F)>0) and (Pos(':',F) <> 0) then
|
|
IsAbsolute:=true;
|
|
end
|
|
else if TargetIsMacOS then
|
|
begin
|
|
IsAbsolute:=IsMacFullPath(F);
|
|
end
|
|
{ generic case }
|
|
else if (F[1]='/') then
|
|
IsAbsolute:=true;
|
|
end;
|
|
|
|
procedure Verbose(lvl:TVerboseLevel;const s:string);
|
|
|
|
const
|
|
lPrefixes : Array[TVerboseLevel] of string = ('Abort','Error','Warning','Info','Debug','SQL');
|
|
|
|
var
|
|
lOutput : String;
|
|
|
|
Procedure DoOutput;
|
|
|
|
begin
|
|
if not IsCGI then
|
|
begin
|
|
Writeln(output,lOutput);
|
|
Flush(output);
|
|
end
|
|
else
|
|
begin
|
|
Writeln(stderr,lOutput);
|
|
Flush(stderr);
|
|
end;
|
|
if Assigned(OnVerbose) then
|
|
OnVerbose(lvl,lOutput);
|
|
end;
|
|
|
|
begin
|
|
lOutput:=lPrefixes[lvl]+': '+S;
|
|
case lvl of
|
|
V_Normal :
|
|
DoOutput;
|
|
V_Debug :
|
|
if DoVerbose then
|
|
DoOutput;
|
|
V_SQL :
|
|
if DoSQL then
|
|
DoOutput;
|
|
V_Warning :
|
|
DoOutput;
|
|
V_Error :
|
|
begin
|
|
DoOutput;
|
|
if not IsCGI then
|
|
halt(1);
|
|
end;
|
|
V_Abort :
|
|
begin
|
|
DoOutput;
|
|
if not IsCGI then
|
|
halt(0);
|
|
end;
|
|
end;
|
|
|
|
end;
|
|
|
|
procedure TrimB(var s:string);
|
|
begin
|
|
S:=TrimLeft(S);
|
|
end;
|
|
|
|
|
|
procedure TrimE(var s:string);
|
|
begin
|
|
S:=TrimRight(S);
|
|
end;
|
|
|
|
|
|
function upper(const s : string) : string;
|
|
var
|
|
i,l : longint;
|
|
|
|
begin
|
|
Result:='';
|
|
L:=Length(S);
|
|
SetLength(Result,l);
|
|
for i:=1 to l do
|
|
if s[i] in ['a'..'z'] then
|
|
Result[i]:=char(byte(s[i])-32)
|
|
else
|
|
Result[i]:=s[i];
|
|
end;
|
|
|
|
function GetConfig(const logprefix,fn:string;out aConfig:TConfig):boolean;
|
|
|
|
Procedure ExtractCodeAndNote(s : String; out aCode : Integer; out aNote : String);
|
|
|
|
var
|
|
i : Integer;
|
|
|
|
begin
|
|
aCode:=0;
|
|
aNote:='';
|
|
if S='' then
|
|
exit;
|
|
I:=1;
|
|
While (i<=Length(s)) and (S[I] in ['0'..'9']) do
|
|
Inc(i);
|
|
if I>1 then
|
|
aCode:=StrToIntDef(Copy(S,1,i-1),0);
|
|
aNote:=Copy(S,I,Length(S)-I+1);
|
|
end;
|
|
|
|
function GetEntry(S : String; Out entry, Res :string):boolean;
|
|
var
|
|
i : longint;
|
|
|
|
begin
|
|
Result:=False;
|
|
Entry:='';
|
|
Res:='';
|
|
S:=TrimLeft(s);
|
|
if (s='') or (S[1]<>'{') then exit(False);
|
|
Delete(S,1,1);
|
|
S:=TrimLeft(s);
|
|
if (s='') or (S[1]<>'%') then exit(False);
|
|
Delete(S,1,1);
|
|
S:=TrimLeft(s);
|
|
i:=Pos('}',S);
|
|
if I=0 then exit(False);
|
|
S:=Copy(S,1,I-1);
|
|
i:=Pos('=',S);
|
|
if I=0 then
|
|
Entry:=Trim(S)
|
|
else
|
|
begin
|
|
Entry:=Trim(Copy(S,1,I-1));
|
|
Res:=Trim(Copy(S,I+1,Length(S)-I));
|
|
end;
|
|
Result:=True;
|
|
Verbose(V_Debug,'Config: '+Entry+' = "'+Res+'"');
|
|
end;
|
|
|
|
Procedure AnalyseEntry(aEntry,aValue : string);
|
|
var
|
|
l,p,code : Integer;
|
|
|
|
begin
|
|
case UpperCase(aEntry) of
|
|
'OPT': aConfig.NeedOptions:=aValue;
|
|
'DELOPT': aConfig.DelOptions:=aValue;
|
|
'TARGET': aConfig.NeedTarget:=aValue;
|
|
'SKIPTARGET': aConfig.SkipTarget:=aValue;
|
|
'CPU': aConfig.NeedCPU:=aValue;
|
|
'SKIPCPU': aConfig.SkipCPU:=aValue;
|
|
'SKIPEMU': aConfig.SkipEmu:=aValue;
|
|
'VERSION': aConfig.MinVersion:=aValue;
|
|
'MAXVERSION': aConfig.MaxVersion:=aValue;
|
|
'RESULT' : aConfig.ResultCode:=StrToIntDef(aValue,0);
|
|
'GRAPH' : aConfig.UsesGraph:=true;
|
|
'FAIL' : aConfig.ShouldFail:=true;
|
|
'NORUN': aConfig.NoRun:=true;
|
|
'NEEDLIBRARY': aConfig.NeedLibrary:=true;
|
|
'NEEDEDAFTER': aConfig.NeededAfter:=true;
|
|
'TIMEOUT': aConfig.Timeout:=StrToIntDef(aValue,0);
|
|
'FILES': aConfig.Files:=aValue;
|
|
'WPOPARAS': aConfig.wpoparas:=aValue;
|
|
'WPOPASSES': aConfig.wpopasses:=StrToIntDef(aValue,0);
|
|
'DELFILES': aConfig.DelFiles:=aValue;
|
|
'INTERACTIVE': aConfig.IsInteractive:=true;
|
|
'RECOMPILE':
|
|
begin
|
|
aConfig.NeedRecompile:=true;
|
|
aConfig.RecompileOpt:=aValue;
|
|
end;
|
|
'KNOWNRUNERROR':
|
|
begin
|
|
aConfig.IsKnownRunError:=true;
|
|
ExtractCodeAndNote(aValue,aConfig.KnownRunError,aConfig.KnownRunNote);
|
|
end;
|
|
'KNOWNCOMPILEERROR':
|
|
begin
|
|
aConfig.IsKnownCompileError:=true;
|
|
ExtractCodeAndNote(aValue,aConfig.KnownCompileError,aConfig.KnownCompileNote);
|
|
end;
|
|
'NOTE':
|
|
begin
|
|
aConfig.Note:=aValue;
|
|
Verbose(V_Normal,LogPrefix+aConfig.Note);
|
|
end;
|
|
'CONFIGFILE':
|
|
begin
|
|
l:=Pos(' ',aValue);
|
|
if l>0 then
|
|
begin
|
|
aConfig.ConfigFileSrc:=Trim(Copy(aValue,1,l-1));
|
|
aConfig.ConfigFileDst:=Trim(Copy(aValue,l+1,Length(aValue)-l+1));
|
|
if aConfig.ConfigFileSrc='' then
|
|
Verbose(V_Error,LogPrefix+' File '+fn+' Config file source is empty');
|
|
if aConfig.ConfigFileDst='' then
|
|
Verbose(V_Error,LogPrefix+' File '+fn+' Config file destination is empty');
|
|
end
|
|
else
|
|
begin
|
|
aConfig.ConfigFileSrc:=aValue;
|
|
aConfig.ConfigFileDst:=aValue;
|
|
end;
|
|
end;
|
|
'EXPECTMSGS':
|
|
begin
|
|
p:=Pos(',',aValue);
|
|
while p>0 do
|
|
begin
|
|
val(Copy(aValue,1,p-1),l,code);
|
|
if code<>0 then
|
|
Verbose(V_Error,LogPrefix+' File '+fn+' Invalid value in EXPECTMSGS list: '+Copy(aValue,1,p-1));
|
|
Insert(l,aConfig.ExpectMsgs,Length(aConfig.ExpectMsgs));
|
|
Delete(aValue,1,p);
|
|
p:=Pos(',',aValue);
|
|
end;
|
|
Val(aValue,l,code);
|
|
if code<>0 then
|
|
Verbose(V_Error,LogPrefix+' File '+fn+' Invalid value in EXPECTMSGS list: '+aValue);
|
|
Insert(l,aConfig.ExpectMsgs,Length(aConfig.ExpectMsgs));
|
|
end;
|
|
else
|
|
Verbose(V_Error,LogPrefix+' File '+fn+' Unknown entry: '+aEntry+' with value: '+aValue);
|
|
end;
|
|
end;
|
|
|
|
var
|
|
l : TStringList;
|
|
lErr : longint;
|
|
s,aEntry,aValue: string;
|
|
|
|
begin
|
|
Result:=False;
|
|
aConfig:=Default(TConfig);
|
|
GetConfig:=false;
|
|
Verbose(V_Debug,LogPrefix+'Reading '+fn);
|
|
lErr:=0;
|
|
L:=TStringList.Create;
|
|
try
|
|
try
|
|
L.LoadFromFile(FN);
|
|
except
|
|
on E : Exception do
|
|
begin
|
|
Verbose(V_WARNING,'Error '+E.ClassName+' loading '+fn+': '+E.Message);
|
|
exit;
|
|
end;
|
|
end;
|
|
For S in L do
|
|
begin
|
|
if GetEntry(S,aEntry,aValue) then
|
|
AnalyseEntry(aEntry,aValue)
|
|
else
|
|
Inc(lErr);
|
|
if lErr>2 then
|
|
Break;
|
|
end;
|
|
finally
|
|
L.Free;
|
|
end;
|
|
Result:=true;
|
|
end;
|
|
|
|
Function GetFileContents (FN : String) : String;
|
|
|
|
begin
|
|
Result:=Sysutils.GetFileAsString(FN);
|
|
end;
|
|
|
|
function GetUnitTestConfig(const logprefix,fn,SrcDir : string; out aConfig : TConfig) : Boolean;
|
|
|
|
var
|
|
Path : string;
|
|
lClassName : string;
|
|
lMethodName : string;
|
|
slashpos : integer;
|
|
FileName : string;
|
|
s,line : string;
|
|
Src : TStrings;
|
|
|
|
begin
|
|
Result := False;
|
|
aConfig:=Default(TConfig);
|
|
if pos('.',fn) > 0 then exit; // This is normally not a unit-test
|
|
slashpos := posr('/',fn);
|
|
if slashpos < 1 then exit;
|
|
lMethodName := copy(fn,slashpos+1,length(fn));
|
|
Path := copy(fn,1,slashpos-1);
|
|
slashpos := posr('/',Path);
|
|
if slashpos > 0 then
|
|
begin
|
|
lClassName := copy(Path,slashpos+1,length(Path));
|
|
Path := copy(Path,1,slashpos-1);
|
|
end
|
|
else
|
|
begin
|
|
lClassName := Path;
|
|
path := '.';
|
|
end;
|
|
if upper(lClassName[1])<>'T' then exit;
|
|
FileName := SrcDir+Path+DirectorySeparator+copy(lowercase(lClassName),2,length(lClassName));
|
|
if FileExists(FileName+'.pas') then
|
|
FileName := FileName + '.pas'
|
|
else if FileExists(FileName+'.pp') then
|
|
FileName := FileName + '.pp'
|
|
else
|
|
exit;
|
|
Src:=TStringList.Create;
|
|
try
|
|
Verbose(V_Debug,logprefix+'Reading: '+FileName);
|
|
Src.LoadFromFile(FileName);
|
|
for Line in Src do
|
|
if Line<>'' then
|
|
begin
|
|
s:=Line;
|
|
TrimB(s);
|
|
if SameText(copy(s,1,9),'PROCEDURE') then
|
|
begin
|
|
if pos(';',s)>11 then
|
|
begin
|
|
s := copy(s,11,pos(';',s)-11);
|
|
TrimB(s);
|
|
if SameText(s,lClassName+'.'+lMethodName) then
|
|
begin
|
|
Result := True;
|
|
aConfig.Note:= 'unittest';
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
finally
|
|
Src.Free
|
|
end;
|
|
end;
|
|
|
|
|
|
|
|
end.
|