From 32f74d23f1dc1d6ff3e73318e221d890da28158f Mon Sep 17 00:00:00 2001 From: michael Date: Sun, 10 Aug 2014 14:58:11 +0000 Subject: [PATCH] * Move to postgresql git-svn-id: trunk@28359 - --- tests/utils/dbdigest.pp | 56 ++-- tests/utils/dbtests.pp | 254 +++++++++--------- tests/utils/testsuite/testsuite.lpi | 388 ++++++++++++++++++---------- tests/utils/testsuite/testsuite.pp | 2 +- tests/utils/testsuite/utests.pp | 171 ++++++------ 5 files changed, 475 insertions(+), 396 deletions(-) diff --git a/tests/utils/dbdigest.pp b/tests/utils/dbdigest.pp index 3f042079c2..ea070ba5ba 100644 --- a/tests/utils/dbdigest.pp +++ b/tests/utils/dbdigest.pp @@ -533,6 +533,7 @@ begin begin readln(logfile,line); fullline:=line; + ts:=stFailedToCompile; If analyse(line,TS) then begin Verbose(V_NORMAL,'Analysing result for test '+Line); @@ -599,7 +600,6 @@ procedure UpdateTestRun; var i : TTestStatus; qry : string; - res : TQueryResult; begin qry:='UPDATE TESTRUN SET '; @@ -620,8 +620,7 @@ procedure UpdateTestRun; 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]); - if RunQuery(Qry,res) then - FreeQueryResult(Res); + ExecuteQuery(Qry,False); end; function GetTestConfigId : Integer; @@ -646,7 +645,6 @@ var qry : string; firstRunID, lastRunID,PrevRunID : Integer; RunCount : Integer; - res : TQueryResult; AddCount : boolean; begin @@ -659,9 +657,7 @@ begin Verbose(V_Warning,format('FirstRunID changed from %d to %d',[FirstRunID,TestRunID])); qry:=format('UPDATE TESTCONFIG SET TCONF_FIRST_RUN_FK=%d WHERE TCONF_ID=%d', [TestRunID,ConfigID]); - if RunQuery(qry,res) then - FreeQueryResult(res) - else + if Not ExecuteQuery(qry,False) then Verbose(V_Warning,'Update of LastRunID failed'); end; qry:=format('SELECT TCONF_LAST_RUN_FK FROM TESTCONFIG WHERE TCONF_ID=%d',[ConfigID]); @@ -670,9 +666,7 @@ begin begin qry:=format('UPDATE TESTCONFIG SET TCONF_LAST_RUN_FK=%d WHERE TCONF_ID=%d', [TestRunID,ConfigID]); - if RunQuery(qry,res) then - FreeQueryResult(res) - else + if not ExecuteQuery(qry,False) then Verbose(V_Warning,'Update of LastRunID failed'); end else @@ -681,14 +675,12 @@ begin PrevRunID:=IDQuery(qry); if TestRunID<>PrevRunID then begin - qry:=format('UPDATE TESTCONFIG SET TCONF_NEW_RUN_FK=%d WHERE TCONF_ID=%d', - [TestRunID,ConfigID]); - if RunQuery(qry,res) then - FreeQueryResult(res) - else - Verbose(V_Warning,'Update of LastRunID failed'); - AddTestHistoryEntry(TestRunID,PrevRunID); - AddCount:=true; + qry:=format('UPDATE TESTCONFIG SET TCONF_NEW_RUN_FK=%d WHERE TCONF_ID=%d', + [TestRunID,ConfigID]); + if not ExecuteQuery(qry,False) then + Verbose(V_Warning,'Update of LastRunID failed'); + AddTestHistoryEntry(TestRunID,PrevRunID); + AddCount:=true; end else Verbose(V_Warning,'TestRunID is equal to last!'); @@ -700,9 +692,7 @@ begin Inc(RunCount); qry:=format('UPDATE TESTCONFIG SET TCONF_COUNT_RUNS=%d WHERE TCONF_ID=%d', [RunCount,ConfigID]); - if RunQuery(qry,res) then - FreeQueryResult(res) - else + if not ExecuteQuery(qry,False) then Verbose(V_Warning,'Update of TU_COUNT_RUNS failed'); end; UpdateTestConfigID:=true; @@ -717,31 +707,23 @@ begin 'TCONF_CPU_FK,TCONF_OS_FK,TCONF_VERSION_FK,TCONF_CATEGORY_FK,'+ 'TCONF_SUBMITTER,TCONF_MACHINE,TCONF_COMMENT,'+ 'TCONF_NEW_DATE,TCONF_FIRST_DATE,TCONF_LAST_DATE) '; - qry:=qry+format(' VALUES(%d,%d,%d,%d,%d,%d,%d,"%s","%s","%s","%s","%s","%s") ', - [TestRunID, TestRunID, TestRunID, TestCPUID, - TestOSID, TestVersionID, TestCategoryID, - Submitter, Machine, Comment, - SqlDate(TestDate), SqlDate(TestDate), SqlDate(TestDate)]); + qry:=qry+format(' VALUES(%d,%d,%d,%d,%d,%d,%d,"%s","%s","%s","%s","%s","%s") ', + [TestRunID, TestRunID, TestRunID, TestCPUID, + TestOSID, TestVersionID, TestCategoryID, + Submitter, Machine, Comment, + SqlDate(TestDate), SqlDate(TestDate), SqlDate(TestDate)]); + qry:=qry+' RETURNING TCONF_ID'; Result:=InsertQuery(qry); AddTestHistoryEntry(TestRunID,0); end; procedure UpdateTestConfig; - var - qry : string; - res : TQueryResult; begin - qry:='SHOW TABLES LIKE ''TESTCONFIG'''; - if not RunQuery(Qry,Res) then - exit; - { Row_Count is zero if table does not exist } - if Res^.Row_Count=0 then exit; - FreeQueryResult(Res); if GetTestPreviousRunHistoryID(TestRunID) <> -1 then begin - Verbose(V_DEBUG,format('TestRun %d already in TestHistory table',[TestRunID])); - exit; + Verbose(V_DEBUG,format('TestRun %d already in TestHistory table',[TestRunID])); + exit; end; if GetTestConfigID >= 0 then diff --git a/tests/utils/dbtests.pp b/tests/utils/dbtests.pp index 340c552567..7698c00c5a 100644 --- a/tests/utils/dbtests.pp +++ b/tests/utils/dbtests.pp @@ -6,7 +6,7 @@ unit dbtests; Interface Uses - mysql55dyn, testu; + sqldb, testu; { --------------------------------------------------------------------- High-level access @@ -34,21 +34,19 @@ function AddTestHistoryEntry(TestRunID,TestPreviousID : Integer) : boolean; Low-level DB access. ---------------------------------------------------------------------} - -Type - TQueryResult = PMYSQL_RES; - Function ConnectToDatabase(DatabaseName,Host,User,Password,Port : String) : Boolean; Procedure DisconnectDatabase; Function InsertQuery(const Query : string) : Integer; -Function RunQuery (Qry : String; Var res : TQueryResult) : Boolean ; -Procedure FreeQueryResult (Res : TQueryResult); -Function GetResultField (Res : TQueryResult; Id : Integer) : String; +Function ExecuteQuery (Qry : String; Silent : Boolean) : Boolean ; +Function OpenQuery (Qry : String; Out Res : TSQLQuery; Silent : Boolean) : Boolean ; +Procedure FreeQueryResult (Var Res : TSQLQuery); +Function GetResultField (Res : TSQLQuery; Id : Integer) : String; Function IDQuery(Qry : String) : Integer; Function StringQuery(Qry : String) : String; Function EscapeSQL( S : String) : String; Function SQLDate(D : TDateTime) : String; + var RelSrcDir, TestSrcDir : string; @@ -56,132 +54,145 @@ var Implementation Uses - SysUtils; + SysUtils, pqconnection; + +Var + Connection : TPQConnection; { --------------------------------------------------------------------- Low-level DB access. ---------------------------------------------------------------------} - -Var - Connection : PMYSQL; - - Function ConnectToDatabase(DatabaseName,Host,User,Password,Port : String) : Boolean; -Var - S : String; - PortNb : longint; - Error : word; begin + Result:=False; Verbose(V_DEBUG,'Connection params : '+DatabaseName+' '+Host+' '+User+' '+Password+' '+Port); - if Port<>'' then - begin - Val(Port,PortNb,Error); - if Error<>0 then - PortNb:=0; - end - else - PortNB:=0; - Connection:=mysql_init(Nil); - Result:=mysql_real_connect(Connection,PChar(Host),PChar(User),PChar(Password),Nil,PortNb,Nil,CLIENT_MULTI_RESULTS)<>Nil; - 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 + Connection:=TPQConnection.Create(Nil); + try + Connection.Hostname:=Host; + Connection.DatabaseName:=DatabaseName; + Connection.Username:=User; + Connection.Password:=Password; + Connection.Connected:=true; + if (Port<>'') then + Connection.Params.Values['Port']:=Port; + except + On E : Exception do begin - S:=StrPas(mysql_error(connection)); - DisconnectDatabase; - Verbose(V_Error,'Failed to select database : '+S); + Verbose(V_ERROR,'Failed to connect to database : '+E.Message); + FreeAndNil(Connection); end; - end; + end; end; Procedure DisconnectDatabase; begin - mysql_close(Connection); + FreeAndNil(Connection); end; -Function RunQuery (Qry : String; Var res : TQueryResult) : Boolean ; +Function CreateQuery(Const ASQL : String) : TSQLQuery; begin + Result:=TSQLQuery.Create(Connection); + Result.Database:=Connection; + Result.Transaction:=Connection.Transaction; + Result.SQL.Text:=ASQL; +end; + + + +Function ExecuteQuery (Qry : String; Silent : Boolean) : Boolean ; + +begin + Verbose(V_DEBUG,'Executing query:'+Qry); + Result:=False; + try + With CreateQuery(Qry) do + try + ExecSQL; + Result:=True; + (Transaction as TSQLTransaction).Commit; + finally + Free; + end; + except + On E : exception do + begin + Connection.Transaction.RollBack; + if not Silent then + Verbose(V_WARNING,'Query : '+Qry+'Failed : '+E.Message); + end; + end; +end; + +Function OpenQuery (Qry : String; Out res : TSQLQuery; Silent : Boolean) : Boolean ; + +begin + Result:=False; 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); + Res:=CreateQuery(Qry); + try + Res.Open; + Result:=True; + except + On E : exception do + begin + FreeAndNil(Res); + Connection.Transaction.RollBack; + if not Silent then + Verbose(V_WARNING,'Query : '+Qry+'Failed : '+E.Message); + end; + end; end; -{ No warning if it fails } -Function RunSilentQuery (Qry : String; Var res : TQueryResult) : Boolean ; +Function GetResultField (Res : TSQLQuery; Id : Integer) : String; + begin - Verbose(V_DEBUG,'Running silent query:'+Qry); - Result:=mysql_query(Connection,PChar(qry))=0; - If Not Result then - Verbose(V_DEBUG,'Silent query : '+Qry+'Failed : '+Strpas(mysql_error(connection))) - else - Res:=Mysql_store_result(connection); -end; - - -Function GetResultField (Res : TQueryResult; Id : Integer) : String; - -Var - Row : PPchar; - -begin - if Res=Nil then + If (Res=Nil) or (ID>=Res.Fields.Count) then Result:='' else - begin - Row:=mysql_fetch_row(Res); - If (Row=Nil) or (Row[ID]=Nil) then - Result:='' - else - Result:=strpas(Row[ID]); - end; + Result:=Res.Fields[ID].AsString; Verbose(V_DEBUG,'Field value '+Result); end; -Procedure FreeQueryResult (Res : TQueryResult); +Procedure FreeQueryResult(var Res : TSQLQuery); begin - mysql_free_result(Res); + if Assigned(Res) and Assigned(Res.Transaction) then + (Res.Transaction as TSQLTransaction).Commit; + FreeAndNil(Res); end; Function IDQuery(Qry : String) : Integer; Var - Res : TQueryResult; + Res : TSQLQuery; begin Result:=-1; - If RunQuery(Qry,Res) then - begin - Result:=StrToIntDef(GetResultField(Res,0),-1); - FreeQueryResult(Res); + If OpenQuery(Qry,Res,False) then + try + Result:=StrToIntDef(GetResultField(Res,0),-1); + finally + FreeQueryResult(Res); end; end; Function StringQuery(Qry : String) : String; Var - Res : TQueryResult; + Res : TSQLQuery; begin Result:=''; - If RunQuery(Qry,Res) then - begin - Result:=GetResultField(Res,0); - FreeQueryResult(Res); + If OpenQuery(Qry,Res,False) then + try + Result:=GetResultField(Res,0); + finally + FreeQueryResult(Res); end; end; @@ -265,17 +276,9 @@ begin end; Function InsertQuery(const Query : string) : Integer; -Var - Res : TQueryResult; begin - If RunQuery(Query,Res) then - begin - Result:=mysql_insert_id(connection); - FreeQueryResult(Res); - end - else - Result:=-1; + Result:=IDQuery(Query); end; Function AddRun(OSID, CPUID, VERSIONID, CATEGORYID : Integer; Date : TDateTime) : Integer; @@ -284,12 +287,12 @@ 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")'; + '(%d,%d,%d,%d,"%s") RETURNING TU_ID'; var Qry : string; begin qry:=Format(SInsertRun,[OSID,CPUID,VERSIONID,CATEGORYID,SQLDate(Date)]); - Result:=InsertQuery(Qry); + Result:=IDQuery(Qry); end; function posr(c : Char; const s : AnsiString) : integer; @@ -380,7 +383,6 @@ Const Var Info : TConfig; - Res : TQueryResult; begin Result:=-1; @@ -388,9 +390,8 @@ begin GetConfig(TestSrcDir+RelSrcDir+Name,Info)) or GetUnitTestConfig(Name,Info) then begin - If RunQuery(Format(SInsertTest,[Name]),Res) then + If ExecuteQuery(Format(SInsertTest,[Name]),False) then begin - FreeQueryResult(Res); Result:=GetTestID(Name); If Result=-1 then Verbose(V_WARNING,'Could not find newly added test!') @@ -424,7 +425,6 @@ Const Var Qry : String; - Res : TQueryResult; begin If Source<>'' then @@ -441,8 +441,7 @@ begin Source, ID ]); - Result:=RunQuery(Qry,res); - FreeQueryResult(Res); + Result:=ExecuteQuery(Qry,False); end; Function AddTestResult(TestID,RunID,TestRes : Integer; @@ -453,37 +452,33 @@ Const SInsertRes='Insert into TESTRESULTS '+ '(TR_TEST_FK,TR_TESTRUN_FK,TR_OK,TR_SKIP,TR_RESULT) '+ ' VALUES '+ - '(%d,%d,"%s","%s",%d) '; + '(%d,%d,"%s","%s",%d) RETURNING TR_ID'; SSelectId='SELECT TR_ID FROM TESTRESULTS WHERE (TR_TEST_FK=%d) '+ ' AND (TR_TESTRUN_FK=%d)'; SInsertLog='Update TESTRESULTS SET TR_LOG="%s"'+ ',TR_OK="%s",TR_SKIP="%s",TR_RESULT=%d WHERE (TR_ID=%d)'; Var Qry : String; - Res : TQueryResult; updateValues : boolean; + begin updateValues:=false; Result:=-1; Qry:=Format(SInsertRes, [TestID,RunID,B[OK],B[Skipped],TestRes,EscapeSQL(Log)]); - If RunSilentQuery(Qry,Res) then - Result:=mysql_insert_id(connection) - else + Result:=IDQuery(Qry); + if (Result=-1) then begin - Qry:=format(SSelectId,[TestId,RunId]); - Result:=IDQuery(Qry); - if Result<>-1 then - updateValues:=true; + Qry:=format(SSelectId,[TestId,RunId]); + Result:=IDQuery(Qry); + if Result<>-1 then + UpdateValues:=true; end; if (Result<>-1) and ((Log<>'') or updateValues) then begin - Qry:=format(SInsertLog,[EscapeSQL(Log),B[OK],B[Skipped],TestRes,Result]); - if not RunQuery(Qry,Res) then - begin - Verbose(V_Warning,'Insert Log failed'); - end; - FreeQueryResult(Res); + Qry:=Format(SInsertLog,[EscapeSQL(Log),B[OK],B[Skipped],TestRes,Result]); + if Not ExecuteQuery(Qry,False) then + Verbose(V_Warning,'Insert Log failed'); end; { If test already existed, return false for is_new to avoid double counting } is_new:=not updateValues; @@ -504,12 +499,8 @@ 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); - FreeQueryResult(Res); + Result:=ExecuteQuery(Format(SDeleteRun,[ID]),False); end; function GetTestPreviousRunHistoryID(TestRunID : Integer) : Integer; @@ -525,21 +516,14 @@ begin end; function AddTestHistoryEntry(TestRunID,TestPreviousID : Integer) : boolean; + var qry : string; - res : TQueryResult; -begin - qry:=format('INSERT INTO TESTRUNHISTORY (TH_ID_FK,TH_PREVIOUS_FK) '+ - ' VALUES (%d,%d)',[TestRunID,TestPreviousID]); - If RunQuery(qry,res) then - begin - FreeQueryResult(res); - AddTestHistoryEntry:=true; - end - else - AddTestHistoryEntry:=false; -end; begin - initialisemysql; + Qry:=format('INSERT INTO TESTRUNHISTORY (TH_ID_FK,TH_PREVIOUS_FK) '+ + ' VALUES (%d,%d)',[TestRunID,TestPreviousID]); + Result:=ExecuteQuery(Qry,False); +end; + end. diff --git a/tests/utils/testsuite/testsuite.lpi b/tests/utils/testsuite/testsuite.lpi index bd5b4c9380..ee4e1d55a5 100644 --- a/tests/utils/testsuite/testsuite.lpi +++ b/tests/utils/testsuite/testsuite.lpi @@ -1,137 +1,20 @@ - + - + - + + + + + - - - + <ActiveWindowIndexAtStart Value="0"/> </General> - <JumpHistory Count="12" HistoryIndex="11"> - <Position1> - <Filename Value="dbwhtml.pp"/> - <Caret Line="85" Column="3" TopLine="82"/> - </Position1> - <Position2> - <Filename Value="dbwhtml.pp"/> - <Caret Line="204" Column="5" TopLine="164"/> - </Position2> - <Position3> - <Filename Value="dbwhtml.pp"/> - <Caret Line="205" Column="5" TopLine="165"/> - </Position3> - <Position4> - <Filename Value="dbwhtml.pp"/> - <Caret Line="203" Column="25" TopLine="168"/> - </Position4> - <Position5> - <Filename Value="dbwhtml.pp"/> - <Caret Line="212" Column="15" TopLine="195"/> - </Position5> - <Position6> - <Filename Value="dbwhtml.pp"/> - <Caret Line="70" Column="67" TopLine="52"/> - </Position6> - <Position7> - <Filename Value="utests.pp"/> - <Caret Line="594" Column="5" TopLine="554"/> - </Position7> - <Position8> - <Filename Value="utests.pp"/> - <Caret Line="66" Column="1" TopLine="34"/> - </Position8> - <Position9> - <Filename Value="dbwhtml.pp"/> - <Caret Line="396" Column="4" TopLine="361"/> - </Position9> - <Position10> - <Filename Value="utests.pp"/> - <Caret Line="66" Column="14" TopLine="35"/> - </Position10> - <Position11> - <Filename Value="utests.pp"/> - <Caret Line="600" Column="56" TopLine="568"/> - </Position11> - <Position12> - <Filename Value="utests.pp"/> - <Caret Line="31" Column="77" TopLine="14"/> - </Position12> - </JumpHistory> - <Units Count="8"> - <Unit0> - <CursorPos X="19" Y="5"/> - <EditorIndex Value="0"/> - <Filename Value="testsuite.pp"/> - <IsPartOfProject Value="True"/> - <Loaded Value="True"/> - <TopLine Value="1"/> - <UnitName Value="testsuite"/> - <UsageCount Value="56"/> - </Unit0> - <Unit1> - <CursorPos X="23" Y="595"/> - <EditorIndex Value="1"/> - <Filename Value="utests.pp"/> - <IsPartOfProject Value="True"/> - <Loaded Value="True"/> - <TopLine Value="568"/> - <UnitName Value="utests"/> - <UsageCount Value="56"/> - </Unit1> - <Unit2> - <CursorPos X="6" Y="136"/> - <EditorIndex Value="4"/> - <Filename Value="/home/michael/fixbranch/rtl/linux/syslinux.pp"/> - <Loaded Value="True"/> - <TopLine Value="94"/> - <UnitName Value="SysLinux"/> - <UsageCount Value="28"/> - </Unit2> - <Unit3> - <CursorPos X="1" Y="1"/> - <Filename Value="/home/michael/test.sql"/> - <SyntaxHighlighter Value="None"/> - <TopLine Value="1"/> - <UsageCount Value="8"/> - </Unit3> - <Unit4> - <CursorPos X="27" Y="23"/> - <EditorIndex Value="3"/> - <Filename Value="/home/michael/fixbranch/rtl/unix/linux.pp"/> - <Loaded Value="True"/> - <TopLine Value="1"/> - <UnitName Value="Linux"/> - <UsageCount Value="25"/> - </Unit4> - <Unit5> - <CursorPos X="56" Y="251"/> - <Filename Value="/home/michael/projects/lazarus/components/editbutton/editbtn.pas"/> - <TopLine Value="248"/> - <UnitName Value="EditBtn"/> - <UsageCount Value="8"/> - </Unit5> - <Unit6> - <CursorPos X="31" Y="8"/> - <Filename Value="/home/michael/projects/lazarus/components/editbutton/demo/frmmain.pp"/> - <ComponentName Value="Form1"/> - <ResourceFilename Value="/home/michael/projects/lazarus/components/editbutton/demo/frmmain.lrs"/> - <TopLine Value="1"/> - <UnitName Value="frmmain"/> - <UsageCount Value="20"/> - </Unit6> - <Unit7> - <CursorPos X="27" Y="393"/> - <EditorIndex Value="2"/> - <Filename Value="dbwhtml.pp"/> - <Loaded Value="True"/> - <TopLine Value="384"/> - <UnitName Value="dbwhtml"/> - <UsageCount Value="25"/> - </Unit7> - </Units> + <BuildModes Count="1"> + <Item1 Name="default" Default="True"/> + </BuildModes> <PublishOptions> <Version Value="2"/> <IgnoreBinaries Value="False"/> @@ -144,16 +27,253 @@ <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/> </local> </RunParams> - <RequiredPackages Count="1"> - <Item1> - <PackageName Value="editbutton"/> - <MinVersion Valid="True"/> - </Item1> - </RequiredPackages> + <Units Count="12"> + <Unit0> + <Filename Value="testsuite.pp"/> + <IsPartOfProject Value="True"/> + <UnitName Value="testsuite"/> + <EditorIndex Value="0"/> + <WindowIndex Value="1"/> + <TopLine Value="1"/> + <CursorPos X="29" Y="5"/> + <UsageCount Value="72"/> + <Loaded Value="True"/> + <LoadedDesigner Value="True"/> + </Unit0> + <Unit1> + <Filename Value="utests.pp"/> + <IsPartOfProject Value="True"/> + <UnitName Value="utests"/> + <IsVisibleTab Value="True"/> + <EditorIndex Value="1"/> + <WindowIndex Value="1"/> + <TopLine Value="1003"/> + <CursorPos X="59" Y="919"/> + <UsageCount Value="72"/> + <Loaded Value="True"/> + </Unit1> + <Unit2> + <Filename Value="../../../../../fixbranch/rtl/linux/syslinux.pp"/> + <UnitName Value="SysLinux"/> + <WindowIndex Value="1"/> + <TopLine Value="94"/> + <CursorPos X="6" Y="136"/> + <UsageCount Value="26"/> + <LoadedDesigner Value="True"/> + </Unit2> + <Unit3> + <Filename Value="../../../../../test.sql"/> + <TopLine Value="1"/> + <CursorPos X="1" Y="1"/> + <SyntaxHighlighter Value="None"/> + <UsageCount Value="6"/> + </Unit3> + <Unit4> + <Filename Value="../../../../../fixbranch/rtl/unix/linux.pp"/> + <UnitName Value="Linux"/> + <WindowIndex Value="1"/> + <TopLine Value="1"/> + <CursorPos X="27" Y="23"/> + <UsageCount Value="23"/> + <LoadedDesigner Value="True"/> + </Unit4> + <Unit5> + <Filename Value="../../../../../projects/lazarus/components/editbutton/editbtn.pas"/> + <UnitName Value="EditBtn"/> + <TopLine Value="248"/> + <CursorPos X="56" Y="251"/> + <UsageCount Value="6"/> + </Unit5> + <Unit6> + <Filename Value="../../../../../projects/lazarus/components/editbutton/demo/frmmain.pp"/> + <ComponentName Value="Form1"/> + <UnitName Value="frmmain"/> + <TopLine Value="1"/> + <CursorPos X="31" Y="8"/> + <UsageCount Value="18"/> + </Unit6> + <Unit7> + <Filename Value="dbwhtml.pp"/> + <UnitName Value="dbwhtml"/> + <WindowIndex Value="1"/> + <TopLine Value="384"/> + <CursorPos X="27" Y="393"/> + <UsageCount Value="23"/> + <LoadedDesigner Value="True"/> + </Unit7> + <Unit8> + <Filename Value="../tresults.pp"/> + <IsPartOfProject Value="True"/> + <UnitName Value="tresults"/> + <UsageCount Value="36"/> + </Unit8> + <Unit9> + <Filename Value="../../../../build/tag_2_6_4/fpcsrc/packages/fcl-base/src/wformat.pp"/> + <UnitName Value="wformat"/> + <EditorIndex Value="4"/> + <WindowIndex Value="1"/> + <TopLine Value="17"/> + <CursorPos X="15" Y="35"/> + <UsageCount Value="18"/> + <Loaded Value="True"/> + </Unit9> + <Unit10> + <Filename Value="../../../../build/tag_2_6_4/fpcsrc/packages/fcl-web/src/base/webutil.pp"/> + <UnitName Value="webutil"/> + <EditorIndex Value="3"/> + <WindowIndex Value="1"/> + <TopLine Value="1"/> + <CursorPos X="1" Y="1"/> + <UsageCount Value="17"/> + <Loaded Value="True"/> + </Unit10> + <Unit11> + <Filename Value="../../../../build/tag_2_6_4/fpcsrc/packages/fcl-web/src/base/cgiapp.pp"/> + <UnitName Value="cgiapp"/> + <EditorIndex Value="2"/> + <WindowIndex Value="1"/> + <TopLine Value="34"/> + <CursorPos X="1" Y="40"/> + <UsageCount Value="17"/> + <Loaded Value="True"/> + </Unit11> + </Units> + <JumpHistory Count="30" HistoryIndex="29"> + <Position1> + <Filename Value="utests.pp"/> + <Caret Line="574" Column="45" TopLine="549"/> + </Position1> + <Position2> + <Filename Value="utests.pp"/> + <Caret Line="946" Column="27" TopLine="930"/> + </Position2> + <Position3> + <Filename Value="utests.pp"/> + <Caret Line="1103" Column="40" TopLine="1077"/> + </Position3> + <Position4> + <Filename Value="utests.pp"/> + <Caret Line="1467" Column="37" TopLine="1442"/> + </Position4> + <Position5> + <Filename Value="utests.pp"/> + <Caret Line="1468" Column="71" TopLine="1443"/> + </Position5> + <Position6> + <Filename Value="utests.pp"/> + <Caret Line="1469" Column="48" TopLine="1444"/> + </Position6> + <Position7> + <Filename Value="utests.pp"/> + <Caret Line="2531" Column="53" TopLine="2531"/> + </Position7> + <Position8> + <Filename Value="utests.pp"/> + <Caret Line="2554" Column="17" TopLine="2525"/> + </Position8> + <Position9> + <Filename Value="utests.pp"/> + <Caret Line="2533" Column="17" TopLine="2519"/> + </Position9> + <Position10> + <Filename Value="utests.pp"/> + <Caret Line="2544" Column="18" TopLine="2540"/> + </Position10> + <Position11> + <Filename Value="utests.pp"/> + <Caret Line="121" Column="1" TopLine="121"/> + </Position11> + <Position12> + <Filename Value="utests.pp"/> + <Caret Line="326" Column="24" TopLine="301"/> + </Position12> + <Position13> + <Filename Value="utests.pp"/> + <Caret Line="67" Column="1" TopLine="61"/> + </Position13> + <Position14> + <Filename Value="utests.pp"/> + <Caret Line="846" Column="3" TopLine="842"/> + </Position14> + <Position15> + <Filename Value="utests.pp"/> + <Caret Line="1" Column="1" TopLine="1"/> + </Position15> + <Position16> + <Filename Value="utests.pp"/> + <Caret Line="2555" Column="11" TopLine="2530"/> + </Position16> + <Position17> + <Filename Value="utests.pp"/> + <Caret Line="2554" Column="10" TopLine="2530"/> + </Position17> + <Position18> + <Filename Value="utests.pp"/> + <Caret Line="1" Column="1" TopLine="1"/> + </Position18> + <Position19> + <Filename Value="utests.pp"/> + <Caret Line="420" Column="21" TopLine="412"/> + </Position19> + <Position20> + <Filename Value="utests.pp"/> + <Caret Line="1" Column="1" TopLine="1"/> + </Position20> + <Position21> + <Filename Value="utests.pp"/> + <Caret Line="2555" Column="41" TopLine="2532"/> + </Position21> + <Position22> + <Filename Value="utests.pp"/> + <Caret Line="2493" Column="3" TopLine="2478"/> + </Position22> + <Position23> + <Filename Value="utests.pp"/> + <Caret Line="2" Column="1" TopLine="1"/> + </Position23> + <Position24> + <Filename Value="utests.pp"/> + <Caret Line="2534" Column="11" TopLine="2527"/> + </Position24> + <Position25> + <Filename Value="utests.pp"/> + <Caret Line="1" Column="1" TopLine="1"/> + </Position25> + <Position26> + <Filename Value="utests.pp"/> + <Caret Line="304" Column="21" TopLine="300"/> + </Position26> + <Position27> + <Filename Value="utests.pp"/> + <Caret Line="676" Column="1" TopLine="661"/> + </Position27> + <Position28> + <Filename Value="utests.pp"/> + <Caret Line="912" Column="13" TopLine="904"/> + </Position28> + <Position29> + <Filename Value="utests.pp"/> + <Caret Line="1" Column="1" TopLine="1"/> + </Position29> + <Position30> + <Filename Value="utests.pp"/> + <Caret Line="919" Column="16" TopLine="889"/> + </Position30> + </JumpHistory> </ProjectOptions> <CompilerOptions> + <Version Value="11"/> + <SearchPaths> + <OtherUnitFiles Value=".."/> + </SearchPaths> + <Parsing> + <SyntaxOptions> + <UseAnsiStrings Value="False"/> + </SyntaxOptions> + </Parsing> <Other> <CompilerPath Value="$(CompPath)"/> </Other> </CompilerOptions> + <EditorMacros Count="0"/> </CONFIG> diff --git a/tests/utils/testsuite/testsuite.pp b/tests/utils/testsuite/testsuite.pp index a926345c91..7d077b5427 100644 --- a/tests/utils/testsuite/testsuite.pp +++ b/tests/utils/testsuite/testsuite.pp @@ -2,7 +2,7 @@ {$h+} program testsuite; -uses utests; +uses utests, tresults; Var App : TTestSuite; diff --git a/tests/utils/testsuite/utests.pp b/tests/utils/testsuite/utests.pp index 8190d171be..ceb5fcc88e 100644 --- a/tests/utils/testsuite/utests.pp +++ b/tests/utils/testsuite/utests.pp @@ -1,25 +1,33 @@ {$mode objfpc} {$h+} + unit utests; interface uses cgiapp, - sysutils,mysql55conn,sqldb,whtml,dbwhtml,db, - tresults, + sysutils, + pqconnection, + sqldb,whtml,dbwhtml,db, + tresults,webutil, Classes,ftFont,fpimage,fpimgcanv,fpWritePng,fpcanvas; const TestsuiteURLPrefix='http://www.freepascal.org/testsuite/'; TestsuiteBin='testsuite.cgi'; ViewURL='http://svn.freepascal.org/cgi-bin/viewvc.cgi/'; - ViewRevURL='http://svn.freepascal.org/cgi-bin/viewvc.cgi?view=revision&revision='; + ViewRevURL='http://svn.freepascal.org/cgi-bin/viewvc.cgi?view=revision&revision='; TestsSubDir='/tests/'; DataBaseSubDir='/packages/fcl-db/tests/'; + var TestsuiteCGIURL : string; + Type + + { TTestSuite } + TTestSuite = Class(TCgiApplication) Private FHTMLWriter : THtmlWriter; @@ -56,6 +64,7 @@ Type FLimit : Integer; FTestLastDays : Integer; FNeedEnd : boolean; + procedure DumpTestInfo(Q: TSQLQuery); Procedure GetOverviewRowAttr(Sender : TObject; Var BGColor : String; Var Align : THTMLAlign; Var VAlign : THTMLValign; Var CustomAttr : String) ; @@ -366,7 +375,8 @@ begin FVersion:=RequestVariables['version']; if Length(FVersion) = 0 then FVersion:=RequestVariables['TESTVERSION']; - + TestsuiteCGIURL:=Self.ScriptName; + SDetailsURL := TestsuiteCGIURL + '?action=1&run1id=%s'; FOS:=RequestVariables['os']; if Length(FOS) = 0 then FOS:=RequestVariables['TESTOS']; @@ -434,7 +444,7 @@ Function TTestSuite.ConnectToDB : Boolean; begin Result:=False; - FDB:=TMySQl55Connection.Create(Self); + FDB:=TPQConnection.Create(Self); FDB.HostName:=DefHost; FDB.DatabaseName:=DefDatabase; FDB.UserName:=DefDBUser; @@ -548,6 +558,9 @@ begin end; Procedure TTestSuite.EmitTitle(ATitle : String); + +Var + S : TStrings; begin AddResponseLn('<HTML>'); AddResponseLn('<TITLE>'+ATitle+''); @@ -892,7 +905,7 @@ end; Procedure TTestSuite.ShowRunOverview; Const SOverview = 'SELECT TU_ID as ID,TU_DATE as Date,TC_NAME as CPU,TO_NAME as OS,'+ - 'TV_VERSION as Version,count(*) as Count,'+ + 'TV_VERSION as Version,(select count(*) from testresults where (TR_TESTRUN_FK=TU_ID)) as Count,'+ 'TU_SVNCOMPILERREVISION as SvnCompRev,'+ 'TU_SVNRTLREVISION as SvnRTLRev,'+ 'TU_SVNPACKAGESREVISION as SvnPackRev,TU_SVNTESTSREVISION as SvnTestsRev,'+ @@ -901,11 +914,13 @@ Const '(TU_SUCCESSFULLYFAILED+TU_SUCCESFULLYCOMPILED+TU_SUCCESSFULLYRUN+'+ 'TU_FAILEDTOCOMPILE+TU_FAILEDTORUN+TU_FAILEDTOFAIL) as Total,'+ 'TU_SUBMITTER as Submitter, TU_MACHINE as Machine, TU_COMMENT as Comment %s '+ - 'FROM TESTRUN left join TESTCPU on (TC_ID=TU_CPU_FK) left join TESTOS on (TO_ID=TU_OS_FK) '+ - 'left join TESTVERSION on (TV_ID=TU_VERSION_FK) left join TESTCATEGORY on (TCAT_ID=TU_CATEGORY_FK) '+ - 'left join TESTRESULTS on (TR_TESTRUN_FK=TU_ID) '+ + 'FROM '+ + ' TESTRUN '+ + ' left join TESTCPU on (TC_ID=TU_CPU_FK) '+ + ' left join TESTOS on (TO_ID=TU_OS_FK) '+ + ' left join TESTVERSION on (TV_ID=TU_VERSION_FK) '+ + ' left join TESTCATEGORY on (TCAT_ID=TU_CATEGORY_FK) '+ '%s'+ - 'GROUP BY TU_ID '+ 'ORDER BY TU_ID DESC LIMIT %d'; @@ -933,11 +948,9 @@ begin S:=S+' AND (TU_COMMENT LIKE '''+Fcomment+''')'; If FCond<>'' then S:=S+' AND ('+FCond+')'; - If FOnlyFailed then - S:=S+' AND (TR_OK="-")'; If GetCategoryName(FCategory)<>'DB' then - SC:=', CONCAT(TU_SVNCOMPILERREVISION,"/",TU_SVNRTLREVISION,"/", '+ - 'TU_SVNPACKAGESREVISION,"/",TU_SVNTESTSREVISION) as svnrev' + SC:=', CONCAT(TU_SVNCOMPILERREVISION,''/'',TU_SVNRTLREVISION,''/'', '+ + 'TU_SVNPACKAGESREVISION,''/'',TU_SVNTESTSREVISION) as svnrev' else SC:=''; If (FCategory='') or (GetCategoryName(FCategory)='All') then @@ -1088,8 +1101,8 @@ begin If Result then begin If GetCategoryName(FCategory)<>'DB' then - SC:=', CONCAT(TU_SVNCOMPILERREVISION,"/",TU_SVNRTLREVISION,"/", '+ - 'TU_SVNPACKAGESREVISION,"/",TU_SVNTESTSREVISION) as svnrev' + SC:=', CONCAT(TU_SVNCOMPILERREVISION,''/'',TU_SVNRTLREVISION,''/'', '+ + 'TU_SVNPACKAGESREVISION,''/'',TU_SVNTESTSREVISION) as svnrev' else SC:=''; If GetCategoryName(FCategory)='All' then @@ -1397,9 +1410,9 @@ begin +' WHERE (TR_TEST_FK=T_ID) AND (TR_TESTRUN_FK='+FRunID+') '; If FOnlyFailed then - S:=S+' AND (TR_OK="-")'; + S:=S+' AND (not TR_OK)'; If FNoSkipped then - S:=S+' AND (TR_SKIP="-")'; + S:=S+' AND (not TR_SKIP)'; S:=S+' ORDER BY TR_ID '; Qry:=S; If FDebug then @@ -1466,6 +1479,33 @@ begin end; end; +Procedure TTestSuite.DumpTestInfo(Q : TSQLQuery); + +Var + I : Integer; + FieldValue,FieldName : String; + +begin + With FHTMLWriter do + For i:=0 to Q.FieldCount-1 do + begin + FieldValue:=Q.Fields[i].AsString; + FieldName:=Q.Fields[i].DisplayName; + if (Not Q.fields[i].IsNull) and (FieldName<>'T_NAME') and (FieldName<>'T_SOURCE') then + begin + if (Q.Fields[i].Datatype=ftBoolean) then + DumpLn('Flag '); + DumpLn(FieldName); + DumpLn(' '); + if (Q.Fields[i].DataType=ftBoolean) and Q.Fields[i].AsBoolean then + DumpLn(' set') + else + DumpLn(FieldValue); + DumpLn('
'); + end; + end; +end; + Procedure TTestSuite.ShowOneTest; Var @@ -1484,8 +1524,7 @@ begin EmitContentType; EmitDocType; if FTestFileID='' then - FTestFileID:=GetSingleton('SELECT T_ID FROM TESTS WHERE T_NAME LIKE ''%'+ - FTestFileName+'%'''); + FTestFileID:=GetSingleton('SELECT T_ID FROM TESTS WHERE T_NAME LIKE ''%'+FTestFileName+'%'''); if FTestFileID<>'' then FTestFileName:=GetTestFileName(FTestFileID); EmitTitle(Title+' : File '+FTestFileName+' Results'); @@ -1527,26 +1566,7 @@ begin Try Open; Try - For i:=0 to FieldCount-1 do - begin - FieldValue:=Fields[i].AsString; - FieldName:=Fields[i].DisplayName; - - if (FieldValue<>'') and (FieldValue<>'-') and - (FieldName<>'T_NAME') and (FieldName<>'T_SOURCE') then - begin - if (FieldValue='+') then - DumpLn('Flag '); - DumpLn(FieldName); - DumpLn(' '); - if FieldValue='+' then - DumpLn(' set') - else - DumpLn(FieldValue); - DumpLn('
'); - end; - end; - + DumpTestInfo(Q); Finally Close; end; @@ -1746,8 +1766,10 @@ end; Procedure TTestSuite.ShowHistory; + Const MaxCombo = 50; + Type StatusLongintArray = Array [TTestStatus] of longint; StatusDateTimeArray = Array [TTestStatus] of TDateTime; @@ -1755,6 +1777,7 @@ Type AStatusDTA = Array[1..MaxCombo] of StatusDateTimeArray; PStatusLA = ^AStatusLA; PStatusDTA = ^AStatusDTA; + Var S,SS,FL,cpu,version,os : String; date : TDateTime; @@ -1782,8 +1805,9 @@ Var version_first_date_id, version_last_date_id : PStatusLA; FieldName,FieldValue, LLog,Source : String; - Res : Boolean; + B,Res : Boolean; ver : known_versions; + begin Res:=False; os_count:=nil; @@ -1855,25 +1879,7 @@ begin Try Open; Try - For i:=0 to FieldCount-1 do - begin - FieldValue:=Fields[i].AsString; - FieldName:=Fields[i].DisplayName; - if (FieldValue<>'') and (FieldValue<>'-') and - (FieldName<>'T_NAME') and (FieldName<>'T_SOURCE') then - begin - if (FieldValue='+') then - DumpLn('Flag '); - DumpLn(FieldName); - DumpLn(' '); - if FieldValue='+' then - DumpLn(' set') - else - DumpLn(FieldValue); - DumpLn('
'); - end; - end; - + DumpTestInfo(Q); Finally Close; end; @@ -2048,14 +2054,11 @@ begin begin Q.RecNo:=i; inc(total_count); - S:=Fields[ok_ind].AsString; - - if S='+' then + if Q.Fields[ok_ind].AsBoolean then inc(OK_count) else inc(not_OK_count); - S:=Fields[skip_ind].AsString; - if S='+' then + if Fields[skip_ind].AsBoolean then inc(skip_count) else inc(not_skip_count); @@ -2529,35 +2532,26 @@ begin HeaderEnd(2); ParaGraphStart; Q:=CreateDataset(''); - Q.SQL.Text:='CREATE TEMPORARY TABLE tr1 like TESTRESULTS;'; - Q.ExecSQL; - Q.SQL.Text:='CREATE TEMPORARY TABLE tr2 like TESTRESULTS;'; - Q.ExecSQL; - Q.SQL.Text:='INSERT INTO tr1 SELECT * FROM '+TESTRESULTSTableName(FRunId)+ - - ' WHERE TR_TESTRUN_FK='+FRunID+';'; - Q.ExecSQL; - Q.SQL.Text:='INSERT INTO tr2 SELECT * FROM '+TESTRESULTSTableName(FCompareRunId)+ - ' WHERE TR_TESTRUN_FK='+FCompareRunID+';'; - Q.ExecSQL; - S:='SELECT T_ID as Id,T_NAME as Filename,tr1.TR_SKIP as Run1_Skipped,' + S:='with tr1 as (SELECT * FROM '+TESTRESULTSTableName(FRunId)+ ' WHERE TR_TESTRUN_FK='+FRunID+'), '+ + ' tr2 as (SELECT * FROM '+TESTRESULTSTableName(FCompareRunId)+' WHERE TR_TESTRUN_FK='+FCompareRunID+')'+ + ' SELECT T_ID as id,T_NAME as Filename,tr1.TR_SKIP as Run1_Skipped,' +'tr2.TR_SKIP as Run2_Skipped,tr1.TR_OK as Run1_OK,' +'tr2.TR_OK as Run2_OK, tr1.TR_Result as Run1_Result,' +'tr2.TR_RESULT as Run2_Result ' +'FROM TESTS, tr2 LEFT JOIN tr1 USING (TR_TEST_FK) ' - +'WHERE ((tr1.TR_SKIP IS NULL) or' - +' (tr2.TR_SKIP IS NULL) or ' + +'WHERE ((tr1.TR_SKIP IS NULL) or (tr2.TR_SKIP IS NULL) or ' +' (%s (tr1.TR_Result<>tr2.TR_Result)))' +'and (T_ID=tr2.TR_TEST_FK)'; If FNoSkipped then begin - Qry:='(((tr1.TR_SKIP="+") and (tr2.TR_OK="-") and (tr2.TR_SKIP="-")) or ' - +'((tr1.TR_OK="-") and (tr1.TR_SKIP="-") and (tr2.TR_SKIP="+")) or ' - +'((tr1.TR_SKIP="-") and (tr2.TR_SKIP="-"))) and '; + Qry:='(((tr1.TR_SKIP) and (not tr2.TR_OK) and (not tr2.TR_SKIP)) or ' + +'((not tr1.TR_OK) and (not tr1.TR_SKIP) and (tr2.TR_SKIP)) or ' + +'((not tr1.TR_SKIP) and (not tr2.TR_SKIP))) and '; end else Qry:=''; Qry:=Format(S,[Qry]); +// DumpLn(Qry); If FDebug then begin system.WriteLn('Query: '+Qry); @@ -2646,25 +2640,25 @@ begin Run2Field := P.Dataset.FindField('OK'); if Run2Field = nil then Run2Field := P.Dataset.FindField('Run2_OK'); - If (not FNoSkipped) and ((Skip1Field.AsString='+') - or ((Skip2Field <> nil) and (Skip2Field.AsString = '+'))) then + If (not FNoSkipped) and ((Skip1Field.AsBoolean) + or ((Skip2Field <> nil) and (Skip2Field.AsBoolean))) then begin Inc(FRunSkipCount); BGColor:='yellow'; // Yellow end - else If Run2Field.AsString='+' then + else If Run2Field.AsBoolean then begin if Run1Field.AsString='' then BGColor:='#68DFB8' - else if Run1Field.ASString<>'+' then + else if Run1Field.AsBoolean then BGColor:='#98FB98'; // pale Green end - else if Run2Field.AsString='-' then + else if Not Run2Field.AsBoolean then begin Inc(FRunFailedCount); if Run1Field.AsString='' then BGColor:='#FF82AB' // Light red - else if Run1Field.AsString<>'-' then + else if Not Run1Field.AsBoolean then BGColor:='#FF225B'; end; end; @@ -2971,6 +2965,5 @@ begin else TestsuiteCGIURL:=TestsuiteURLPrefix+'cgi-bin/'+TestsuiteBin; - SDetailsURL := TestsuiteCGIURL + '?action=1&run1id=%s'; ShortDateFormat:='yyyy/mm/dd'; end.