From a7f59dc5a91be14936a1838ed10265365d983e2e Mon Sep 17 00:00:00 2001 From: pierre Date: Fri, 15 Jun 2018 20:25:30 +0000 Subject: Merge most of trunk/tests/utils changes from trunk branch. Merge of trunk revision 32622 ------------------------------------------------------------------------ r32622 | nickysn | 2015-12-09 16:56:23 +0100 (Wed, 09 Dec 2015) | 2 lines Changed paths: M /trunk/tests/utils/dosbox/dosbox_wrapper.pas * on Windows, run dosbox with the swoHIDE option to prevent the annoying focus stealing dosbox consoles from appearing ------------------------------------------------------------------------ Merge of trunk revision 32623 ------------------------------------------------------------------------ r32623 | pierre | 2015-12-10 02:48:18 +0100 (Thu, 10 Dec 2015) | 16 lines Changed paths: M /trunk/tests/utils/dosbox/dosbox_wrapper.pas + (OutputFileName variable): Add possibility to use output duplicated to a file by a modified dosbox version, using an entry in [dos] section of dosbox.conf cinfig file. copy_con_to_file=/path/to/file/that/will/get/the/copy + (EchoOutput procedure) Write to ouput the content of this file so that it ends up into XXXX.elg file when checking test file XXXX. * Add use_temp_dir boolean variable, set to true by default, can be set to false by setting DOSBOX_NO_TEMPDIR env. variable. + Add hide_execution boolean variable (might only work on Windows), which sets SWOHide to Process.ShowWindow property if true. hide_execution defaults to true, but can be set to true by setting DOSBOX_NO_HIDE to set to false. + Add do_exit boolean variable (defaulting to true), which adds 'exit' as last line into autoexec section in dosbox.conf. Use DOSBOX_NO_EXIT to avoid automatic closing of DosBox at the end of test execution (can bbe useful for debugging purposes). ------------------------------------------------------------------------ Merge of trunk revision 32624 ------------------------------------------------------------------------ r32624 | pierre | 2015-12-10 02:49:37 +0100 (Thu, 10 Dec 2015) | 1 line Changed paths: M /trunk/tests/utils/dosbox/dosbox.conf Change 'exit' to '' to allow to avoid exit at the end of test run ------------------------------------------------------------------------ Merge of trunk revision 32678 ------------------------------------------------------------------------ r32678 | nickysn | 2015-12-18 02:40:22 +0100 (Fri, 18 Dec 2015) | 3 lines Changed paths: M /trunk/tests/utils/dosbox/dosbox_wrapper.pas * write a message to stdout if dosbox is killed due to a timeout ------------------------------------------------------------------------ Merge of trunk revision 32679 ------------------------------------------------------------------------ r32679 | nickysn | 2015-12-18 02:43:24 +0100 (Fri, 18 Dec 2015) | 5 lines Changed paths: M /trunk/tests/utils/dosbox/dosbox_wrapper.pas * handle exceptions when opening the exitcode.txt file as well, so that we write a nicer message to stdout in case the file does not exist (which happens often when we kill dosbox, due to a timeout) ------------------------------------------------------------------------ Merge of trunk revision 32696 ------------------------------------------------------------------------ r32696 | nickysn | 2015-12-22 01:05:39 +0100 (Tue, 22 Dec 2015) | 5 lines Changed paths: M /trunk/tests/utils/dosbox/dosbox_wrapper.pas + support specifying the dosbox timeout (the maximal amount of time a test is allowed to run, before dosbox is killed) via the DOSBOX_TIMEOUT environment variable ------------------------------------------------------------------------ Merge of trunk revision 32697 ------------------------------------------------------------------------ r32697 | nickysn | 2015-12-22 11:01:13 +0100 (Tue, 22 Dec 2015) | 3 lines Changed paths: M /trunk/tests/utils/dosbox/dosbox_wrapper.pas * increased the default dosbox timeout to 60 seconds ------------------------------------------------------------------------ Merge of trunk revision 32761 ------------------------------------------------------------------------ r32761 | nickysn | 2015-12-27 13:43:01 +0100 (Sun, 27 Dec 2015) | 3 lines Changed paths: M /trunk/tests/utils/dosbox/dosbox_wrapper.pas * increased the default dosbox timeout to 90 seconds ------------------------------------------------------------------------ Merge of trunk revision 32834 ------------------------------------------------------------------------ r32834 | nickysn | 2016-01-03 12:54:45 +0100 (Sun, 03 Jan 2016) | 3 lines Changed paths: M /trunk/tests/utils/dosbox/dosbox_wrapper.pas * dosbox timeout increased to 100 seconds ------------------------------------------------------------------------ Merge of trunk revision 33385 ------------------------------------------------------------------------ r33385 | pierre | 2016-03-30 09:42:35 +0200 (Wed, 30 Mar 2016) | 9 lines Changed paths: M /trunk/tests/utils/dosbox/dosbox_wrapper.pas + Add verbose boolean variable, set to false by default, set to true by setting environment variable DOSBOX_VERBOSE. Most output generated by the wrapper is now only given if verbose is true. + New constant SkipUntilText, default value 'Drive C is mounted as ', allow to discard output generated by dosbox program up to the line containing this string. ------------------------------------------------------------------------ Merge of trunk revision 36230 ------------------------------------------------------------------------ r36230 | pierre | 2017-05-16 22:51:36 +0200 (Tue, 16 May 2017) | 1 line Changed paths: M /trunk/tests/utils/dosbox/dosbox.conf Add disablesplash=true ------------------------------------------------------------------------ Merge of trunk revision 36231 ------------------------------------------------------------------------ r36231 | pierre | 2017-05-16 22:56:29 +0200 (Tue, 16 May 2017) | 9 lines Changed paths: M /trunk/tests/utils/dosbox/dosbox_wrapper.pas + Add UseSignals macro, which conditionally adds code using signals unit to try to interrupt runaway executables + Global DosBoxProcess TProcess class variable. + Display modified lines inside dosbox.conf if verbose * Try to use Terminate when program exceeds dosbox_timeout (in seconds) * Handle signals if UseSignals macro is set. ------------------------------------------------------------------------ Merge of trunk revision 36313 ------------------------------------------------------------------------ r36313 | pierre | 2017-05-24 09:41:25 +0200 (Wed, 24 May 2017) | 1 line Changed paths: M /trunk/tests/utils/dosbox/dosbox_wrapper.pas Fix ExitCode readout if temp directory is used by postponing temp directory cleanup ------------------------------------------------------------------------ Merge of trunk revision 36317 ------------------------------------------------------------------------ r36317 | pierre | 2017-05-24 23:53:01 +0200 (Wed, 24 May 2017) | 1 line Changed paths: M /trunk/tests/utils/dbdigest.pp M /trunk/tests/utils/testu.pp Limit log size to 50000, and add all testrun information at start ------------------------------------------------------------------------ Merge of trunk revision 36726 ------------------------------------------------------------------------ r36726 | pierre | 2017-07-11 20:07:43 +0200 (Tue, 11 Jul 2017) | 1 line Changed paths: M /trunk/tests/utils/dosbox/dosbox_wrapper.pas Search for cwsdpmi DOS exeutable in PATH if DOSBOX_NEEDS_CWSDPMI is set or TEST_OS_TARGET is go32v2 to allow testing go32v2 programs using DOSBOX ------------------------------------------------------------------------ Merge of trunk revision 36992 ------------------------------------------------------------------------ r36992 | svenbarth | 2017-08-20 22:23:50 +0200 (Sun, 20 Aug 2017) | 1 line Changed paths: M /trunk/tests/utils/dotest.pp M /trunk/tests/utils/testu.pp * implement support for copying a central, pre-created configuration file for a test ------------------------------------------------------------------------ Merge of trunk revision 38648 ------------------------------------------------------------------------ r38648 | pierre | 2018-03-30 09:59:14 +0200 (Fri, 30 Mar 2018) | 1 line Changed paths: M /trunk/tests/utils/dotest.pp M /trunk/tests/utils/testu.pp Move several path related functions from dotest program to testu unit for use in dosbox_wrapper program ------------------------------------------------------------------------ Merge of trunk revision 38683 ------------------------------------------------------------------------ r38683 | pierre | 2018-04-04 23:00:26 +0200 (Wed, 04 Apr 2018) | 7 lines Changed paths: M /trunk/tests/utils/dosbox/dosbox_wrapper.pas * Improve support in temporary directory. + CopyNeededFiles to copy additional files to temp directory. + TempFileList: New variable. * Cleanup: Use TempFileList to delete more file. + Add optional -Ssource_file_name directory. ------------------------------------------------------------------------ Merge of trunk revision 38684 ------------------------------------------------------------------------ r38684 | pierre | 2018-04-04 23:27:07 +0200 (Wed, 04 Apr 2018) | 1 line Changed paths: M /trunk/tests/utils/dotest.pp M /trunk/tests/utils/testu.pp Move GetToken function to testu unit ------------------------------------------------------------------------ Merge of trunk revision 38685 ------------------------------------------------------------------------ r38685 | pierre | 2018-04-04 23:27:36 +0200 (Wed, 04 Apr 2018) | 1 line Changed paths: M /trunk/tests/utils/dosbox/dosbox_wrapper.pas Add handling of DelFiles ------------------------------------------------------------------------ Merge of trunk revision 38741 ------------------------------------------------------------------------ r38741 | pierre | 2018-04-12 15:44:14 +0200 (Thu, 12 Apr 2018) | 1 line Changed paths: M /trunk/tests/utils/dosbox/dosbox.conf Use auto instead of dynamic, as dynamic is not always possible ------------------------------------------------------------------------ Merge of trunk revision 38742 ------------------------------------------------------------------------ r38742 | pierre | 2018-04-12 15:46:09 +0200 (Thu, 12 Apr 2018) | 1 line Changed paths: M /trunk/tests/utils/dosbox/dosbox_wrapper.pas Add .exe suffix to ASrcFileName if ADestFileName ends with .exe or if file is not found ------------------------------------------------------------------------ Merge of trunk revision 38816 ------------------------------------------------------------------------ r38816 | pierre | 2018-04-23 00:18:27 +0200 (Mon, 23 Apr 2018) | 1 line Changed paths: M /trunk/tests/utils/dosbox/dosbox_wrapper.pas Avoid program RTE if failing to remove temporary directory ------------------------------------------------------------------------ Merge of trunk revision 38960 ------------------------------------------------------------------------ r38960 | pierre | 2018-05-09 17:17:40 +0200 (Wed, 09 May 2018) | 1 line Changed paths: M /trunk/tests/utils/dosbox/dosbox_wrapper.pas Correct copy of files to temp directory and removal of temp directory ------------------------------------------------------------------------ Merge of trunk revision 39197 ------------------------------------------------------------------------ r39197 | pierre | 2018-06-08 10:35:45 +0200 (Fri, 08 Jun 2018) | 1 line Changed paths: M /trunk/tests/utils/dosbox/dosbox_wrapper.pas Report if ExitStatus of DosBox process is non-zero ------------------------------------------------------------------------ git-svn-id: https://svn.freepascal.org/svn/fpc/branches/fixes_3_0@39236 3ad0048d-3df7-0310-abae-a5850022a9f2 --- tests/utils/dbdigest.pp | 12 +- tests/utils/dosbox/dosbox.conf | 8 +- tests/utils/dosbox/dosbox_wrapper.pas | 550 ++++++++++++++++++++++++++++++---- tests/utils/dotest.pp | 230 +++++--------- tests/utils/testu.pp | 182 ++++++++++- 5 files changed, 765 insertions(+), 217 deletions(-) diff --git a/tests/utils/dbdigest.pp b/tests/utils/dbdigest.pp index 1fce9ec2b3..16c396a6fe 100644 --- a/tests/utils/dbdigest.pp +++ b/tests/utils/dbdigest.pp @@ -402,7 +402,8 @@ Var ConfigID : Integer; Procedure GetIDs; - +var + qry : string; begin TestCPUID := GetCPUId(TestCPU); If TestCPUID=-1 then @@ -425,11 +426,15 @@ begin If (TestRunID=-1) then begin TestRunID:=AddRun(TestOSID,TestCPUID,TestVersionID,TestCategoryID,TestDate); - If TestRUnID=-1 then + If TestRunID=-1 then Verbose(V_Error,'Could not insert new testrun record!'); end else CleanTestRun(TestRunID); + { Add known infomration at start } + qry:=format('UPDATE TESTRUN SET TU_SUBMITTER=''%s'', TU_MACHINE=''%s'', TU_COMMENT=''%s'', TU_DATE=''%s''',[Submitter,Machine,Comment,SqlDate(TestDate)]); + qry:=qry+' WHERE TU_ID='+format('%d',[TestRunID]); + ExecuteQuery(Qry,False); end; @@ -467,7 +472,8 @@ begin { End of file marker } if eof(LongLogFile) or (pos('>>>>>>>>>>>',S)=1) then exit; - Result:=Result+S+LineEnding; + if length(Result) 5 then - raise; + begin + Writeln('Directory creation failed'); + raise; + end; end; end; until Done; @@ -31,10 +59,13 @@ procedure GenerateDosBoxConf(const ADosBoxDir: string); var SourceConfFileName, TargetConfFileName: string; SourceFile, TargetFile: TextFile; - S: string; + OrigS, S: string; begin SourceConfFileName := ExtractFilePath(ParamStr(0)) + 'dosbox.conf'; TargetConfFileName := ADosBoxDir + 'dosbox.conf'; + OutputFileName := ADosBoxDir + 'dosbox.out'; + if verbose then + Writeln('Using target dosbox.conf ',TargetConfFileName); AssignFile(SourceFile, SourceConfFileName); AssignFile(TargetFile, TargetConfFileName); Reset(SourceFile); @@ -44,7 +75,15 @@ begin while not EoF(SourceFile) do begin Readln(SourceFile, S); + OrigS:=S; S := AnsiReplaceStr(S, '$DosBoxDir', ADosBoxDir); + S := AnsiReplaceStr(S, '$wrapper_output', OutputFileName); + if do_exit then + S := AnsiReplaceStr(S, '$exit', 'exit') + else + S := AnsiReplaceStr(S, '$exit', ''); + If verbose and (OrigS <> S) then + Writeln('"',OrigS,'" transformed into "',S,'"'); Writeln(TargetFile, S); end; finally @@ -55,6 +94,17 @@ begin end; end; +{ File names in Config entries assume that + executables have no suffix } +function TargetFileExists(AName : string) : boolean; +begin + result:=SysUtils.FileExists(AName); + if not result then + result:=SysUtils.FileExists(AName+'.exe'); + if not result then + result:=SysUtils.FileExists(AName+'.EXE'); +end; + procedure CopyFile(ASrcFileName, ADestFileName: string); var SrcF, DestF: File; @@ -62,98 +112,450 @@ var Buf: array [0..4095] of Byte; BytesRead: Integer; begin - Writeln('CopyFile ', ASrcFileName, '->', ADestFileName); - if not AnsiEndsText('.exe', ASrcFileName) then + if not AnsiEndsText('.exe', ASrcFileName) and AnsiEndsText('.EXE',ADestFileName) then ASrcFileName := ASrcFileName + '.exe'; + if not FileExists(ASrcFileName) then + begin + ASrcFileName:=ASrcFileName+'.exe'; + ADestFileName:=ADestFileName+'.exe'; + end; + if verbose then + Writeln('CopyFile "', ASrcFileName, '" -> "', ADestFileName,'"'); OldFileMode := FileMode; try - AssignFile(SrcF, ASrcFileName); - AssignFile(DestF, ADestFileName); - FileMode := fmOpenRead; - Reset(SrcF, 1); try - FileMode := fmOpenWrite; + AssignFile(SrcF, ASrcFileName); + AssignFile(DestF, ADestFileName); + FileMode := fmOpenRead; + Reset(SrcF, 1); try - Rewrite(DestF, 1); - repeat - BlockRead(SrcF, Buf, SizeOf(Buf), BytesRead); - BlockWrite(DestF, Buf, BytesRead); - until BytesRead < SizeOf(Buf); + FileMode := fmOpenWrite; + try + Rewrite(DestF, 1); + repeat + BlockRead(SrcF, Buf, SizeOf(Buf), BytesRead); + BlockWrite(DestF, Buf, BytesRead); + until BytesRead < SizeOf(Buf); + finally + CloseFile(DestF); + end; finally - CloseFile(DestF); + CloseFile(SrcF); end; finally - CloseFile(SrcF); + FileMode := OldFileMode; end; - finally - FileMode := OldFileMode; + except + on E : Exception do + writeln('Error: '+ E.ClassName + #13#10 + E.Message ); end; 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:=length(Hstr)+1; + if Ext<>'' then + begin + if Ext[1]='.' then + ForceExtension:=Copy(Hstr,1,j-1)+Ext + else + ForceExtension:=Copy(Hstr,1,j-1)+'.'+Ext + end + else + ForceExtension:=Copy(Hstr,1,j-1); +end; + +procedure CopyNeededFiles; +var + Config : TConfig; + LocalFile, RemoteFile, s: string; + LocalPath: string; + i : integer; + FileList : TStringList; + RelativeToConfigMarker : TObject; + + 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 BuildFileList: TStringList; + var + dfl, fl : string; + begin + fl:=Trim(Config.Files); + dfl:=Trim(Config.DelFiles); + if (fl='') and (dfl='') and (Config.ConfigFileSrc='') then + begin + Result:=nil; + exit; + end; + Result:=TStringList.Create; + while fl<>'' do + begin + LocalFile:=Trim(GetToken(fl, [' ',',',';'])); + Result.Add(LocalFile); + if verbose then + writeln('Adding file ',LocalFile,' from Config.Files'); + end; + + if Config.ConfigFileSrc<>'' then + begin + if Config.ConfigFileSrc=Config.ConfigFileDst then + Result.AddObject(Config.ConfigFileSrc,RelativeToConfigMarker) + else + Result.AddObject(Config.ConfigFileSrc+'='+Config.ConfigFileDst,RelativeToConfigMarker); + if verbose then + writeln('Adding config file Src=',Config.ConfigFileSrc,' Dst=',Config.ConfigFileDst); + end; + while dfl <> '' do + begin + LocalFile:=Trim(GetToken(dfl, [' ',',',';'])); + Result.Add(LocalFile); + if verbose then + writeln('Adding file ',LocalFile,' from Config.DelFiles'); + end; + end; + +var + ddir : string; + param1_dir : string; +begin + param1_dir:=ExtractFilePath(ParamStr(1)); + if not IsAbsolute(SourceFileName) and not TargetFileExists(SourceFileName) then + begin + ddir:=GetEnvironmentVariable('BASEDIR'); + if ddir='' then + GetDir(0,ddir); + // writeln('Start ddir=',ddir); + while (ddir<>'') do + begin + if TargetFileExists(ddir+DirectorySeparator+SourceFileName) then + begin + SourceFileName:=ddir+DirectorySeparator+SourceFileName; + break; + end + else + begin + if ddir=splitpath(ddir) then + break + else + ddir:=splitpath(ddir); + if ddir[length(ddir)]=DirectorySeparator then + ddir:=copy(ddir,1,length(ddir)-1); + // writeln('Next ddir=',ddir); + end; + end; + end; + if not TargetFileExists(SourceFileName) then + begin + writeln('File ',SourceFileName,' not found'); + exit; + end + else if verbose then + writeln('Analyzing source file ',SourceFileName); + if not GetConfig(SourceFileName,config) then + exit; + + RelativeToConfigMarker:=TObject.Create; + FileList:=BuildFileList; + TmpFileList:=TStringList.Create; + if assigned(FileList) then + begin + LocalPath:=SplitPath(SourceFileName); + if (Length(LocalPath) > 0) and (LocalPath[Length(LocalPath)]<>DirectorySeparator) then + LocalPath:=LocalPath+DirectorySeparator; + for i:=0 to FileList.count-1 do + begin + if FileList.Names[i]<>'' then + begin + LocalFile:=FileList.Names[i]; + RemoteFile:=FileList.ValueFromIndex[i]; + end + else + begin + LocalFile:=FileList[i]; + RemoteFile:=LocalFile; + end; + if FileList.Objects[i]=RelativeToConfigMarker then + s:='config/'+LocalFile + else + s:=LocalPath+LocalFile; + if not TargetFileExists(s) then + if TargetFileExists(param1_dir+DirectorySeparator+LocalFile) then + s:=param1_dir+DirectorySeparator+LocalFile; + CopyFile(s,DosBoxDir+RemoteFile); + TmpFileList.Add(RemoteFile); + end; + FileList.Free; + end; + RelativeToConfigMarker.Free; +end; + +{ On modified dosbox executable it is possible to get + a copy of all output to CON into a file, simply write it + back to output, so it ends up into testname.elg file. + Skip all until line beginning with 'Drive C is mounted as' } +procedure EchoOutput; +const + SkipUntilText = 'Drive C is mounted as '; +var + StdText : TextFile; + st : string; + line : longint; + SkipUntilSeen : boolean; +begin + if FileExists(OutputFileName) then + begin + if verbose then + Writeln('Trying to open ',OutputFileName); + try + AssignFile(StdText, OutputFileName); + Reset(StdText); + if verbose then + Writeln('Successfully opened ',OutputFileName,', copying content to output'); + try + line:=0; + SkipUntilSeen:=false; + while not eof(StdText) do + begin + Readln(StdText,st); + inc(line); + if not SkipUntilSeen then + SkipUntilSeen:=pos(SkipUntilText,st)>0; + if SkipUntilSeen then + Writeln(line,': ',st); + end; + finally + if not SkipUntilSeen then + Writeln('Could not find "',SkipUntilText,'" in file ',OutputFilename); + Flush(output); + CloseFile(StdText); + end; + finally + if use_temp_dir then + DeleteFile(OutputFileName); + end; + end; +end; + function ReadExitCode(const ADosBoxDir: string): Integer; var F: TextFile; begin AssignFile(F, ADosBoxDir + 'EXITCODE.TXT'); - Reset(F); try + Reset(F); Readln(F, Result); - finally + if Result <> 0 then + Writeln('ExitCode=',Result); CloseFile(F); + except + Writeln('Unable to read exitcode value'); + if (DosBoxExitStatus <> 0) then + Writeln('DosBox exit status = ',DosBoxExitStatus); + ReadExitCode:=127*256; end; end; -procedure ExecuteDosBox(const ADosBoxBinaryPath, ADosBoxDir: string); -const - Timeout = 10*15; { 15 seconds } +function ExecuteDosBox(const ADosBoxBinaryPath, ADosBoxDir: string) : Integer; var - Process: TProcess; Time: Integer = 0; begin - Process := TProcess.Create(nil); + DosBoxProcess := TProcess.Create(nil); + result:=-1; try - Process.Executable := ADosBoxBinaryPath; - Process.Parameters.Add('-conf'); - Process.Parameters.Add(ADosBoxDir + 'dosbox.conf'); - Process.Execute; + DosBoxProcess.Executable := ADosBoxBinaryPath; + DosBoxProcess.Parameters.Add('-conf'); + DosBoxProcess.Parameters.Add(ADosBoxDir + 'dosbox.conf'); + if hide_execution then + DosBoxProcess.ShowWindow := swoHIDE; + DosBoxProcess.Execute; repeat Inc(Time); - if Time > Timeout then + if (Time > 10*dosbox_timeout) and do_exit then break; Sleep(100); - until not Process.Running; - if Process.Running then - Process.Terminate(254); + until not DosBoxProcess.Running; + if DosBoxProcess.Running then + begin + Writeln('Timeout exceeded. Killing dosbox...'); + DosBoxProcess.Terminate(254); + Sleep(100); + end; finally - Process.Free; + result:=DosBoxProcess.ExitStatus; + DosBoxProcess.Free; + DosBoxProcess:=nil; + EchoOutput; end; end; -procedure Cleanup(const ADosBoxDir: string); - procedure DeleteIfExists(const AFileName: string); - begin - if FileExists(AFileName) then - DeleteFile(AFileName); - end; +function DeleteIfExists(const AFileName: string) : boolean; +begin + result:=false; + if FileExists(AFileName) then + result:=DeleteFile(AFileName); + if not result and FileExists(AFileName+'.exe') then + result:=DeleteFile(AFileName+'.exe'); + if not result and FileExists(AFileName+'.EXE') then + result:=DeleteFile(AFileName+'.EXE'); +end; +{ RemoveDir, with removal of files or subdirectories inside first. + ADirName is supposed to finish with DirectorySeparator } +function RemoveDir(const ADirName: string) : boolean; +var + Info : TSearchRec; +begin + Result:=true; + If FindFirst (AdirName+'*',faAnyFile and faDirectory,Info)=0 then + begin + repeat + with Info do + begin + If (Attr and faDirectory) = faDirectory then + begin + { Skip present and parent directory } + if (Name<>'..') and (Name<>'.') then + if not RemoveDir(ADirName+Name+DirectorySeparator) then + begin + writeln('Failed to remove dir '+ADirName+Name+DirectorySeparator); + result:=false; + FindClose(Info); + exit; + end; + end + else + if not DeleteFile(ADirName+Name) then + begin + writeln('Failed to remove file '+ADirName+Name); + result:=false; + FindClose(Info); + exit; + end; + end; + Until FindNext(info)<>0; + end; + FindClose(Info); + RemoveDir:=SysUtils.RemoveDir(ADirName); +end; + +procedure Cleanup(const ADosBoxDir: string); +var + i : longint; begin DeleteIfExists(ADosBoxDir + 'dosbox.conf'); DeleteIfExists(ADosBoxDir + 'EXITCODE.TXT'); DeleteIfExists(ADosBoxDir + 'EXITCODE.EXE'); + DeleteIfExists(ADosBoxDir + 'CWSDPMI.EXE'); DeleteIfExists(ADosBoxDir + 'TEST.EXE'); - RmDir(ADosBoxDir); + if Assigned(TmpFileList) then + begin + for i:=0 to TmpFileList.count-1 do + if TmpFileList[i]<>'' then + DeleteIfExists(ADosBoxDir + TmpFileList[i]); + end; + TmpFileList.Free; + ChDir(StartDir); + if not RemoveDir(ADosBoxDir) then + writeln('Failed to remove dir ',ADosBoxDir); +end; + + +{$ifdef UseSignals} +const + SignalCalled : boolean = false; + SignalNb : longint = 0; + +function DosBoxSignal(signal:longint):longint; cdecl; + +begin + SignalCalled:=true; + SignalNb:=signal; end; +{$endif def UseSignals} +procedure ExitProc; var - DosBoxDir: string; - ExitCode: Integer = 255; - DosBoxBinaryPath: string; + count : longint; +begin + if assigned(DosBoxProcess) and (DosBoxProcess.Running) then + begin + Writeln('In ExitProc. Killing dosbox...'); + DosBoxProcess.Terminate(254*1024); + Sleep(100); + count:=1; + while (DosBoxProcess.Running) do + begin + Sleep(100); + inc(count); + if (count mod 20=0) then + DosBoxProcess.Terminate(254*1024+count); + end; + if count>1 then + Writeln('In ExitProc. Wait for termination dosbox..., time=',count/10); + EchoOutput; + end; +end; + begin Randomize; + + + if GetEnvironmentVariable('DOSBOX_NO_TEMPDIR')<>'' then + begin + use_temp_dir:=false; + Writeln('use_temp_dir set to false'); + end; + if GetEnvironmentVariable('DOSBOX_NO_HIDE')<>'' then + begin + hide_execution:=false; + Writeln('hide_execution set to false'); + end; + if GetEnvironmentVariable('DOSBOX_NO_EXIT')<>'' then + begin + do_exit:=false; + Writeln('do_exit set to false'); + end; + if GetEnvironmentVariable('DOSBOX_VERBOSE')<>'' then + begin + verbose:=true; + Writeln('verbose set to true'); + end; + if (GetEnvironmentVariable('DOSBOX_NEEDS_CWSDPMI')<>'') or + (GetEnvironmentVariable('TEST_OS_TARGET')='go32v2') then + begin + need_cwsdpmi:=true; + Writeln('need_cwsdpmi set to true'); + end; + if GetEnvironmentVariable('DOSBOX_TIMEOUT')<>'' then + begin + dosbox_timeout:=StrToInt(GetEnvironmentVariable('DOSBOX_TIMEOUT')); + Writeln('dosbox_timeout set to ', dosbox_timeout, ' seconds'); + end; if ParamCount = 0 then begin - Writeln('Usage: ' + ParamStr(0) + ' '); + Writeln('Usage: ' + ParamStr(0) + ' (-Ssourcename)'); + Writeln('Set DOSBOX_NO_TEMPDIR env variable to 1 to avoid using a temporary directory'); + Writeln('Set DOSBOX_NO_HIDE to avoid running dosbox in an hidden window'); + Writeln('Set DOSBOX_NO_EXIT to avoid exiting dosbox after test has been run'); + Writeln('Set DOSBOX_TIMEOUT to set the timeout in seconds before killing the dosbox process, assuming the test has hanged'); halt(1); end; DosBoxBinaryPath := GetEnvironmentVariable('DOSBOX'); @@ -161,16 +563,64 @@ begin begin Writeln('Please set the DOSBOX environment variable to the dosbox executable'); halt(1); + end + else + begin + Writeln('Using DOSBOX executable: ',DosBoxBinaryPath); end; - DosBoxDir := GenerateTempDir; + + { DosBoxDir is used inside dosbox.conf as a MOUNT parameter } + if use_temp_dir then + begin + GetDir(0,StartDir); + DosBoxDir := GenerateTempDir; + { All executable test have t.*.pp pattern } + if (paramcount>1) and (copy(paramstr(2),1,2)='-S') then + SourceFileName:=copy(paramstr(2),3,length(paramstr(2))) + else + SourceFileName:=ForceExtension(Paramstr(1),'.pp'); + CopyNeededFiles; + end + else + begin + Writeln('Using ',ParamStr(1)); + DosBoxDir:=ExtractFilePath(ParamStr(1)); + if DosBoxDir='' then + DosBoxDir:=GetCurrentDir+DirectorySeparator; + Writeln('Using DosBoxDir=',DosBoxDir); + { Get rid of previous exicode.txt file } + DeleteIfExists(DosBoxDir + 'EXITCODE.TXT'); + end; try +{$ifdef UseSignals} + Signal(SIGINT,@DosBoxSignal); + Signal(SIGQUIT,@DosBoxSignal); + Signal(SIGTERM,@DosBoxSignal); +{$endif def UseSignals} GenerateDosBoxConf(DosBoxDir); CopyFile(ExtractFilePath(ParamStr(0)) + 'exitcode.exe', DosBoxDir + 'EXITCODE.EXE'); CopyFile(ParamStr(1), DosBoxDir + 'TEST.EXE'); - ExecuteDosBox(DosBoxBinaryPath, DosBoxDir); - ExitCode := ReadExitCode(DosBoxDir); + if need_cwsdpmi then + begin + cwsdpmi_file:=FileSearch('cwsdpmi.exe',GetEnvironmentVariable('PATH')); + if cwsdpmi_file<>'' then + CopyFile(cwsdpmi_file, DosBoxDir + 'CWSDPMI.EXE') + else if verbose then + writeln('cwsdpmi executable missing'); + end; + DosBoxExitStatus:=ExecuteDosBox(DosBoxBinaryPath, DosBoxDir); finally - Cleanup(DosBoxDir); + ExitProc; end; +{$ifdef UseSignals} + if SignalCalled then + begin + Writeln('Signal ',SignalNb,' called'); + end; +{$endif def UseSignals} + ExitProc; + ExitCode:=ReadExitCode(DosBoxDir); + if use_temp_dir then + Cleanup(DosBoxDir); halt(ExitCode); end. diff --git a/tests/utils/dotest.pp b/tests/utils/dotest.pp index 66527ae55f..713f279481 100644 --- a/tests/utils/dotest.pp +++ b/tests/utils/dotest.pp @@ -24,6 +24,7 @@ uses {$ifdef macos} macutils, {$endif} + strutils, teststr, testu, redir, @@ -114,75 +115,20 @@ const TargetCanCompileLibraries : boolean = true; UniqueSuffix: string = ''; -{ Constants used in IsAbsolute function } - TargetHasDosStyleDirectories : boolean = false; - TargetAmigaLike : boolean = false; - TargetIsMacOS : boolean = false; - TargetIsUnix : boolean = false; -{ 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; - -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; +const + NoSharedLibSupportPattern='$nosharedlib'; + TargetHasNoSharedLibSupport = 'msdos,go32v2'; + NoWorkingUnicodeSupport='$nounicode'; + TargetHasNoWorkingUnicodeSupport = 'msdos'; + NoWorkingThread='$nothread'; + TargetHasNoWorkingThreadSupport = 'go32v2,msdos'; + +procedure TranslateConfig(var AConfig: TConfig); begin - FindFirst (F,anyfile,Info); - PathExists:=(DosError=0) and (Info.Attr and Directory=Directory); - FindClose (Info); + AConfig.SkipTarget:=ReplaceText(AConfig.SkipTarget, NoSharedLibSupportPattern, TargetHasNoSharedLibSupport); + AConfig.SkipTarget:=ReplaceText(AConfig.SkipTarget, NoWorkingUnicodeSupport, TargetHasNoWorkingUnicodeSupport); + AConfig.SkipTarget:=ReplaceText(AConfig.SkipTarget, NoWorkingThread, TargetHasNoWorkingThreadSupport); end; @@ -262,60 +208,6 @@ begin 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 #0) and not (p^ in Delims) do begin - Inc(p); - Inc(i); - end; - GetToken:=Copy(s,1,i); - Delete(s,1,i+1); -end; - procedure mkdirtree(const s:string); var SErr, hs : string; @@ -1254,6 +1128,7 @@ var EndTicks, StartTicks : int64; FileList : TStringList; + RelativeToConfigMarker : TObject; function BuildFileList: TStringList; var @@ -1261,44 +1136,61 @@ var index : longint; begin s:=Config.Files; - if length(s) = 0 then + if (length(s) = 0) and (Config.ConfigFileSrc='') then begin Result:=nil; exit; end; Result:=TStringList.Create; - repeat - index:=pos(' ',s); - if index=0 then - LocalFile:=s - else - LocalFile:=copy(s,1,index-1); - Result.Add(LocalFile); - if index=0 then - break; - s:=copy(s,index+1,length(s)-index); - until false; + if s<>'' then + repeat + index:=pos(' ',s); + if index=0 then + LocalFile:=s + else + LocalFile:=copy(s,1,index-1); + Result.Add(LocalFile); + if index=0 then + break; + s:=copy(s,index+1,length(s)-index); + until false; + if Config.ConfigFileSrc<>'' then + begin + if Config.ConfigFileSrc=Config.ConfigFileDst then + Result.AddObject(Config.ConfigFileSrc,RelativeToConfigMarker) + else + Result.AddObject(Config.ConfigFileSrc+'='+Config.ConfigFileDst,RelativeToConfigMarker); + end; end; begin + RelativeToConfigMarker:=TObject.Create; if RemoteAddr='' then begin If UniqueSuffix<>'' then begin FileList:=BuildFileList; if assigned(FileList) then + for i:=0 to FileList.Count-1 do begin - LocalPath:=SplitPath(PPFile[current]); - if Length(LocalPath) > 0 then - LocalPath:=LocalPath+'/'; - for i:=0 to FileList.count-1 do + if FileList.Names[i]<>'' then + begin + LocalFile:=FileList.Names[i]; + RemoteFile:=FileList.ValueFromIndex[i]; + end + else begin LocalFile:=FileList[i]; - CopyFile(LocalPath+LocalFile,TestOutputDir+'/'+LocalFile,false); + RemoteFile:=LocalFile; end; - FileList.Free; + if FileList.Objects[i]=RelativeToConfigMarker then + s:='config/'+LocalFile + else + s:=LocalPath+LocalFile; + CopyFile(s,TestOutputDir+'/'+RemoteFile,false); end; end; + RelativeToConfigMarker.Free; exit(true); end; execres:=true; @@ -1321,6 +1213,7 @@ begin if not execres then begin Verbose(V_normal, 'Could not copy executable '+FileToCopy); + RelativeToConfigMarker.Free; exit(execres); end; FileList:=BuildFileList; @@ -1331,9 +1224,21 @@ begin LocalPath:=LocalPath+'/'; for i:=0 to FileList.count-1 do begin - LocalFile:=FileList[i]; - RemoteFile:=RemotePath+'/'+SplitFileName(LocalFile); - LocalFile:=LocalPath+LocalFile; + if FileList.Names[i]<>'' then + begin + LocalFile:=FileList.Names[i]; + RemoteFile:=FileList.ValueFromIndex[i]; + end + else + begin + LocalFile:=FileList[i]; + RemoteFile:=LocalFile; + end; + RemoteFile:=RemotePath+'/'+SplitFileName(RemoteFile); + if FileList.Objects[i]=RelativeToConfigMarker then + LocalFile:='config/'+LocalFile + else + LocalFile:=LocalPath+LocalFile; if DoVerbose and (rcpprog='pscp') then pref:='-v ' else @@ -1344,12 +1249,14 @@ begin begin Verbose(V_normal, 'Could not copy required file '+LocalFile); FileList.Free; + RelativeToConfigMarker.Free; exit(false); end; end; end; FileList.Free; MaybeCopyFiles:=execres; + RelativeToConfigMarker.Free; end; function RunExecutable:boolean; @@ -1386,6 +1293,9 @@ begin {$I+} ioresult; s:=CurrDir+SplitFileName(TestExe); + { Add -Ssource_file_name for dosbox_wrapper } + if pos('dosbox_wrapper',EmulatorName)>0 then + s:=s+' -S'+PPFile[current]; execres:=ExecuteEmulated(EmulatorName,s,FullExeLogFile,StartTicks,EndTicks); {$I-} ChDir(OldDir); diff --git a/tests/utils/testu.pp b/tests/utils/testu.pp index 0c424aa6f4..ba659ecb99 100644 --- a/tests/utils/testu.pp +++ b/tests/utils/testu.pp @@ -5,11 +5,15 @@ 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 @@ -41,6 +45,8 @@ type Category : string; Note : string; Files : string; + ConfigFileSrc : string; + ConfigFileDst : string; WpoParas : string; WpoPasses : longint; DelFiles : string; @@ -49,6 +55,8 @@ type Const DoVerbose : boolean = false; DoSQL : boolean = false; + MaxLogSize : LongInt = 50000; + procedure TrimB(var s:string); procedure TrimE(var s:string); @@ -57,8 +65,160 @@ 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 (i2) 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 @@ -282,6 +442,25 @@ begin 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 @@ -320,7 +499,8 @@ begin While Not(EOF(F)) do begin ReadLn(F,S); - Result:=Result+S+LineEnding; + if length(Result)