mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-12 19:29:28 +02:00
509 lines
12 KiB
ObjectPascal
509 lines
12 KiB
ObjectPascal
{$mode objfpc}
|
|
{$h+}
|
|
|
|
unit testu;
|
|
|
|
Interface
|
|
|
|
uses
|
|
dos;
|
|
{ ---------------------------------------------------------------------
|
|
utility functions, shared by several programs of the test suite
|
|
---------------------------------------------------------------------}
|
|
|
|
type
|
|
TCharSet = set of char;
|
|
|
|
TVerboseLevel=(V_Abort,V_Error,V_Warning,V_Normal,V_Debug,V_SQL);
|
|
|
|
TConfig = record
|
|
NeedOptions,
|
|
DelOptions,
|
|
NeedCPU,
|
|
SkipCPU,
|
|
SkipEmu,
|
|
NeedTarget,
|
|
SkipTarget,
|
|
MinVersion,
|
|
MaxVersion,
|
|
KnownRunNote,
|
|
KnownCompileNote,
|
|
RecompileOpt: string;
|
|
ResultCode : longint;
|
|
KnownRunError : longint;
|
|
KnownCompileError : longint;
|
|
NeedRecompile : boolean;
|
|
NeedLibrary : boolean;
|
|
NeededAfter : boolean;
|
|
IsInteractive : boolean;
|
|
IsKnownRunError,
|
|
IsKnownCompileError : boolean;
|
|
NoRun : boolean;
|
|
UsesGraph : boolean;
|
|
ShouldFail : boolean;
|
|
Timeout : longint;
|
|
Category : string;
|
|
Note : string;
|
|
Files : string;
|
|
ConfigFileSrc : string;
|
|
ConfigFileDst : string;
|
|
WpoParas : string;
|
|
WpoPasses : longint;
|
|
DelFiles : string;
|
|
end;
|
|
|
|
Const
|
|
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 fn:string;var r: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 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;
|
|
var
|
|
p : dirstr;
|
|
n : namestr;
|
|
e : extstr;
|
|
begin
|
|
FSplit(s,p,n,e);
|
|
SplitFileName:=n+e;
|
|
end;
|
|
|
|
Function SplitFileBase(const s:string):string;
|
|
var
|
|
p : dirstr;
|
|
n : namestr;
|
|
e : extstr;
|
|
begin
|
|
FSplit(s,p,n,e);
|
|
SplitFileBase:=n;
|
|
end;
|
|
|
|
Function SplitFileExt(const s:string):string;
|
|
var
|
|
p : dirstr;
|
|
n : namestr;
|
|
e : extstr;
|
|
begin
|
|
FSplit(s,p,n,e);
|
|
SplitFileExt:=e;
|
|
end;
|
|
|
|
|
|
Function FileExists (Const F : String) : Boolean;
|
|
{
|
|
Returns True if the file exists, False if not.
|
|
}
|
|
Var
|
|
info : searchrec;
|
|
begin
|
|
FindFirst (F,anyfile,Info);
|
|
FileExists:=DosError=0;
|
|
FindClose (Info);
|
|
end;
|
|
|
|
|
|
Function PathExists (Const F : String) : Boolean;
|
|
{
|
|
Returns True if the file exists, False if not.
|
|
}
|
|
Var
|
|
info : searchrec;
|
|
begin
|
|
FindFirst (F,anyfile,Info);
|
|
PathExists:=(DosError=0) and (Info.Attr and Directory=Directory);
|
|
FindClose (Info);
|
|
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);
|
|
begin
|
|
case lvl of
|
|
V_Normal :
|
|
writeln(s);
|
|
V_Debug :
|
|
if DoVerbose then
|
|
writeln('Debug: ',s);
|
|
V_SQL :
|
|
if DoSQL then
|
|
writeln('SQL: ',s);
|
|
V_Warning :
|
|
writeln('Warning: ',s);
|
|
V_Error :
|
|
begin
|
|
writeln('Error: ',s);
|
|
halt(1);
|
|
end;
|
|
V_Abort :
|
|
begin
|
|
writeln('Abort: ',s);
|
|
halt(0);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TrimB(var s:string);
|
|
begin
|
|
while (s<>'') and (s[1] in [' ',#9]) do
|
|
delete(s,1,1);
|
|
end;
|
|
|
|
|
|
procedure TrimE(var s:string);
|
|
begin
|
|
while (s<>'') and (s[length(s)] in [' ',#9]) do
|
|
delete(s,length(s),1);
|
|
end;
|
|
|
|
|
|
function upper(const s : string) : string;
|
|
var
|
|
i,l : longint;
|
|
|
|
begin
|
|
L:=Length(S);
|
|
SetLength(upper,l);
|
|
for i:=1 to l do
|
|
if s[i] in ['a'..'z'] then
|
|
upper[i]:=char(byte(s[i])-32)
|
|
else
|
|
upper[i]:=s[i];
|
|
end;
|
|
|
|
function GetConfig(const fn:string;var r:TConfig):boolean;
|
|
var
|
|
t : text;
|
|
part,code : integer;
|
|
l : longint;
|
|
s,res : string;
|
|
|
|
function GetEntry(const entry:string):boolean;
|
|
var
|
|
i : longint;
|
|
begin
|
|
Getentry:=false;
|
|
Res:='';
|
|
if Upper(Copy(s,1,length(entry)))=Upper(entry) then
|
|
begin
|
|
Delete(s,1,length(entry));
|
|
TrimB(s);
|
|
if (s<>'') then
|
|
begin
|
|
if (s[1]='=') then
|
|
begin
|
|
delete(s,1,1);
|
|
i:=pos('}',s);
|
|
if i=0 then
|
|
i:=255
|
|
else
|
|
dec(i);
|
|
res:=Copy(s,1,i);
|
|
TrimB(res);
|
|
TrimE(res);
|
|
end;
|
|
Verbose(V_Debug,'Config: '+Entry+' = "'+Res+'"');
|
|
GetEntry:=true;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
FillChar(r,sizeof(r),0);
|
|
GetConfig:=false;
|
|
Verbose(V_Debug,'Reading '+fn);
|
|
assign(t,fn);
|
|
{$I-}
|
|
reset(t);
|
|
{$I+}
|
|
if ioresult<>0 then
|
|
begin
|
|
Verbose(V_Error,'Can''t open '+fn);
|
|
exit;
|
|
end;
|
|
r.Note:='';
|
|
while not eof(t) do
|
|
begin
|
|
readln(t,s);
|
|
if Copy(s,1,3)=#$EF#$BB#$BF then
|
|
delete(s,1,3);
|
|
TrimB(s);
|
|
if s<>'' then
|
|
begin
|
|
if s[1]='{' then
|
|
begin
|
|
delete(s,1,1);
|
|
TrimB(s);
|
|
if (s<>'') and (s[1]='%') then
|
|
begin
|
|
delete(s,1,1);
|
|
if GetEntry('OPT') then
|
|
r.NeedOptions:=res
|
|
else
|
|
if GetEntry('DELOPT') then
|
|
r.DelOptions:=res
|
|
else
|
|
if GetEntry('TARGET') then
|
|
r.NeedTarget:=res
|
|
else
|
|
if GetEntry('SKIPTARGET') then
|
|
r.SkipTarget:=res
|
|
else
|
|
if GetEntry('CPU') then
|
|
r.NeedCPU:=res
|
|
else
|
|
if GetEntry('SKIPCPU') then
|
|
r.SkipCPU:=res
|
|
else
|
|
if GetEntry('SKIPEMU') then
|
|
r.SkipEmu:=res
|
|
else
|
|
if GetEntry('VERSION') then
|
|
r.MinVersion:=res
|
|
else
|
|
if GetEntry('MAXVERSION') then
|
|
r.MaxVersion:=res
|
|
else
|
|
if GetEntry('RESULT') then
|
|
Val(res,r.ResultCode,code)
|
|
else
|
|
if GetEntry('GRAPH') then
|
|
r.UsesGraph:=true
|
|
else
|
|
if GetEntry('FAIL') then
|
|
r.ShouldFail:=true
|
|
else
|
|
if GetEntry('RECOMPILE') then
|
|
begin
|
|
r.NeedRecompile:=true;
|
|
r.RecompileOpt:=res;
|
|
end
|
|
else
|
|
if GetEntry('NORUN') then
|
|
r.NoRun:=true
|
|
else
|
|
if GetEntry('NEEDLIBRARY') then
|
|
r.NeedLibrary:=true
|
|
else
|
|
if GetEntry('NEEDEDAFTER') then
|
|
r.NeededAfter:=true
|
|
else
|
|
if GetEntry('KNOWNRUNERROR') then
|
|
begin
|
|
r.IsKnownRunError:=true;
|
|
if res<>'' then
|
|
begin
|
|
val(res,l,code);
|
|
if code>1 then
|
|
begin
|
|
part:=code;
|
|
val(copy(res,1,code-1),l,code);
|
|
delete(res,1,part);
|
|
end;
|
|
if code=0 then
|
|
r.KnownRunError:=l;
|
|
if res<>'' then
|
|
r.KnownRunNote:=res;
|
|
end;
|
|
end
|
|
else
|
|
if GetEntry('KNOWNCOMPILEERROR') then
|
|
begin
|
|
r.IsKnownCompileError:=true;
|
|
if res<>'' then
|
|
begin
|
|
val(res,l,code);
|
|
if code>1 then
|
|
begin
|
|
part:=code;
|
|
val(copy(res,1,code-1),l,code);
|
|
delete(res,1,part);
|
|
end;
|
|
if code=0 then
|
|
r.KnownCompileError:=l;
|
|
if res<>'' then
|
|
r.KnownCompileNote:=res;
|
|
end;
|
|
end
|
|
else
|
|
if GetEntry('INTERACTIVE') then
|
|
r.IsInteractive:=true
|
|
else
|
|
if GetEntry('NOTE') then
|
|
begin
|
|
R.Note:='Note: '+res;
|
|
Verbose(V_Normal,r.Note);
|
|
end
|
|
else
|
|
if GetEntry('TIMEOUT') then
|
|
Val(res,r.Timeout,code)
|
|
else
|
|
if GetEntry('FILES') then
|
|
r.Files:=res
|
|
else
|
|
if GetEntry('CONFIGFILE') then
|
|
begin
|
|
l:=Pos(' ',res);
|
|
if l>0 then
|
|
begin
|
|
r.ConfigFileSrc:=Copy(res,1,l-1);
|
|
r.ConfigFileDst:=Copy(res,l+1,Length(res)-l+1);
|
|
if r.ConfigFileSrc='' then
|
|
Verbose(V_Error,'Config file source is empty');
|
|
if r.ConfigFileDst='' then
|
|
Verbose(V_Error,'Config file destination is empty');
|
|
end
|
|
else
|
|
begin
|
|
r.ConfigFileSrc:=res;
|
|
r.ConfigFileDst:=res;
|
|
end;
|
|
end
|
|
else
|
|
if GetEntry('WPOPARAS') then
|
|
r.wpoparas:=res
|
|
else
|
|
if GetEntry('WPOPASSES') then
|
|
val(res,r.wpopasses,code)
|
|
else
|
|
if GetEntry('DELFILES') then
|
|
r.DelFiles:=res
|
|
else
|
|
Verbose(V_Error,'Unknown entry: '+s);
|
|
end;
|
|
end
|
|
else
|
|
break;
|
|
end;
|
|
end;
|
|
close(t);
|
|
GetConfig:=true;
|
|
end;
|
|
|
|
Function GetFileContents (FN : String) : String;
|
|
|
|
Var
|
|
F : Text;
|
|
S : String;
|
|
|
|
begin
|
|
Result:='';
|
|
Assign(F,FN);
|
|
{$I-}
|
|
Reset(F);
|
|
If IOResult<>0 then
|
|
Exit;
|
|
{$I+}
|
|
While Not(EOF(F)) do
|
|
begin
|
|
ReadLn(F,S);
|
|
if length(Result)<MaxLogSize then
|
|
Result:=Result+S+LineEnding;
|
|
end;
|
|
Close(F);
|
|
end;
|
|
|
|
end.
|