summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorpierre <pierre@3ad0048d-3df7-0310-abae-a5850022a9f2>2018-06-15 20:25:30 +0000
committerpierre <pierre@3ad0048d-3df7-0310-abae-a5850022a9f2>2018-06-15 20:25:30 +0000
commita7f59dc5a91be14936a1838ed10265365d983e2e (patch)
tree04d7db6227378605f61cc99ae9b7ddcbf83f905f
parent41a6fb16fc383fba46f8c7af12b60a2e8f8fd815 (diff)
downloadfpc-a7f59dc5a91be14936a1838ed10265365d983e2e.tar.gz
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
-rw-r--r--tests/utils/dbdigest.pp12
-rw-r--r--tests/utils/dosbox/dosbox.conf8
-rw-r--r--tests/utils/dosbox/dosbox_wrapper.pas550
-rw-r--r--tests/utils/dotest.pp230
-rw-r--r--tests/utils/testu.pp182
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)<MaxLogSize then
+ Result:=Result+S+LineEnding;
end;
end
else if IsFirst then
diff --git a/tests/utils/dosbox/dosbox.conf b/tests/utils/dosbox/dosbox.conf
index 1d45b287fc..363c54c91f 100644
--- a/tests/utils/dosbox/dosbox.conf
+++ b/tests/utils/dosbox/dosbox.conf
@@ -32,6 +32,7 @@ waitonerror=true
priority=higher,normal
mapperfile=mapper-0.74.map
usescancodes=true
+disablesplash=true
[dosbox]
# language: Select another language file.
@@ -77,8 +78,8 @@ scaler=normal2x
# cycleup: Amount of cycles to decrease/increase with keycombo.(CTRL-F11/CTRL-F12)
# cycledown: Setting it lower than 100 will be a percentage.
-#core=auto
-core=dynamic
+core=auto
+#core=dynamic
cputype=auto
#cycles=auto
cycles=max
@@ -232,6 +233,7 @@ xms=true
ems=true
umb=true
keyboardlayout=auto
+copy_con_to_file=$wrapper_output
[ipx]
# ipx: Enable ipx over UDP/IP emulation.
@@ -247,4 +249,4 @@ ipx=false
mount c $DosBoxDir
c:
exitcode test.exe
-exit
+$exit
diff --git a/tests/utils/dosbox/dosbox_wrapper.pas b/tests/utils/dosbox/dosbox_wrapper.pas
index cd7f345606..44452916f1 100644
--- a/tests/utils/dosbox/dosbox_wrapper.pas
+++ b/tests/utils/dosbox/dosbox_wrapper.pas
@@ -1,7 +1,30 @@
{$MODE objfpc}{$H+}
uses
- SysUtils, StrUtils, Process;
+ SysUtils, StrUtils,
+{$ifdef UseSignals}
+ signals,
+{$endif def UseSignals}
+ testu, classes,
+ Process;
+
+const
+ use_temp_dir : boolean = true;
+ need_cwsdpmi : boolean = false;
+ cwsdpmi_file : string = '';
+ hide_execution : boolean = true;
+ do_exit : boolean = true;
+ verbose : boolean = false;
+ DosBoxProcess: TProcess = nil;
+ dosbox_timeout : integer = 400; { default timeout in seconds }
+ DosBoxExitStatus : integer = -1;
+var
+ OutputFileName : String;
+ SourceFileName : String;
+ StartDir, DosBoxDir: string;
+ ExitCode: Integer = 255;
+ DosBoxBinaryPath: string;
+ TmpFileList : TStringList;
function GenerateTempDir: string;
var
@@ -13,6 +36,8 @@ begin
repeat
try
FileName := TempDir + 'dosboxwrappertmp_' + IntToStr(Random(100000));
+ if verbose then
+ writeln('Trying to create directory ',Filename);
MkDir(FileName);
Done := True;
except
@@ -20,7 +45,10 @@ begin
begin
{ 5 = Access Denied, returned when a file is duplicated }
if E.ErrorCode <> 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) + ' <executable>');
+ Writeln('Usage: ' + ParamStr(0) + ' <executable> (-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<length(s)) and not(s[i] in ['/','\'{$IFDEF MACOS},':'{$ENDIF}]) do
- inc(i);
- if s[i] in ['/','\'{$IFDEF MACOS},':'{$ENDIF}] then
- dec(i);
- SplitBasePath:=Copy(s,1,i);
-end;
-
-Function SplitFileName(const s:string):string;
-var
- p : dirstr;
- n : namestr;
- e : extstr;
-begin
- FSplit(s,p,n,e);
- SplitFileName:=n+e;
-end;
-
-Function SplitFileBase(const s:string):string;
-var
- p : dirstr;
- n : namestr;
- e : extstr;
-begin
- FSplit(s,p,n,e);
- SplitFileBase:=n;
-end;
-
-Function SplitFileExt(const s:string):string;
-var
- p : dirstr;
- n : namestr;
- e : extstr;
-begin
- FSplit(s,p,n,e);
- SplitFileExt:=e;
-end;
-
-
function ForceExtension(Const HStr,ext:String):String;
{
Return a filename which certainly has the extension ext
@@ -339,24 +231,6 @@ begin
ForceExtension:=Copy(Hstr,1,j-1);
end;
-type
- TCharSet = set of char;
-
-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;
-
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 (i<length(s)) and not(s[i] in ['/','\'{$IFDEF MACOS},':'{$ENDIF}]) do
+ inc(i);
+ if s[i] in ['/','\'{$IFDEF MACOS},':'{$ENDIF}] then
+ dec(i);
+ SplitBasePath:=Copy(s,1,i);
+end;
+
+Function SplitFileName(const s:string):string;
+var
+ p : dirstr;
+ n : namestr;
+ e : extstr;
+begin
+ FSplit(s,p,n,e);
+ SplitFileName:=n+e;
+end;
+
+Function SplitFileBase(const s:string):string;
+var
+ p : dirstr;
+ n : namestr;
+ e : extstr;
+begin
+ FSplit(s,p,n,e);
+ SplitFileBase:=n;
+end;
+
+Function SplitFileExt(const s:string):string;
+var
+ p : dirstr;
+ n : namestr;
+ e : extstr;
+begin
+ FSplit(s,p,n,e);
+ SplitFileExt:=e;
+end;
+
+
+Function FileExists (Const F : String) : Boolean;
+{
+ Returns True if the file exists, False if not.
+}
+Var
+ info : searchrec;
+begin
+ FindFirst (F,anyfile,Info);
+ FileExists:=DosError=0;
+ FindClose (Info);
+end;
+
+
+Function PathExists (Const F : String) : Boolean;
+{
+ Returns True if the file exists, False if not.
+}
+Var
+ info : searchrec;
+begin
+ FindFirst (F,anyfile,Info);
+ PathExists:=(DosError=0) and (Info.Attr and Directory=Directory);
+ FindClose (Info);
+end;
+
+{ extracted from rtl/macos/macutils.inc }
+
+function IsMacFullPath (const path: string): Boolean;
+ begin
+ if Pos(':', path) = 0 then {its partial}
+ IsMacFullPath := false
+ else if path[1] = ':' then
+ IsMacFullPath := false
+ else
+ IsMacFullPath := true
+ end;
+
+
+Function IsAbsolute (Const F : String) : boolean;
+{
+ Returns True if the name F is a absolute file name
+}
+begin
+ IsAbsolute:=false;
+ if TargetHasDosStyleDirectories then
+ begin
+ if (F[1]='/') or (F[1]='\') then
+ IsAbsolute:=true;
+ if (Length(F)>2) and (F[2]=':') and ((F[3]='\') or (F[3]='/')) then
+ IsAbsolute:=true;
+ end
+ else if TargetAmigaLike then
+ begin
+ if (length(F)>0) and (Pos(':',F) <> 0) then
+ IsAbsolute:=true;
+ end
+ else if TargetIsMacOS then
+ begin
+ IsAbsolute:=IsMacFullPath(F);
+ end
+ { generic case }
+ else if (F[1]='/') then
+ IsAbsolute:=true;
+end;
+
procedure Verbose(lvl:TVerboseLevel;const s:string);
begin
case lvl of
@@ -283,6 +443,25 @@ begin
if GetEntry('FILES') then
r.Files:=res
else
+ if GetEntry('CONFIGFILE') then
+ begin
+ l:=Pos(' ',res);
+ if l>0 then
+ begin
+ r.ConfigFileSrc:=Copy(res,1,l-1);
+ r.ConfigFileDst:=Copy(res,l+1,Length(res)-l+1);
+ if r.ConfigFileSrc='' then
+ Verbose(V_Error,'Config file source is empty');
+ if r.ConfigFileDst='' then
+ Verbose(V_Error,'Config file destination is empty');
+ end
+ else
+ begin
+ r.ConfigFileSrc:=res;
+ r.ConfigFileDst:=res;
+ end;
+ end
+ else
if GetEntry('WPOPARAS') then
r.wpoparas:=res
else
@@ -320,7 +499,8 @@ begin
While Not(EOF(F)) do
begin
ReadLn(F,S);
- Result:=Result+S+LineEnding;
+ if length(Result)<MaxLogSize then
+ Result:=Result+S+LineEnding;
end;
Close(F);
end;