12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169 |
- {
- 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,
- {$ifdef macos}
- macutils,
- {$endif}
- teststr,
- testu,
- redir;
- {$ifdef go32v2}
- {$define LIMIT83FS}
- {$endif}
- {$ifdef os2}
- {$define LIMIT83FS}
- {$endif}
- type
- tcompinfo = (compver,comptarget,compcpu);
- const
- ObjExt='o';
- PPUExt='ppu';
- {$ifdef UNIX}
- ExeExt='';
- {$else UNIX}
- {$ifdef MACOS}
- ExeExt='';
- {$else MACOS}
- ExeExt='exe';
- {$endif MACOS}
- {$endif UNIX}
- var
- Config : TConfig;
- CompilerLogFile,
- ExeLogFile,
- LongLogfile,
- FailLogfile,
- RTLUnitsDir,
- TestOutputDir,
- OutputDir : string;
- CompilerBin : string;
- CompilerCPU : string;
- CompilerTarget : string;
- CompilerVersion : string;
- PPFile : string;
- PPFileInfo : string;
- TestName : string;
- const
- DoGraph : boolean = false;
- DoInteractive : boolean = false;
- DoExecute : boolean = false;
- DoKnown : boolean = false;
- DoAll : boolean = false;
- DoUsual : boolean = true;
- TargetDir : string = '';
- ExtraCompilerOpts : string = '';
- DelExecutable : boolean = false;
- RemoteAddr : string = '';
- RemotePath : string = '/tmp';
- RemotePara : string = '';
- rshprog : string = 'rsh';
- rcpprog : string = 'rcp';
- rquote : char = '''';
- emulatorname : string = '';
- 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;
- 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;
- function trimspace(const s:string):string;
- var
- i,j : longint;
- begin
- i:=length(s);
- while (i>0) and (s[i] in [#9,' ']) do
- dec(i);
- j:=1;
- while (j<i) and (s[j] in [#9,' ']) do
- inc(j);
- trimspace:=Copy(s,j,i-j+1);
- end;
- function IsInList(const entry,list:string):boolean;
- var
- i,istart : longint;
- begin
- IsInList:=false;
- i:=0;
- while (i<length(list)) do
- begin
- { Find list item }
- istart:=i+1;
- while (i<length(list)) and
- (list[i+1]<>',') 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 ['/','\'{$IFDEF MACOS},':'{$ENDIF}]) do
- dec(i);
- SplitPath:=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 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 mkdirtree(const s:string);
- var
- hs : string;
- begin
- if s='' then
- exit;
- if s[length(s)] in ['\','/'{$IFDEF MACOS},':'{$ENDIF}] then
- hs:=Copy(s,1,length(s)-1)
- else
- hs:=s;
- if not PathExists(hs) then
- begin
- { Try parent first }
- mkdirtree(SplitPath(hs));
- { make this dir }
- Verbose(V_Debug,'Making Directory '+s);
- {$I-}
- mkdir(s);
- {$I+}
- ioresult;
- end;
- end;
- Function RemoveFile(const f:string):boolean;
- var
- g : file;
- begin
- assign(g,f);
- {$I-}
- erase(g);
- {$I+}
- RemoveFile:=(ioresult=0);
- 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 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,'Compiler Version: "'+CompilerVersion+'"');
- end;
- function GetCompilerCPU:boolean;
- begin
- if CompilerCPU='' then
- GetCompilerCPU:=GetCompilerInfo(compcpu)
- else
- GetCompilerCPU:=true;
- if GetCompilerCPU then
- Verbose(V_Debug,'Compiler CPU: "'+CompilerCPU+'"');
- end;
- function GetCompilerTarget:boolean;
- begin
- if CompilerTarget='' then
- GetCompilerTarget:=GetCompilerInfo(comptarget)
- else
- GetCompilerTarget:=true;
- if GetCompilerTarget then
- Verbose(V_Debug,'Compiler Target: "'+CompilerTarget+'"');
- end;
- function CompilerFullTarget:string;
- begin
- CompilerFullTarget:=CompilerCPU+'-'+CompilerTarget;
- end;
- function OutputFileName(Const s,ext:String):String;
- begin
- {$ifndef macos}
- OutputFileName:=OutputDir+'/'+ForceExtension(s,ext);
- {$else macos}
- OutputFileName:=ConcatMacPath(OutputDir,ForceExtension(s,ext));
- {$endif macos}
- end;
- function TestOutputFileName(Const s,ext:String):String;
- begin
- {$ifndef macos}
- TestOutputFileName:=TestOutputDir+'/'+ForceExtension(SplitFileName(s),ext);
- {$else macos}
- TestOutputFileName:=ConcatMacPath(TestOutputDir,ForceExtension(SplitFileName(s),ext));
- {$endif macos}
- 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
- args : string;
- execres : boolean;
- begin
- RunCompiler:=false;
- args:='-n -Fu'+RTLUnitsDir;
- args:=args+' -FE'+TestOutputDir;
- {$ifdef macos}
- args:=args+' -WT '; {tests should be compiled as MPWTool}
- {$endif macos}
- if ExtraCompilerOpts<>'' then
- args:=args+ExtraCompilerOpts;
- {$ifdef unix}
- { Add runtime library path to current dir to find .so files }
- if Config.NeedLibrary then
- {$ifndef darwin}
- args:=args+' -Fl'+TestOutputDir+' ''-k-rpath .''';
- {$else darwin}
- args:=args+' -Fl'+TestOutputDir;
- {$endif darwin}
- {$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 }
- {$ifndef macos}
- execres:=ExecuteRedir(CompilerBin,args,'',CompilerLogFile,'stdout');
- {$else macos}
- {Due to that Toolserver is not reentrant, we have to asm and link via script.}
- execres:=ExecuteRedir(CompilerBin,'-s '+args,'',CompilerLogFile,'stdout');
- if execres then
- execres:=ExecuteRedir(TestOutputDir + ':ppas','','',CompilerLogFile,'stdout');
- {$endif macos}
- Verbose(V_Debug,'Exitcode '+ToStr(ExecuteResult));
- { Error during execution? }
- if (not execres) and (ExecuteResult=0) then
- begin
- AddLog(FailLogFile,TestName);
- AddLog(ResLogFile,failed_to_compile+PPFileInfo);
- AddLog(LongLogFile,line_separation);
- AddLog(LongLogFile,failed_to_compile+PPFileInfo);
- CopyFile(CompilerLogFile,LongLogFile,true);
- { avoid to try again }
- AddLog(ExeLogFile,failed_to_compile+PPFileInfo);
- Verbose(V_Abort,'IOStatus: '+ToStr(IOStatus));
- exit;
- end;
- { Check for internal error }
- if ExitWithInternalError(CompilerLogFile) 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(CompilerLogFile,LongLogFile,true);
- { avoid to try again }
- AddLog(ExeLogFile,'Failed to compile '+PPFileInfo);
- Verbose(V_Abort,'Internal error in compiler');
- exit;
- end;
- { Should the compile fail ? }
- if Config.ShouldFail then
- begin
- if ExecuteResult<>0 then
- begin
- AddLog(ResLogFile,success_compilation_failed+PPFileInfo);
- { avoid to try again }
- AddLog(ExeLogFile,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(ExeLogFile,failed_compilation_successful+PPFileInfo);
- if Config.Note<>'' then
- AddLog(LongLogFile,Config.Note);
- CopyFile(CompilerLogFile,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(CompilerLogFile,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(CompilerLogFile,LongLogFile,true);
- { avoid to try again }
- AddLog(ExeLogFile,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 CheckTestExitCode(const OutName:string):boolean;
- var
- t : text;
- s : string;
- i,code : integer;
- begin
- CheckTestExitCode:=false;
- { open logfile }
- assign(t,Outname);
- {$I-}
- reset(t);
- {$I+}
- if ioresult<>0 then
- exit;
- while not eof(t) do
- begin
- readln(t,s);
- i:=pos('TestExitCode: ',s);
- if i>0 then
- begin
- delete(s,1,i+14-1);
- val(s,ExecuteResult,code);
- if code=0 then;
- CheckTestExitCode:=true;
- break;
- end;
- end;
- close(t);
- end;
- function RunExecutable:boolean;
- const
- {$ifdef unix}
- CurrDir = './';
- {$else}
- CurrDir = '';
- {$endif}
- var
- OldDir,
- FullExeLogFile,
- TestRemoteExe,
- TestExe : string;
- execres : boolean;
- function ExecuteRemote(const prog,args:string):boolean;
- begin
- Verbose(V_Debug,'RemoteExecuting '+Prog+' '+args);
- ExecuteRemote:=ExecuteRedir(prog,args,'',EXELogFile,'stdout');
- end;
- function ExecuteEmulated(const prog,args:string):boolean;
- begin
- Verbose(V_Debug,'EmulatorExecuting '+Prog+' '+args);
- ExecuteEmulated:=ExecuteRedir(prog,args,'',FullExeLogFile,'stdout');
- end;
- begin
- RunExecutable:=false;
- execres:=true;
- { when remote testing, leave extension away }
- if RemoteAddr='' then
- TestExe:=OutputFileName(PPFile,ExeExt)
- else
- TestExe:=OutputFileName(PPFile,'');
- if EmulatorName<>'' then
- begin
- { Get full name out log file, because we change the directory during
- execution }
- FullExeLogFile:=FExpand(EXELogFile);
- {$I-}
- GetDir(0,OldDir);
- ChDir(TestOutputDir);
- {$I+}
- ioresult;
- execres:=ExecuteEmulated(EmulatorName,CurrDir+SplitFileName(TestExe));
- {$I-}
- ChDir(OldDir);
- {$I+}
- end
- else if RemoteAddr<>'' then
- begin
- { We don't want to create subdirs, remove paths from the test }
- TestRemoteExe:=RemotePath+'/'+SplitFileName(TestExe);
- ExecuteRemote(rshprog,RemotePara+' '+RemoteAddr+' rm -f '+TestRemoteExe);
- ExecuteRemote(rcpprog,RemotePara+' '+TestExe+' '+RemoteAddr+':'+TestRemoteExe);
- { rsh doesn't pass the exitcode, use a second command to print the exitcode
- on the remoteshell to stdout }
- execres:=ExecuteRemote(rshprog,RemotePara+' '+RemoteAddr+' '+rquote+'chmod 755 '+TestRemoteExe+
- ' ; cd '+RemotePath+' ; '+TestRemoteExe+' ; echo "TestExitCode: $?"'+rquote);
- { Check for TestExitCode error in output, sets ExecuteResult }
- CheckTestExitCode(EXELogFile);
- end
- else
- begin
- { Get full name out log file, because we change the directory during
- execution }
- FullExeLogFile:=FExpand(EXELogFile);
- Verbose(V_Debug,'Executing '+TestExe);
- {$I-}
- GetDir(0,OldDir);
- ChDir(TestOutputDir);
- {$I+}
- ioresult;
- { don't redirect interactive and graph programs }
- if Config.IsInteractive or Config.UsesGraph then
- execres:=ExecuteRedir(CurrDir+SplitFileName(TestExe),'','','','')
- else
- execres:=ExecuteRedir(CurrDir+SplitFileName(TestExe),'','',FullExeLogFile,'stdout');
- {$I-}
- ChDir(OldDir);
- {$I+}
- ioresult;
- end;
- { Error during execution? }
- Verbose(V_Debug,'Exitcode '+ToStr(ExecuteResult));
- if (not execres) and (ExecuteResult=0) then
- begin
- AddLog(FailLogFile,TestName);
- AddLog(ResLogFile,failed_to_run+PPFileInfo);
- AddLog(LongLogFile,line_separation);
- AddLog(LongLogFile,failed_to_run+PPFileInfo);
- CopyFile(EXELogFile,LongLogFile,true);
- { avoid to try again }
- AddLog(ExeLogFile,failed_to_run+PPFileInfo);
- Verbose(V_Abort,'IOStatus: '+ToStr(IOStatus));
- exit;
- end;
- 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(EXELogFile,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(EXELogFile,LongLogFile,true);
- Verbose(V_Abort,'Exitcode: '+ToStr(ExecuteResult)+' (expected '+ToStr(Config.ResultCode)+')');
- end
- end
- else
- begin
- AddLog(ResLogFile,successfully_run+PPFileInfo);
- RunExecutable:=true;
- end;
- if DelExecutable then
- begin
- Verbose(V_Debug,'Deleting executable '+TestExe);
- if RemoteAddr<>'' then
- ExecuteRemote(rshprog,RemotePara+' '+RemoteAddr+' rm -f '+TestRemoteExe);
- RemoveFile(TestExe);
- RemoveFile(ForceExtension(TestExe,ObjExt));
- RemoveFile(ForceExtension(TestExe,PPUExt));
- 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(' -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');
- writeln(' -M<emulator> run the tests using the given emulator');
- writeln(' -R<remote> run the tests remotely with the given rsh/ssh address');
- writeln(' -S use ssh instead of rsh');
- writeln(' -T remove temporary files (executable,ppu,o)');
- writeln(' -P<path> path to the tests tree on the remote machine');
- writeln(' -U<remotepara>');
- writeln(' pass additional parameter to remote program. Multiple -U can be used');
- writeln(' -V be verbose');
- writeln(' -W use putty compatible file names when testing (plink and pscp)');
- writeln(' -Y<opts> extra options passed to the compiler. Several -Y<opt> can be given.');
- 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;
- 'M' : EmulatorName:=Para;
- 'P' : RemotePath:=Para;
- 'R' : RemoteAddr:=Para;
- 'S' :
- begin
- rshprog:='ssh';
- rcpprog:='scp';
- end;
- 'T' :
- DelExecutable:=true;
- 'U' :
- RemotePara:=RemotePara+' '+Para;
- 'V' : DoVerbose:=true;
- 'W' :
- begin
- rshprog:='plink';
- rcpprog:='pscp';
- rquote:=' ';
- end;
- 'X' : UseComSpec:=false;
- 'Y' : ExtraCompilerOpts:= ExtraCompilerOpts +' '+ Para;
- end;
- end
- else
- begin
- If PPFile<>'' then
- HelpScreen;
- PPFile:=ForceExtension(Para,'pp');
- end;
- end;
- if (PPFile='') then
- HelpScreen;
- { disable graph,interactive when running remote }
- if RemoteAddr<>'' then
- begin
- DoGraph:=false;
- DoInteractive:=false;
- end;
- SetPPFileInfo;
- TestName:=Copy(PPFile,1,Pos('.pp',PPFile)-1);
- Verbose(V_Debug,'Running test '+TestName+', file '+PPFile);
- end;
- procedure RunTest;
- var
- PPDir : string;
- Res : boolean;
- begin
- Res:=GetConfig(ppfile,Config);
- if Res then
- begin
- Res:=GetCompilerCPU;
- Res:=GetCompilerTarget;
- {$ifndef MACOS}
- RTLUnitsDir:='units/'+{$ifdef LIMIT83FS}CompilerTarget{$else}CompilerFullTarget{$endif};
- {$else MACOS}
- RTLUnitsDir:=':units:'+CompilerFullTarget;
- {$endif MACOS}
- if not PathExists(RTLUnitsDir) then
- Verbose(V_Abort,'Unit path "'+RTLUnitsDir+'" does not exists');
- {$ifndef MACOS}
- OutputDir:='output/'+{$ifdef LIMIT83FS}CompilerTarget{$else}CompilerFullTarget{$endif};
- {$else MACOS}
- OutputDir:=':output:'+CompilerFullTarget;
- {$endif MACOS}
- if not PathExists(OutputDir) then
- Verbose(V_Abort,'Output path "'+OutputDir+'" does not exists');
- { Global log files }
- ResLogFile:=OutputFileName('log','');
- LongLogFile:=OutputFileName('longlog','');
- FailLogFile:=OutputFileName('faillist','');
- { Make subdir in output if needed }
- PPDir:=SplitPath(PPFile);
- if PPDir[length(PPDir)] in ['/','\'{$ifdef MACOS},':'{$endif MACOS}] then
- Delete(PPDir,length(PPDir),1);
- if PPDir<>'' then
- begin
- {$ifndef MACOS}
- TestOutputDir:=OutputDir+'/'+PPDir;
- {$else MACOS}
- TestOutputDir:=OutputDir+PPDir;
- {$endif MACOS}
- mkdirtree(TestOutputDir);
- end
- else
- TestOutputDir:=OutputDir;
- { Per test logfiles }
- CompilerLogFile:=TestOutputFileName(SplitFileName(PPFile),'log');
- ExeLogFile:=TestOutputFileName(SplitFileName(PPFile),'elg');
- Verbose(V_Debug,'Using Compiler logfile: '+CompilerLogFile);
- Verbose(V_Debug,'Using Execution logfile: '+ExeLogFile);
- end;
- 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(EXELogFile,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(EXELogFile,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(EXELogFile,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<Config.MinVersion then
- begin
- { avoid a second attempt by writing to elg file }
- AddLog(EXELogFile,skipping_compiler_version_too_low+PPFileInfo);
- AddLog(ResLogFile,skipping_compiler_version_too_low+PPFileInfo);
- Verbose(V_Abort,'Compiler version too low '+CompilerVersion+' < '+Config.MinVersion);
- Res:=false;
- end;
- end;
- end;
- if Res then
- begin
- if (Config.MaxVersion<>'') 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(EXELogFile,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);
- if not IsInList(CompilerCPU,Config.NeedCPU) then
- begin
- { avoid a second attempt by writing to elg file }
- AddLog(EXELogFile,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.SkipCPU);
- if IsInList(CompilerCPU,Config.SkipCPU) then
- begin
- { avoid a second attempt by writing to elg file }
- AddLog(EXELogFile,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.SkipEmu<>'' then
- begin
- Verbose(V_Debug,'Skip emulator: '+emulatorname);
- if IsInList(emulatorname,Config.SkipEmu) then
- begin
- { avoid a second attempt by writing to elg file }
- AddLog(EXELogFile,skipping_other_cpu+PPFileInfo);
- AddLog(ResLogFile,skipping_other_cpu+PPFileInfo);
- Verbose(V_Abort,'Emulator "'+emulatorname+'" is in list "'+Config.SkipEmu+'"');
- Res:=false;
- end;
- end;
- end;
- if Res then
- begin
- if Config.NeedTarget<>'' then
- begin
- Verbose(V_Debug,'Required compiler target: '+Config.NeedTarget);
- if not IsInList(CompilerTarget,Config.NeedTarget) then
- begin
- { avoid a second attempt by writing to elg file }
- AddLog(EXELogFile,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);
- if IsInList(CompilerTarget,Config.SkipTarget) then
- begin
- { avoid a second attempt by writing to elg file }
- AddLog(EXELogFile,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(EXELogFile,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(EXELogFile,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(TestOutputFilename(PPFile,'ppu')) or
- FileExists(TestOutputFilename(PPFile,'ppo')) or
- FileExists(TestOutputFilename(PPFile,'ppw')) then
- begin
- AddLog(ExeLogFile,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.
|