{ $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. **********************************************************************} {$H+} program dotest; uses dos, teststr, testu, redir; type tcompinfo = (compver,comptarget,compcpu); const {$ifdef UNIX} ExeExt=''; {$else UNIX} ExeExt='exe'; {$endif UNIX} var Config : TConfig; CompilerBin : string; CompilerCPU : string; CompilerTarget : string; CompilerVersion : string; PPFile : string; PPFileInfo : string; TestName : string; const LongLogfile : string[32] = 'longlog'; FailLogfile : string[32] = 'faillist'; DoGraph : boolean = false; DoInteractive : boolean = false; DoExecute : boolean = false; DoKnown : boolean = false; DoAll : boolean = false; DoUsual : boolean = true; 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)0) and (s[i] in [#9,' ']) do dec(i); j:=1; while (j',') do inc(i); if Upcase(entry)=Upcase(TrimSpace(Copy(list,istart,i-istart+1))) then begin IsInList:=true; exit; end; { skip , } inc(i); end; 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; 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 i0 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 GetCompilerInfo(c:tcompinfo):boolean; function GetToken(var s:string):string; var i : longint; begin i:=pos(' ',s); if i=0 then i:=length(s)+1; GetToken:=Copy(s,1,i-1); Delete(s,1,i); end; var t : text; hs : string; begin GetCompilerInfo:=false; { Try to get all information in one call, this is supported in 1.1. Older compilers 1.0.x will only return the first info } case c of compver : hs:='-iVTPTO'; compcpu : hs:='-iTPTOV'; comptarget : hs:='-iTOTPV'; end; ExecuteRedir(CompilerBin,hs,'','out',''); assign(t,'out'); {$I-} reset(t); readln(t,hs); close(t); erase(t); {$I+} if ioresult<>0 then Verbose(V_Error,'Can''t get Compiler Info') else begin Verbose(V_Debug,'Retrieved Compiler Info: "'+hs+'"'); case c of compver : begin CompilerVersion:=GetToken(hs); CompilerCPU:=GetToken(hs); CompilerTarget:=GetToken(hs); end; compcpu : begin CompilerCPU:=GetToken(hs); CompilerTarget:=GetToken(hs); CompilerVersion:=GetToken(hs); end; comptarget : begin CompilerTarget:=GetToken(hs); CompilerCPU:=GetToken(hs); CompilerVersion:=GetToken(hs); end; end; GetCompilerInfo:=true; end; end; function GetCompilerVersion:boolean; begin if CompilerVersion='' then GetCompilerVersion:=GetCompilerInfo(compver) else GetCompilerVersion:=true; if GetCompilerVersion then Verbose(V_Debug,'Current Compiler Version: "'+CompilerVersion+'"'); end; function GetCompilerCPU:boolean; begin if CompilerCPU='' then GetCompilerCPU:=GetCompilerInfo(compcpu) else GetCompilerCPU:=true; if GetCompilerCPU then Verbose(V_Debug,'Current Compiler CPU: "'+CompilerCPU+'"'); end; function GetCompilerTarget:boolean; begin if CompilerTarget='' then GetCompilerTarget:=GetCompilerInfo(comptarget) else GetCompilerTarget:=true; if GetCompilerTarget then Verbose(V_Debug,'Current Compiler Target: "'+CompilerTarget+'"'); 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:='-n -Fuunits'; {$ifdef unix} { Add runtime library path to current dir to find .so files } if Config.NeedLibrary then args:=args+' ''-k-rpath .'''; {$endif unix} 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 Config.Note<>'' then AddLog(FailLogFile,Config.Note); AddLog(ResLogFile,failed_to_compile+PPFileInfo+' internalerror generated'); AddLog(LongLogFile,line_separation); AddLog(LongLogFile,failed_to_compile+PPFileInfo); if Config.Note<>'' then AddLog(LongLogFile,Config.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 Config.Note<>'' then AddLog(FailLogFile,Config.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 Config.Note<>'' then AddLog(LongLogFile,Config.Note); CopyFile(OutName,LongLogFile,true); end; end else begin if (ExecuteResult<>0) and (((Config.KnownCompileNote<>'') and (Config.KnownCompileError=0)) or ((Config.KnownCompileError<>0) and (ExecuteResult=Config.KnownCompileError))) then begin AddLog(FailLogFile,TestName+known_problem+Config.KnownCompileNote); AddLog(ResLogFile,failed_to_run+PPFileInfo+known_problem+Config.KnownCompileNote); AddLog(LongLogFile,line_separation); AddLog(LongLogFile,known_problem+Config.KnownCompileNote); AddLog(LongLogFile,failed_to_compile+PPFileInfo+' ('+ToStr(ExecuteResult)+')'); Copyfile(OutName,LongLogFile,true); Verbose(V_Abort,known_problem+'exitcode: '+ToStr(ExecuteResult)); end else if ExecuteResult<>0 then begin AddLog(FailLogFile,TestName); if Config.Note<>'' then AddLog(FailLogFile,Config.Note); AddLog(ResLogFile,failed_to_compile+PPFileInfo); AddLog(LongLogFile,line_separation); AddLog(LongLogFile,failed_to_compile+PPFileInfo); if Config.Note<>'' then AddLog(LongLogFile,Config.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); { don't redirect interactive and graph programs .. } if Config.IsInteractive or Config.UsesGraph then ExecuteRedir(TestExe,'','','','') else ExecuteRedir(TestExe,'','',OutName,''); Verbose(V_Debug,'Exitcode '+ToStr(ExecuteResult)); if ExecuteResult<>Config.ResultCode then begin if (ExecuteResult<>0) and (ExecuteResult=Config.KnownRunError) then begin AddLog(FailLogFile,TestName+known_problem+Config.KnownRunNote); AddLog(ResLogFile,failed_to_run+PPFileInfo+known_problem+Config.KnownRunNote); AddLog(LongLogFile,line_separation); AddLog(LongLogFile,known_problem+Config.KnownRunNote); AddLog(LongLogFile,failed_to_run+PPFileInfo+' ('+ToStr(ExecuteResult)+')'); Copyfile(OutName,LongLogFile,true); Verbose(V_Abort,known_problem+'exitcode: '+ToStr(ExecuteResult)+' (expected '+ToStr(Config.ResultCode)+')'); end else 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 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] '); writeln; writeln('Options can be:'); writeln(' -C set compiler to use'); writeln(' -V verbose'); writeln(' -E execute test also'); writeln(' -X don''t use COMSPEC'); 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; DoAll:=true; end; 'C' : CompilerBin:=Para; 'E' : DoExecute:=true; 'G' : begin DoGraph:=true; if para='-' then DoUsual:=false; end; 'I' : begin DoInteractive:=true; if para='-' then DoUsual:=false; end; 'K' : begin DoKnown:=true; if para='-' then DoUsual:=false; end; 'V' : DoVerbose:=true; 'X' : UseComSpec:=false; 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.IsKnownCompileError 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 and not DoUsual then res:=(Config.IsInteractive and DoInteractive) or (Config.IsKnownRunError and DoKnown) or (Config.UsesGraph and DoGraph); if Res then begin if (Config.MinVersion<>'') and not DoAll then begin Verbose(V_Debug,'Required compiler version: '+Config.MinVersion); Res:=GetCompilerVersion; if CompilerVersion'') and not DoAll then begin Verbose(V_Debug,'Highest compiler version: '+Config.MaxVersion); Res:=GetCompilerVersion; if CompilerVersion>Config.MaxVersion then begin { avoid a second attempt by writing to elg file } AddLog(OutName,skipping_compiler_version_too_high+PPFileInfo); AddLog(ResLogFile,skipping_compiler_version_too_high+PPFileInfo); Verbose(V_Abort,'Compiler version too high '+CompilerVersion+' > '+Config.MaxVersion); 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 not IsInList(CompilerCPU,Config.NeedCPU) 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 "'+CompilerCPU+'" is not in list "'+Config.NeedCPU+'"'); Res:=false; end; end; end; if Res then begin if Config.SkipCPU<>'' then begin Verbose(V_Debug,'Skip compiler cpu: '+Config.NeedCPU); Res:=GetCompilerCPU; if IsInList(CompilerCPU,Config.SkipCPU) 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 "'+CompilerCPU+'" is in list "'+Config.SkipCPU+'"'); Res:=false; end; end; end; if Res then begin if Config.NeedTarget<>'' then begin Verbose(V_Debug,'Required compiler target: '+Config.NeedTarget); Res:=GetCompilerTarget; if not IsInList(CompilerTarget,Config.NeedTarget) then begin { avoid a second attempt by writing to elg file } AddLog(OutName,skipping_other_target+PPFileInfo); AddLog(ResLogFile,skipping_other_target+PPFileInfo); Verbose(V_Abort,'Compiler target "'+CompilerTarget+'" is not in list "'+Config.NeedTarget+'"'); Res:=false; end; end; end; if Res then begin if Config.SkipTarget<>'' then begin Verbose(V_Debug,'Skip compiler target: '+Config.NeedTarget); Res:=GetCompilerTarget; if IsInList(CompilerTarget,Config.SkipTarget) then begin { avoid a second attempt by writing to elg file } AddLog(OutName,skipping_other_target+PPFileInfo); AddLog(ResLogFile,skipping_other_target+PPFileInfo); Verbose(V_Abort,'Compiler target "'+CompilerTarget+'" is in list "'+Config.SkipTarget+'"'); 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 if Config.IsKnownRunError 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); 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.29 2003-10-31 16:14:20 peter * remove compileerror10, note10 * remove known, use knowncompileerror,knownrunerror instead * knowncompileerror,knownrunerror tests are now really skipped Revision 1.28 2003/10/13 14:19:02 peter * digest updated for max version limit Revision 1.27 2003/06/13 08:16:34 pierre * fix a problem with KNOWNCOMPILE10ERROR Revision 1.26 2003/02/20 12:41:15 pierre + handle KNOWNCOMPILEERROR and KNOWNCOMPILE10ERROR Revision 1.25 2002/12/24 22:30:41 peter * small verbosity update Revision 1.24 2002/12/24 21:47:49 peter * NeedTarget, SkipTarget, SkipCPU added * Retrieve compiler info in a single call for 1.1 compiler Revision 1.23 2002/12/17 15:04:32 michael + Added dbdigest to store results in a database Revision 1.22 2002/12/15 13:30:46 peter * NEEDLIBRARY option to add -rpath to the linker for unix. This is needed to test runtime library tests. The library needs the -FE. option to place the .so in the correct directory Revision 1.21 2002/12/05 16:03:34 pierre + -X option to disable UseComSpec Revision 1.20 2002/11/18 16:42:43 pierre + KNOWNRUNERROR added Revision 1.19 2002/11/18 01:31:07 pierre + use -n option + use -G- for only graph + use -I- for only interactive + use -K- for only known bugs. 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. }