fpc/tests/utils/dotest.pp
2002-11-14 10:36:12 +00:00

775 lines
18 KiB
ObjectPascal

{
$Id$
This file is part of the Free Pascal test suite.
Copyright (c) 1999-2002 by the Free Pascal development team.
This program makes the compilation and
execution of individual test sources.
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program 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.
**********************************************************************}
program dotest;
uses
dos,
teststr,
redir;
const
{$ifdef UNIX}
ExeExt='';
{$else UNIX}
ExeExt='exe';
{$endif UNIX}
type
TVerboseLevel=(V_Abort,V_Error,V_Warning,V_Normal,V_Debug);
TConfig = record
NeedOptions,
NeedCPU,
NeedVersion : string;
ResultCode : longint;
NeedRecompile : boolean;
IsInteractive : boolean;
IsKnown : boolean;
NoRun : boolean;
UsesGraph : boolean;
ShouldFail : boolean;
Category : string;
end;
var
Config : TConfig;
CompilerBin : string;
CompilerCPU : string;
CompilerVersion : string;
PPFile : string;
PPFileInfo : string;
TestName : string;
Note : string;
const
LongLogfile : string[32] = 'longlog';
FailLogfile : string[32] = 'faillist';
DoVerbose : boolean = false;
DoGraph : boolean = false;
DoInteractive : boolean = false;
DoExecute : boolean = false;
DoKnown : boolean = false;
procedure Verbose(lvl:TVerboseLevel;const s:string);
begin
case lvl of
V_Normal :
writeln(s);
V_Debug :
if DoVerbose then
writeln('Debug: ',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;
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 ToStr(l:longint):string;
var
s : string;
begin
Str(l,s);
ToStr:=s;
end;
function ToStrZero(l:longint;nbzero : byte):string;
var
s : string;
begin
Str(l,s);
while length(s)<nbzero do
s:='0'+s;
ToStrZero:=s;
end;
procedure SetPPFileInfo;
Var
info : searchrec;
dt : DateTime;
begin
FindFirst (PPFile,anyfile,Info);
If DosError=0 then
begin
UnpackTime(info.time,dt);
PPFileInfo:=PPFile+' '+ToStr(dt.year)+'/'+ToStrZero(dt.month,2)+'/'+
ToStrZero(dt.day,2)+' '+ToStrZero(dt.Hour,2)+':'+ToStrZero(dt.min,2)+':'+ToStrZero(dt.sec,2);
end
else
PPFileInfo:=PPfile;
FindClose (Info);
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 : longint;
begin
for i:=1 to length(s) do
if s[i] in ['a'..'z'] then
upper[i]:=char(byte(s[i])-32)
else
upper[i]:=s[i];
upper[0]:=s[0];
end;
function SplitPath(const s:string):string;
var
i : longint;
begin
i:=Length(s);
while (i>0) and not(s[i] in ['/','\']) do
dec(i);
SplitPath:=Copy(s,1,i);
end;
function ForceExtension(Const HStr,ext:String):String;
{
Return a filename which certainly has the extension ext
}
var
j : longint;
begin
j:=length(Hstr);
while (j>0) and (Hstr[j]<>'.') do
dec(j);
if j=0 then
j:=255;
if Ext<>'' then
ForceExtension:=Copy(Hstr,1,j-1)+'.'+Ext
else
ForceExtension:=Copy(Hstr,1,j-1);
end;
procedure Copyfile(const fn1,fn2:string;append:boolean);
const
bufsize = 16384;
var
f,g : file;
i : longint;
buf : pointer;
begin
if Append then
Verbose(V_Debug,'Appending '+fn1+' to '+fn2)
else
Verbose(V_Debug,'Copying '+fn1+' to '+fn2);
assign(f,fn1);
assign(g,fn2);
{$I-}
reset(f,1);
{$I+}
if ioresult<>0 then
Verbose(V_Error,'Can''t open '+fn1);
if append then
begin
{$I-}
reset(g,1);
{$I+}
if ioresult<>0 then
append:=false
else
seek(g,filesize(g));
end;
if not append then
begin
{$I-}
rewrite(g,1);
{$I+}
if ioresult<>0 then
Verbose(V_Error,'Can''t open '+fn2+' for output');
end;
getmem(buf,bufsize);
repeat
blockread(f,buf^,bufsize,i);
blockwrite(g,buf^,i);
until i<bufsize;
freemem(buf,bufsize);
close(f);
close(g);
end;
procedure AddLog(const logfile,s:string);
var
t : text;
begin
assign(t,logfile);
{$I-}
append(t);
{$I+}
if ioresult<>0 then
begin
{$I-}
rewrite(t);
{$I+}
if ioresult<>0 then
Verbose(V_Abort,'Can''t append to '+logfile);
end;
writeln(t,s);
close(t);
end;
function GetConfig(const fn:string;var r:TConfig):boolean;
var
t : text;
code : integer;
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;
Note:='';
while not eof(t) do
begin
readln(t,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('CPU') then
r.NeedCPU:=res
else
if GetEntry('VERSION') then
r.NeedVersion:=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
r.NeedRecompile:=true
else
if GetEntry('NORUN') then
r.NoRun:=true
else
if GetEntry('KNOWN') then
r.IsKnown:=true
else
if GetEntry('INTERACTIVE') then
r.IsInteractive:=true
else
if GetEntry('NOTE') then
begin
Note:='Note: '+res;
Verbose(V_Normal,Note);
end
else
Verbose(V_Error,'Unknown entry: '+s);
end;
end
else
break;
end;
end;
close(t);
GetConfig:=true;
end;
function GetCompilerVersion:boolean;
var
t : text;
begin
GetCompilerVersion:=false;
ExecuteRedir(CompilerBin,'-iV','','out','');
assign(t,'out');
{$I-}
reset(t);
readln(t,CompilerVersion);
close(t);
erase(t);
{$I+}
if ioresult<>0 then
Verbose(V_Error,'Can''t get Compiler Version')
else
begin
Verbose(V_Debug,'Current Compiler Version: '+CompilerVersion);
GetCompilerVersion:=true;
end;
end;
function GetCompilerCPU:boolean;
var
t : text;
begin
GetCompilerCPU:=false;
ExecuteRedir(CompilerBin,'-iTP','','out','');
assign(t,'out');
{$I-}
reset(t);
readln(t,CompilerCPU);
close(t);
erase(t);
{$I+}
if ioresult<>0 then
Verbose(V_Error,'Can''t get Compiler CPU Target')
else
begin
Verbose(V_Debug,'Current Compiler CPU Target: '+CompilerCPU);
GetCompilerCPU:=true;
end;
end;
function ExitWithInternalError(const OutName:string):boolean;
var
t : text;
s : string;
begin
ExitWithInternalError:=false;
{ open logfile }
assign(t,Outname);
{$I-}
reset(t);
{$I+}
if ioresult<>0 then
exit;
while not eof(t) do
begin
readln(t,s);
if pos('Fatal: Internal error ',s)>0 then
begin
ExitWithInternalError:=true;
break;
end;
end;
close(t);
end;
function RunCompiler:boolean;
var
outname,
args : string;
begin
RunCompiler:=false;
OutName:=ForceExtension(PPFile,'log');
args:='-Fuunits';
if Config.NeedOptions<>'' then
args:=args+' '+Config.NeedOptions;
args:=args+' '+ppfile;
Verbose(V_Debug,'Executing '+compilerbin+' '+args);
{ also get the output from as and ld that writes to stderr sometimes }
ExecuteRedir(CompilerBin,args,'',OutName,OutName);
Verbose(V_Debug,'Exitcode '+ToStr(ExecuteResult));
{ Check for internal error }
if ExitWithInternalError(OutName) then
begin
AddLog(FailLogFile,TestName);
if Note<>'' then
AddLog(FailLogFile,Note);
AddLog(ResLogFile,failed_to_compile+PPFileInfo+' internalerror generated');
AddLog(LongLogFile,line_separation);
AddLog(LongLogFile,failed_to_compile+PPFileInfo);
if Note<>'' then
AddLog(LongLogFile,Note);
CopyFile(OutName,LongLogFile,true);
{ avoid to try again }
AddLog(ForceExtension(PPFile,'elg'),'Failed to compile '++PPFileInfo);
Verbose(V_Abort,'Internal error in compiler');
exit;
end;
{ Shoud the compile fail ? }
if Config.ShouldFail then
begin
if ExecuteResult<>0 then
begin
AddLog(ResLogFile,success_compilation_failed+PPFileInfo);
{ avoid to try again }
AddLog(ForceExtension(PPFile,'elg'),success_compilation_failed+PPFileInfo);
RunCompiler:=true;
end
else
begin
AddLog(FailLogFile,TestName);
if Note<>'' then
AddLog(FailLogFile,Note);
AddLog(ResLogFile,failed_compilation_successful+PPFileInfo);
AddLog(LongLogFile,line_separation);
AddLog(LongLogFile,failed_compilation_successful+PPFileInfo);
{ avoid to try again }
AddLog(ForceExtension(PPFile,'elg'),failed_compilation_successful+PPFileInfo);
if Note<>'' then
AddLog(LongLogFile,Note);
CopyFile(OutName,LongLogFile,true);
end;
end
else
begin
if ExecuteResult<>0 then
begin
AddLog(FailLogFile,TestName);
if Note<>'' then
AddLog(FailLogFile,Note);
AddLog(ResLogFile,failed_to_compile+PPFileInfo);
AddLog(LongLogFile,line_separation);
AddLog(LongLogFile,failed_to_compile+PPFileInfo);
if Note<>'' then
AddLog(LongLogFile,Note);
CopyFile(OutName,LongLogFile,true);
{ avoid to try again }
AddLog(ForceExtension(PPFile,'elg'),failed_to_compile+PPFileInfo);
Verbose(V_Abort,'Exitcode: '+ToStr(ExecuteResult)+' (expected 0)');
end
else
begin
AddLog(ResLogFile,successfully_compiled+PPFileInfo);
RunCompiler:=true;
end;
end;
end;
function RunExecutable:boolean;
var
outname,
TestExe : string;
begin
RunExecutable:=false;
TestExe:=ForceExtension(PPFile,ExeExt);
OutName:=ForceExtension(PPFile,'elg');
Verbose(V_Debug,'Executing '+TestExe);
ExecuteRedir(TestExe,'','',OutName,'');
Verbose(V_Debug,'Exitcode '+ToStr(ExecuteResult));
if ExecuteResult<>Config.ResultCode then
begin
AddLog(FailLogFile,TestName);
AddLog(ResLogFile,failed_to_run+PPFileInfo);
AddLog(LongLogFile,line_separation);
AddLog(LongLogFile,failed_to_run+PPFileInfo+' ('+ToStr(ExecuteResult)+')');
Copyfile(OutName,LongLogFile,true);
Verbose(V_Abort,'Exitcode: '+ToStr(ExecuteResult)+' (expected '+ToStr(Config.ResultCode)+')');
end
else
begin
AddLog(ResLogFile,successfully_run+PPFileInfo);
RunExecutable:=true;
end;
end;
procedure getargs;
var
ch : char;
para : string;
i : longint;
procedure helpscreen;
begin
writeln('dotest [Options] <File>');
writeln;
writeln('Options can be:');
writeln(' -C<compiler> set compiler to use');
writeln(' -V verbose');
writeln(' -E execute test also');
writeln(' -A include ALL tests');
writeln(' -G include graph tests');
writeln(' -K include known bug tests');
writeln(' -I include interactive tests');
halt(1);
end;
begin
PPFile:='';
if exeext<>'' then
CompilerBin:='ppc386.'+exeext
else
CompilerBin:='ppc386';
for i:=1 to paramcount do
begin
para:=Paramstr(i);
if (para[1]='-') then
begin
ch:=Upcase(para[2]);
delete(para,1,2);
case ch of
'A' :
begin
DoGraph:=true;
DoInteractive:=true;
DoKnown:=true;
end;
'C' : CompilerBin:=Para;
'E' : DoExecute:=true;
'G' : DoGraph:=true;
'I' : DoInteractive:=true;
'V' : DoVerbose:=true;
'K' : DoKnown:=true;
end;
end
else
begin
If PPFile<>'' then
HelpScreen;
PPFile:=ForceExtension(Para,'pp');
end;
end;
if (PPFile='') then
HelpScreen;
SetPPFileInfo;
TestName:=Copy(PPFile,1,Pos('.pp',PPFile)-1);
Verbose(V_Debug,'Running test '+TestName+', file '+PPFile);
end;
procedure RunTest;
var
Res : boolean;
OutName : string;
begin
Res:=GetConfig(ppfile,Config);
OutName:=ForceExtension(PPFile,'elg');
if Res then
begin
if Config.UsesGraph and (not DoGraph) then
begin
AddLog(ResLogFile,skipping_graph_test+PPFileInfo);
{ avoid a second attempt by writing to elg file }
AddLog(OutName,skipping_graph_test+PPFileInfo);
Verbose(V_Abort,skipping_graph_test);
Res:=false;
end;
end;
if Res then
begin
if Config.IsInteractive and (not DoInteractive) then
begin
{ avoid a second attempt by writing to elg file }
AddLog(OutName,skipping_interactive_test+PPFileInfo);
AddLog(ResLogFile,skipping_interactive_test+PPFileInfo);
Verbose(V_Abort,skipping_interactive_test);
Res:=false;
end;
end;
if Res then
begin
if Config.IsKnown and (not DoKnown) then
begin
{ avoid a second attempt by writing to elg file }
AddLog(OutName,skipping_known_bug+PPFileInfo);
AddLog(ResLogFile,skipping_known_bug+PPFileInfo);
Verbose(V_Abort,skipping_known_bug);
Res:=false;
end;
end;
if Res then
begin
if Config.NeedVersion<>'' then
begin
Verbose(V_Debug,'Required compiler version: '+Config.NeedVersion);
Res:=GetCompilerVersion;
if CompilerVersion<Config.NeedVersion then
begin
{ avoid a second attempt by writing to elg file }
AddLog(OutName,skipping_compiler_version_too_low+PPFileInfo);
AddLog(ResLogFile,skipping_compiler_version_too_low+PPFileInfo);
Verbose(V_Abort,'Compiler version too low '+CompilerVersion+' < '+Config.NeedVersion);
Res:=false;
end;
end;
end;
if Res then
begin
if Config.NeedCPU<>'' then
begin
Verbose(V_Debug,'Required compiler cpu: '+Config.NeedCPU);
Res:=GetCompilerCPU;
if Upper(Config.NeedCPU)<>Upper(CompilerCPU) then
begin
{ avoid a second attempt by writing to elg file }
AddLog(OutName,skipping_other_cpu+PPFileInfo);
AddLog(ResLogFile,skipping_other_cpu+PPFileInfo);
Verbose(V_Abort,'Compiler cpu wrong '+CompilerCPU+' <> '+Config.NeedCPU);
Res:=false;
end;
end;
end;
if Res then
begin
Res:=RunCompiler;
if Res and Config.NeedRecompile then
Res:=RunCompiler;
end;
if Res then
begin
if (Config.NoRun) then
begin
{ avoid a second attempt by writing to elg file }
AddLog(OutName,skipping_run_test+PPFileInfo);
AddLog(ResLogFile,skipping_run_test+PPFileInfo);
Verbose(V_Debug,skipping_run_test);
end
else
begin
if (not Config.ShouldFail) and DoExecute then
begin
if FileExists(ForceExtension(PPFile,'ppu')) or
FileExists(ForceExtension(PPFile,'ppo')) or
FileExists(ForceExtension(PPFile,'ppw')) then
begin
AddLog(ForceExtension(PPFile,'elg'),skipping_run_unit+PPFileInfo);
AddLog(ResLogFile,skipping_run_unit+PPFileInfo);
Verbose(V_Debug,'Unit found, skipping run test')
end
else
Res:=RunExecutable;
end;
end;
end;
end;
begin
GetArgs;
RunTest;
end.
{
$Log$
Revision 1.18 2002-11-14 10:36:12 pierre
* add internalerror info to log file
Revision 1.17 2002/11/13 15:26:24 pierre
+ digest program added
Revision 1.16 2002/11/13 15:19:44 pierre
log strings moved to teststr unit
Revision 1.15 2002/09/07 15:40:56 peter
* old logs removed and tabs fixed
Revision 1.14 2002/04/21 18:15:32 peter
* Check for internal errors
Revision 1.13 2002/03/03 13:27:28 hajny
+ added support for OS/2 units (.ppo)
Revision 1.12 2002/01/29 13:24:16 pierre
+ also generate .elg file for units
Revision 1.11 2002/01/29 12:51:08 pierre
+ PPFileInfo to also display time stamp of test file
* generate .elg file in several cases
to avoid trying to recompute the same test
over and over again.
}