diff --git a/.gitattributes b/.gitattributes
index fb54cc9de0..2ad7d41df4 100644
--- a/.gitattributes
+++ b/.gitattributes
@@ -3744,9 +3744,13 @@ test/runtestsgui.lpr svneol=native#text/plain
test/testglobals.pas svneol=native#text/plain
test/testlpi.pas svneol=native#text/plain
test/testresult-db/createdb.sql svneol=native#text/plain
+test/testresult-db/dbtests.pp svneol=native#text/plain
+test/testresult-db/importtestresults.lpi svneol=native#text/plain
+test/testresult-db/importtestresults.pp svneol=native#text/plain
test/testresult-db/teststr.pp svneol=native#text/plain
test/testresult-db/testsuite.lpi svneol=native#text/plain
test/testresult-db/testsuite.pp svneol=native#text/plain
+test/testresult-db/testu.pp svneol=native#text/plain
test/testresult-db/tresults.pp svneol=native#text/plain
test/testresult-db/utests.pp svneol=native#text/plain
test/testunits.pas svneol=native#text/plain
diff --git a/test/testresult-db/dbtests.pp b/test/testresult-db/dbtests.pp
new file mode 100644
index 0000000000..0efbd38eaf
--- /dev/null
+++ b/test/testresult-db/dbtests.pp
@@ -0,0 +1,448 @@
+{$mode objfpc}
+{$H+}
+
+unit dbtests;
+
+Interface
+
+Uses
+{$ifndef ver1_0}
+ mysql4,
+{$else}
+ mysql,
+{$endif}
+ testu;
+
+{ ---------------------------------------------------------------------
+ High-level access
+ ---------------------------------------------------------------------}
+
+Function GetTestID(Name : string) : Integer;
+Function GetOSID(Name : String) : Integer;
+Function GetCPUID(Name : String) : Integer;
+Function GetCategoryID(Name : String) : Integer;
+Function GetVersionID(Name : String) : Integer;
+Function GetRunID(OSID, CPUID, VERSIONID : Integer; Date : TDateTime) : Integer;
+Function AddRun(OSID, CPUID, VERSIONID, CATEGORYID : Integer; Date : TDateTime) : Integer;
+Function AddTest(Name : String; AddSource : Boolean) : Integer;
+Function UpdateTest(ID : Integer; Info : TConfig; Source : String) : Boolean;
+Function AddTestResult(TestID,RunID,TestRes : Integer;
+ OK, Skipped : Boolean;
+ Log : String) : Integer;
+Function RequireTestID(Name : String): Integer;
+Function CleanTestRun(ID : Integer) : Boolean;
+
+{ ---------------------------------------------------------------------
+ Low-level DB access.
+ ---------------------------------------------------------------------}
+
+
+Type
+ TQueryResult = PMYSQL_RES;
+
+Function ConnectToDatabase(DatabaseName,Host,User,Password : String) : Boolean;
+Procedure DisconnectDatabase;
+Function RunQuery (Qry : String; Var res : TQueryResult) : Boolean ;
+Procedure FreeQueryResult (Res : TQueryResult);
+Function GetResultField (Res : TQueryResult; Id : Integer) : String;
+Function IDQuery(Qry : String) : Integer;
+Function EscapeSQL( S : String) : String;
+Function SQLDate(D : TDateTime) : String;
+
+var
+ RelSrcDir,
+ TestSrcDir : string;
+
+Implementation
+
+Uses
+ SysUtils;
+
+{ ---------------------------------------------------------------------
+ Low-level DB access.
+ ---------------------------------------------------------------------}
+
+
+Var
+ Connection : TMYSQL;
+
+
+Function ConnectToDatabase(DatabaseName,Host,User,Password : String) : Boolean;
+
+Var
+ S : String;
+
+begin
+ Verbose(V_DEBUG,'Connection params : '+DatabaseName+' '+Host+' '+User+' '+Password);
+{$ifdef ver1_0}
+ Result:=mysql_connect(@Connection,PChar(Host),PChar(User),PChar(Password))<>Nil;
+{$else}
+ mysql_init(@Connection);
+ Result:=mysql_real_connect(@Connection,PChar(Host),PChar(User),PChar(Password),Nil,0,Nil,0)<>Nil;
+{$endif}
+ If Not Result then
+ begin
+ S:=Strpas(mysql_error(@connection));
+ Verbose(V_ERROR,'Failed to connect to database : '+S);
+ end
+ else
+ begin
+ Result:=Mysql_select_db(@Connection,Pchar(DatabaseName))>=0;
+ If Not result then
+ begin
+ S:=StrPas(mysql_error(@connection));
+ DisconnectDatabase;
+ Verbose(V_Error,'Failed to select database : '+S);
+ end;
+ end;
+end;
+
+Procedure DisconnectDatabase;
+
+begin
+ mysql_close(@Connection);
+end;
+
+Function RunQuery (Qry : String; Var res : TQueryResult) : Boolean ;
+
+begin
+ Verbose(V_DEBUG,'Running query:'+Qry);
+ Result:=mysql_query(@Connection,PChar(qry))=0;
+ If Not Result then
+ Verbose(V_WARNING,'Query : '+Qry+'Failed : '+Strpas(mysql_error(@connection)))
+ else
+ Res:=Mysql_store_result(@connection);
+end;
+
+Function GetResultField (Res : TQueryResult; Id : Integer) : String;
+
+Var
+ Row : TMYSQL_ROW;
+
+begin
+ if Res=Nil then
+ Result:=''
+ else
+ begin
+ Row:=mysql_fetch_row(Res);
+ If (Row=Nil) or (Row[ID]=Nil) then
+ Result:=''
+ else
+ Result:=strpas(Row[ID]);
+ end;
+ Verbose(V_DEBUG,'Field value '+Result);
+end;
+
+Procedure FreeQueryResult (Res : TQueryResult);
+
+begin
+ mysql_free_result(Res);
+end;
+
+Function IDQuery(Qry : String) : Integer;
+
+Var
+ Res : TQueryResult;
+
+begin
+ Result:=-1;
+ If RunQuery(Qry,Res) then
+ begin
+ Result:=StrToIntDef(GetResultField(Res,0),-1);
+ FreeQueryResult(Res);
+ end;
+end;
+
+Function EscapeSQL( S : String) : String;
+
+
+begin
+ Result:=StringReplace(S,'"','\"',[rfReplaceAll]);
+ Verbose(V_DEBUG,'EscapeSQL : "'+S+'" -> "'+Result+'"');
+end;
+
+
+Function SQLDate(D : TDateTime) : String;
+
+begin
+ Result:=FormatDateTime('YYYY/MM/DD hh:nn:ss',D);
+end;
+
+{ ---------------------------------------------------------------------
+ High-level access
+ ---------------------------------------------------------------------}
+
+
+Function GetTestID(Name : string) : Integer;
+
+Const
+ SFromName = 'SELECT T_ID FROM TESTS WHERE (T_NAME="%s")';
+
+begin
+ Result:=IDQuery(Format(SFromName,[Name]));
+end;
+
+Function GetOSID(Name : String) : Integer;
+
+Const
+ SFromName = 'SELECT TO_ID FROM TESTOS WHERE (TO_NAME="%s")';
+
+begin
+ Result:=IDQuery(Format(SFromName,[Name]));
+end;
+
+Function GetVersionID(Name : String) : Integer;
+
+Const
+ SFromName = 'SELECT TV_ID FROM TESTVERSION WHERE (TV_VERSION="%s")';
+
+begin
+ Result:=IDQuery(Format(SFromName,[Name]));
+end;
+
+Function GetCPUID(Name : String) : Integer;
+
+Const
+ SFromName = 'SELECT TC_ID FROM TESTCPU WHERE (TC_NAME="%s")';
+
+begin
+ Result:=IDQuery(Format(SFromName,[Name]));
+end;
+
+Function GetCategoryID(Name : String) : Integer;
+
+Const
+ SFromName = 'SELECT TCAT_ID FROM TESTCATEGORY WHERE (TCAT_NAME="%s")';
+
+begin
+ Result:=IDQuery(Format(SFromName,[Name]));
+end;
+
+Function GetRunID(OSID, CPUID, VERSIONID : Integer; Date : TDateTime) : Integer;
+
+
+Const
+ SFromIDS = 'SELECT TU_ID FROM TESTRUN WHERE '+
+ ' (TU_OS_FK=%d) '+
+ ' AND (TU_CPU_FK=%d) '+
+ ' AND (TU_VERSION_FK=%d) '+
+ ' AND (TU_DATE="%s")';
+
+begin
+ Result:=IDQuery(Format(SFromIDS,[OSID,CPUID,VERSIONID,SQLDate(Date)]));
+end;
+
+Function AddRun(OSID, CPUID, VERSIONID, CATEGORYID : Integer; Date : TDateTime) : Integer;
+
+Const
+ SInsertRun = 'INSERT INTO TESTRUN '+
+ '(TU_OS_FK,TU_CPU_FK,TU_VERSION_FK,TU_CATEGORY_FK,TU_DATE)'+
+ ' VALUES '+
+ '(%d,%d,%d,%d,"%s")';
+
+Var
+ Res : TQueryResult;
+
+begin
+ If RunQuery(Format(SInsertRun,[OSID,CPUID,VERSIONID,CATEGORYID,SQLDate(Date)]),Res) then
+ Result:=mysql_insert_id(@connection)
+ else
+ Result:=-1;
+end;
+
+function posr(c : Char; const s : AnsiString) : integer;
+var
+ i : integer;
+begin
+ i := length(s);
+ while (i>0) and (s[i] <> c) do dec(i);
+ Result := i;
+end;
+
+function GetUnitTestConfig(const fn : string; var r : TConfig) : Boolean;
+var
+ Path : string;
+ ClassName : string;
+ MethodName : string;
+ slashpos : integer;
+ FileName : string;
+ s : string;
+ t : text;
+begin
+ Result := False;
+ FillChar(r,sizeof(r),0);
+ if pos('.',fn) > 0 then exit; // This is normally not a unit-test
+ slashpos := posr('/',fn);
+ if slashpos < 1 then exit;
+ MethodName := copy(fn,slashpos+1,length(fn));
+ Path := copy(fn,1,slashpos-1);
+ slashpos := posr('/',Path);
+ if slashpos > 0 then
+ begin
+ ClassName := copy(Path,slashpos+1,length(Path));
+ Path := copy(Path,1,slashpos-1);
+ end
+ else
+ begin
+ ClassName := Path;
+ path := '.';
+ end;
+ if upper(ClassName[1])<>'T' then exit;
+ FileName := TestSrcDir+RelSrcDir+Path+DirectorySeparator+copy(lowercase(ClassName),2,length(classname));
+ if FileExists(FileName+'.pas') then
+ FileName := FileName + '.pas'
+ else if FileExists(FileName+'.pp') then
+ FileName := FileName + '.pp'
+ else exit;
+
+ Verbose(V_Debug,'Reading '+FileName);
+ assign(t,FileName);
+ {$I-}
+ reset(t);
+ {$I+}
+ if ioresult<>0 then
+ begin
+ Verbose(V_Error,'Can''t open '+FileName);
+ exit;
+ end;
+ while not eof(t) do
+ begin
+ readln(t,s);
+
+ if s<>'' then
+ begin
+ TrimB(s);
+ if SameText(copy(s,1,9),'PROCEDURE') then
+ begin
+ if pos(';',s)>11 then
+ begin
+ s := copy(s,11,pos(';',s)-11);
+ TrimB(s);
+ if SameText(s,ClassName+'.'+MethodName) then
+ begin
+ Result := True;
+ r.Note:= 'unittest';
+ end;
+ end;
+ end;
+ end;
+ end;
+ close(t);
+end;
+
+Function AddTest(Name : String; AddSource : Boolean) : Integer;
+
+Const
+ SInsertTest = 'INSERT INTO TESTS (T_NAME,T_ADDDATE)'+
+ ' VALUES ("%s",NOW())';
+
+Var
+ Info : TConfig;
+ Res : TQueryResult;
+
+begin
+ Result:=-1;
+ If (FileExists(TestSrcDir+RelSrcDir+Name) and
+ GetConfig(TestSrcDir+RelSrcDir+Name,Info)) or
+ GetUnitTestConfig(Name,Info) then
+ begin
+ If RunQuery(Format(SInsertTest,[Name]),Res) then
+ begin
+ Result:=GetTestID(Name);
+ If Result=-1 then
+ Verbose(V_WARNING,'Could not find newly added test!')
+ else
+ If AddSource then
+ UpdateTest(Result,Info,GetFileContents(Name))
+ else
+ UpdateTest(Result,Info,'');
+ end
+ end
+ else
+ Verbose(V_ERROR,'Could not find test "'+Name+'" or info about this test.');
+end;
+
+Const
+ B : Array[Boolean] of String = ('-','+');
+
+Function UpdateTest(ID : Integer; Info : TConfig; Source : String) : Boolean;
+
+Const
+ SUpdateTest = 'Update TESTS SET '+
+ ' T_CPU="%s", T_OS="%s", T_VERSION="%s",'+
+ ' T_GRAPH="%s", T_INTERACTIVE="%s", T_RESULT=%d,'+
+ ' T_FAIL="%s", T_RECOMPILE="%s", T_NORUN="%s",'+
+ ' T_NEEDLIBRARY="%s", T_KNOWNRUNERROR=%d,'+
+ ' T_KNOWN="%s", T_NOTE="%s", T_OPTS = "%s"'+
+ ' %s '+
+ 'WHERE'+
+ ' T_ID=%d';
+
+
+Var
+ Qry : String;
+ Res : TQueryResult;
+
+begin
+ If Source<>'' then
+ begin
+ Source:=EscapeSQL(Source);
+ Source:=', T_SOURCE="'+Source+'"';
+ end;
+ With Info do
+ Qry:=Format(SUpdateTest,[EscapeSQL(NeedCPU),'',EscapeSQL(MinVersion),
+ B[usesGraph],B[IsInteractive],ResultCode,
+ B[ShouldFail],B[NeedRecompile],B[NoRun],
+ B[NeedLibrary],KnownRunError,
+ B[IsKnownCompileError],EscapeSQL(Note),EscapeSQL(NeedOptions),
+ Source,
+ ID
+ ]);
+ Result:=RunQuery(Qry,res)
+end;
+
+Function AddTestResult(TestID,RunID,TestRes : Integer;
+ OK, Skipped : Boolean;
+ Log : String) : Integer;
+
+Const
+ SInsertRes='Insert into TESTRESULTS '+
+ '(TR_TEST_FK,TR_TESTRUN_FK,TR_OK,TR_SKIP,TR_RESULT,TR_LOG) '+
+ ' VALUES '+
+ '(%d,%d,"%s","%s",%d,"%s") ';
+
+Var
+ Qry : String;
+ Res : TQueryResult;
+
+begin
+ Result:=-1;
+ Qry:=Format(SInsertRes,
+ [TestID,RunID,B[OK],B[Skipped],TestRes,EscapeSQL(Log)]);
+ If RunQuery(Qry,Res) then
+ Result:=mysql_insert_id(@connection);
+end;
+
+Function RequireTestID(Name : String): Integer;
+
+begin
+ Result:=GetTestID(Name);
+ If Result=-1 then
+ Result:=AddTest(Name,FileExists(Name));
+ If Result=-1 then
+ Verbose(V_WARNING,'Could not find or create entry for test '+Name);
+end;
+
+Function CleanTestRun(ID : Integer) : Boolean;
+
+Const
+ SDeleteRun = 'DELETE FROM TESTRESULTS WHERE TR_TESTRUN_FK=%d';
+
+Var
+ Res : TQueryResult;
+
+begin
+ Result:=RunQuery(Format(SDeleteRun,[ID]),Res);
+end;
+
+end.
diff --git a/test/testresult-db/importtestresults.lpi b/test/testresult-db/importtestresults.lpi
new file mode 100644
index 0000000000..4ba2607145
--- /dev/null
+++ b/test/testresult-db/importtestresults.lpi
@@ -0,0 +1,137 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/test/testresult-db/importtestresults.pp b/test/testresult-db/importtestresults.pp
new file mode 100644
index 0000000000..9970bb1fcc
--- /dev/null
+++ b/test/testresult-db/importtestresults.pp
@@ -0,0 +1,412 @@
+{
+ This file is part of the Free Pascal test suite.
+ Copyright (c) 2002 by the Free Pascal development team.
+
+ This program generates a digest
+ of the last tests run.
+
+ 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.
+
+ **********************************************************************}
+
+{$mode objfpc}
+{$h+}
+
+program importtestresults;
+
+uses
+ sysutils,teststr,testu,tresults,dbtests;
+
+
+Var
+ StatusCount : Array[TTestStatus] of Integer;
+ UnknownLines : integer;
+
+
+Procedure ExtractTestFileName(Var Line : string);
+
+Var I : integer;
+
+begin
+ I:=Pos(' ',Line);
+ If (I<>0) then
+ Line:=Copy(Line,1,I-1);
+end;
+
+Function Analyse(Var Line : string; Var Status : TTestStatus) : Boolean;
+
+Var
+ TS : TTestStatus;
+
+begin
+ Result:=False;
+ For TS:=FirstStatus to LastStatus do
+ begin
+ Result:=Pos(StatusText[TS],Line)=1;
+ If Result then
+ begin
+ Status:=TS;
+ Delete(Line,1,Length(StatusText[TS]));
+ ExtractTestFileName(Line);
+ Break;
+ end;
+ end;
+end;
+
+Type
+
+TConfigOpt = (
+ coDatabaseName,
+ soHost,
+ coUserName,
+ coPassword,
+ coLogFile,
+ coOS,
+ coCPU,
+ coCategory,
+ coVersion,
+ coDate,
+ coSubmitter,
+ coMachine,
+ coComment,
+ coTestSrcDir,
+ coRelSrcDir,
+ coVerbose
+ );
+
+Const
+
+ConfigStrings : Array [TConfigOpt] of string = (
+ 'databasename',
+ 'host',
+ 'username',
+ 'password',
+ 'logfile',
+ 'os',
+ 'cpu',
+ 'widgetset',
+ 'category',
+ 'version',
+ 'date',
+ 'submitter',
+ 'machine',
+ 'comment',
+ 'testsrcdir',
+ 'relsrcdir',
+ 'verbose'
+);
+
+ConfigOpts : Array[TConfigOpt] of char
+ = ('d','h','u','p','l','o','c','w','a','v','t','s','m','C','S','r','V');
+
+Var
+ TestOS,
+ TestCPU,
+ TestVersion,
+ TestCategory,
+ DatabaseName,
+ HostName,
+ UserName,
+ Password,
+ ResultsFileName,
+ Submitter,
+ Machine,
+ Comment : String;
+ TestDate : TDateTime;
+
+Procedure SetOpt (O : TConfigOpt; Value : string);
+var
+ year,month,day,min,hour : word;
+begin
+ Case O of
+ coDatabaseName : DatabaseName:=Value;
+ soHost : HostName:=Value;
+ coUserName : UserName:=Value;
+ coPassword : Password:=Value;
+ coLogFile : ResultsFileName:=Value;
+ coOS : TestOS:=Value;
+ coCPU : TestCPU:=Value;
+ coCategory : TestCategory:=Value;
+ coVersion : TestVersion:=Value;
+ coDate :
+ begin
+ { Formated like YYYYMMDDhhmm }
+ if Length(value)=12 then
+ begin
+ year:=StrToInt(Copy(value,1,4));
+ month:=StrToInt(Copy(value,5,2));
+ day:=StrToInt(Copy(Value,7,2));
+ hour:=StrToInt(Copy(Value,9,2));
+ min:=StrToInt(Copy(Value,11,2));
+ TestDate:=EncodeDate(year,month,day)+EncodeTime(hour,min,0,0);
+ end
+ else
+ Verbose(V_Error,'Error in date format, use YYYYMMDDhhmm');
+ end;
+ coSubmitter : Submitter:=Value;
+ coMachine : Machine:=Value;
+ coComment : Comment:=Value;
+ coVerbose : DoVerbose:=true;
+ coTestSrcDir :
+ begin
+ TestSrcDir:=Value;
+ if (TestSrcDir<>'') and (TestSrcDir[length(TestSrcDir)]<>'/') then
+ TestSrcDir:=TestSrcDir+'/';
+ end;
+ coRelSrcDir :
+ begin
+ RelSrcDir:=Value;
+ if (RelSrcDir<>'') and (RelSrcDir[length(RelSrcDir)]<>'/') then
+ RelSrcDir:=RelSrcDir+'/';
+ if (RelSrcDir<>'') and (RelSrcDir[1]='/') then
+ RelSrcDir:=copy(RelSrcDir,2,length(RelSrcDir)-1);
+ end;
+ end;
+end;
+
+Function ProcessOption(S: String) : Boolean;
+
+Var
+ N : String;
+ I : Integer;
+ co : TConfigOpt;
+
+begin
+ Verbose(V_DEBUG,'Processing option: '+S);
+ I:=Pos('=',S);
+ Result:=(I<>0);
+ If Result then
+ begin
+ N:=Copy(S,1,I-1);
+ Delete(S,1,I);
+ For co:=low(TConfigOpt) to high(TConfigOpt) do
+ begin
+ Result:=CompareText(ConfigStrings[co],N)=0;
+ If Result then
+ Break;
+ end;
+ end;
+ If Result then
+ SetOpt(co,S)
+ else
+ Verbose(V_ERROR,'Unknown option : '+n+S);
+end;
+
+Procedure ProcessConfigfile(FN : String);
+
+Var
+ F : Text;
+ S : String;
+ I : Integer;
+
+begin
+ // Set the default value for old digests without RelSrcDir to the rtl/compiler
+ // testsuite
+ RelSrcDir:='tests/';
+ If Not FileExists(FN) Then
+ Exit;
+ Verbose(V_DEBUG,'Parsing config file: '+FN);
+ Assign(F,FN);
+ {$i-}
+ Reset(F);
+ If IOResult<>0 then
+ Exit;
+ {$I+}
+ While not(EOF(F)) do
+ begin
+ ReadLn(F,S);
+ S:=trim(S);
+ I:=Pos('#',S);
+ If I<>0 then
+ S:=Copy(S,1,I-1);
+ If (S<>'') then
+ ProcessOption(S);
+ end;
+ Close(F);
+end;
+
+Procedure ProcessCommandLine;
+
+Var
+ I : Integer;
+ O : String;
+ c,co : TConfigOpt;
+ Found : Boolean;
+
+begin
+ I:=1;
+ While I<=ParamCount do
+ begin
+ O:=Paramstr(I);
+ Found:=Length(O)=2;
+ If Found then
+ For co:=low(TConfigOpt) to high(TConfigOpt) do
+ begin
+ Found:=(O[2]=ConfigOpts[co]);
+ If Found then
+ begin
+ c:=co;
+ Break;
+ end;
+ end;
+ If Not Found then
+ Verbose(V_ERROR,'Illegal command-line option : '+O)
+ else
+ begin
+ Found:=(I0 then
+ Verbose(V_Error,'Unable to open log file'+ResultsFileName);
+{$i+}
+ while not eof(logfile) do
+ begin
+ readln(logfile,line);
+ If analyse(line,TS) then
+ begin
+ Verbose(V_NORMAL,'Analysing result for test '+Line);
+ Inc(StatusCount[TS]);
+ If Not ExpectRun[TS] then
+ begin
+ ID:=RequireTestID(Line);
+ If (ID<>-1) then
+ begin
+ If Not (TestOK[TS] or TestSkipped[TS]) then
+ begin
+ TestLog:=GetExecuteLog(Line);
+ if pos(failed_to_compile,TestLog)=1 then
+ TestLog:=GetLog(Line);
+ end
+ else
+ TestLog:='';
+ AddTestResult(ID,TestRunID,Ord(TS),TestOK[TS],TestSkipped[TS],TestLog);
+ end;
+ end
+ end
+ else
+ Inc(UnknownLines);
+ end;
+ close(logfile);
+end;
+
+procedure ProcessResultsFile;
+begin
+end;
+
+procedure UpdateTestRun;
+
+ var
+ i : TTestStatus;
+ qry : string;
+ res : TQueryResult;
+
+ begin
+ qry:='UPDATE TESTRUN SET ';
+ for i:=low(TTestStatus) to high(TTestStatus) do
+ qry:=qry+format('%s=%d, ',[SQLField[i],StatusCount[i]]);
+ qry:=qry+format('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]);
+ RunQuery(Qry,res)
+ end;
+
+
+begin
+ ProcessConfigFile('dbdigest.cfg');
+ ProcessCommandLine;
+ If ResultsFileName<>'' then
+ begin
+ ConnectToDatabase(DatabaseName,HostName,UserName,Password);
+ GetIDs;
+ ProcessResultsFile(ResultsFileName);
+ UpdateTestRun;
+ end
+ else
+ Verbose(V_ERROR,'Missing log file name');
+end.
diff --git a/test/testresult-db/testu.pp b/test/testresult-db/testu.pp
new file mode 100644
index 0000000000..8f8a86b828
--- /dev/null
+++ b/test/testresult-db/testu.pp
@@ -0,0 +1,300 @@
+{$mode objfpc}
+{$h+}
+
+unit testu;
+
+Interface
+
+{ ---------------------------------------------------------------------
+ utility functions, shared by several programs of the test suite
+ ---------------------------------------------------------------------}
+
+type
+ TVerboseLevel=(V_Abort,V_Error,V_Warning,V_Normal,V_Debug);
+
+ TConfig = record
+ NeedOptions,
+ NeedCPU,
+ SkipCPU,
+ SkipEmu,
+ NeedTarget,
+ SkipTarget,
+ MinVersion,
+ MaxVersion,
+ KnownRunNote,
+ KnownCompileNote : string;
+ ResultCode : longint;
+ KnownRunError : longint;
+ KnownCompileError : longint;
+ NeedRecompile : boolean;
+ NeedLibrary : boolean;
+ IsInteractive : boolean;
+ IsKnownRunError,
+ IsKnownCompileError : boolean;
+ NoRun : boolean;
+ UsesGraph : boolean;
+ ShouldFail : boolean;
+ Timeout : longint;
+ Category : string;
+ Note : string;
+ Files : string;
+ end;
+
+Const
+ DoVerbose : boolean = false;
+
+procedure TrimB(var s:string);
+procedure TrimE(var s:string);
+function upper(const s : string) : string;
+procedure Verbose(lvl:TVerboseLevel;const s:string);
+function GetConfig(const fn:string;var r:TConfig):boolean;
+Function GetFileContents (FN : String) : String;
+
+Implementation
+
+procedure Verbose(lvl:TVerboseLevel;const s:string);
+begin
+ case lvl of
+ V_Normal :
+ writeln(s);
+ V_Debug :
+ if DoVerbose then
+ writeln('Debug: ',s);
+ V_Warning :
+ writeln('Warning: ',s);
+ V_Error :
+ begin
+ writeln('Error: ',s);
+ halt(1);
+ end;
+ V_Abort :
+ begin
+ writeln('Abort: ',s);
+ halt(0);
+ end;
+ end;
+end;
+
+procedure TrimB(var s:string);
+begin
+ while (s<>'') and (s[1] in [' ',#9]) do
+ delete(s,1,1);
+end;
+
+
+procedure TrimE(var s:string);
+begin
+ while (s<>'') and (s[length(s)] in [' ',#9]) do
+ delete(s,length(s),1);
+end;
+
+
+function upper(const s : string) : string;
+var
+ i,l : longint;
+
+begin
+ L:=Length(S);
+ SetLength(upper,l);
+ for i:=1 to l do
+ if s[i] in ['a'..'z'] then
+ upper[i]:=char(byte(s[i])-32)
+ else
+ upper[i]:=s[i];
+end;
+
+function GetConfig(const fn:string;var r:TConfig):boolean;
+var
+ t : text;
+ part,code : integer;
+ l : longint;
+ s,res : string;
+
+ function GetEntry(const entry:string):boolean;
+ var
+ i : longint;
+ begin
+ Getentry:=false;
+ Res:='';
+ if Upper(Copy(s,1,length(entry)))=Upper(entry) then
+ begin
+ Delete(s,1,length(entry));
+ TrimB(s);
+ if (s<>'') then
+ begin
+ if (s[1]='=') then
+ begin
+ delete(s,1,1);
+ i:=pos('}',s);
+ if i=0 then
+ i:=255
+ else
+ dec(i);
+ res:=Copy(s,1,i);
+ TrimB(res);
+ TrimE(res);
+ end;
+ Verbose(V_Debug,'Config: '+Entry+' = "'+Res+'"');
+ GetEntry:=true;
+ end;
+ end;
+ end;
+
+begin
+ FillChar(r,sizeof(r),0);
+ GetConfig:=false;
+ Verbose(V_Debug,'Reading '+fn);
+ assign(t,fn);
+ {$I-}
+ reset(t);
+ {$I+}
+ if ioresult<>0 then
+ begin
+ Verbose(V_Error,'Can''t open '+fn);
+ exit;
+ end;
+ r.Note:='';
+ while not eof(t) do
+ begin
+ readln(t,s);
+ if Copy(s,1,3)=#$EF#$BB#$BF then
+ delete(s,1,3);
+ if s<>'' then
+ begin
+ TrimB(s);
+ if s[1]='{' then
+ begin
+ delete(s,1,1);
+ TrimB(s);
+ if (s<>'') and (s[1]='%') then
+ begin
+ delete(s,1,1);
+ if GetEntry('OPT') then
+ r.NeedOptions:=res
+ else
+ if GetEntry('TARGET') then
+ r.NeedTarget:=res
+ else
+ if GetEntry('SKIPTARGET') then
+ r.SkipTarget:=res
+ else
+ if GetEntry('CPU') then
+ r.NeedCPU:=res
+ else
+ if GetEntry('SKIPCPU') then
+ r.SkipCPU:=res
+ else
+ if GetEntry('SKIPEMU') then
+ r.SkipEmu:=res
+ else
+ if GetEntry('VERSION') then
+ r.MinVersion:=res
+ else
+ if GetEntry('MAXVERSION') then
+ r.MaxVersion:=res
+ else
+ if GetEntry('RESULT') then
+ Val(res,r.ResultCode,code)
+ else
+ if GetEntry('GRAPH') then
+ r.UsesGraph:=true
+ else
+ if GetEntry('FAIL') then
+ r.ShouldFail:=true
+ else
+ if GetEntry('RECOMPILE') then
+ r.NeedRecompile:=true
+ else
+ if GetEntry('NORUN') then
+ r.NoRun:=true
+ else
+ if GetEntry('NEEDLIBRARY') then
+ r.NeedLibrary:=true
+ else
+ if GetEntry('KNOWNRUNERROR') then
+ begin
+ r.IsKnownRunError:=true;
+ if res<>'' then
+ begin
+ val(res,l,code);
+ if code>1 then
+ begin
+ part:=code;
+ val(copy(res,1,code-1),l,code);
+ delete(res,1,part);
+ end;
+ if code=0 then
+ r.KnownRunError:=l;
+ if res<>'' then
+ r.KnownRunNote:=res;
+ end;
+ end
+ else
+ if GetEntry('KNOWNCOMPILEERROR') then
+ begin
+ r.IsKnownCompileError:=true;
+ if res<>'' then
+ begin
+ val(res,l,code);
+ if code>1 then
+ begin
+ part:=code;
+ val(copy(res,1,code-1),l,code);
+ delete(res,1,part);
+ end;
+ if code=0 then
+ r.KnownCompileError:=l;
+ if res<>'' then
+ r.KnownCompileNote:=res;
+ end;
+ end
+ else
+ if GetEntry('INTERACTIVE') then
+ r.IsInteractive:=true
+ else
+ if GetEntry('NOTE') then
+ begin
+ R.Note:='Note: '+res;
+ Verbose(V_Normal,r.Note);
+ end
+ else
+ if GetEntry('TIMEOUT') then
+ Val(res,r.Timeout,code)
+ else
+ if GetEntry('FILES') then
+ r.Files:=res
+ else
+ Verbose(V_Error,'Unknown entry: '+s);
+ end;
+ end
+ else
+ break;
+ end;
+ end;
+ close(t);
+ GetConfig:=true;
+end;
+
+Function GetFileContents (FN : String) : String;
+
+Var
+ F : Text;
+ S : String;
+
+begin
+ Result:='';
+ Assign(F,FN);
+ {$I-}
+ Reset(F);
+ If IOResult<>0 then
+ Exit;
+ {$I+}
+ While Not(EOF(F)) do
+ begin
+ ReadLn(F,S);
+ Result:=Result+S+LineEnding;
+ end;
+ Close(F);
+end;
+
+end.