* The Category of a testrun is now stored into the database. The default is CategoryID is 1 for compatibility with digests without category

 * Fixed procession of db-errors
 * Added support for adding new fpcunit-tests and parse the testunits

git-svn-id: trunk@9853 -

tests/utils/dbdigest.pp

@@ -68,6 +68,7 @@ TConfigOpt = (
   coLogFile,
   coOS,
   coCPU,
+  coCategory,
   coVersion,
   coDate,
   coSubmitter,
@@ -87,6 +88,7 @@ ConfigStrings : Array [TConfigOpt] of string = (
   'logfile',
   'os',
   'cpu',
+  'category',
   'version',
   'date',
   'submitter',
@@ -97,12 +99,13 @@ ConfigStrings : Array [TConfigOpt] of string = (
 );
 
 ConfigOpts : Array[TConfigOpt] of char
-           = ('d','h','u','p','l','o','c','v','t','s','m','C','S','V');
+           = ('d','h','u','p','l','o','c','a','v','t','s','m','C','S','V');
 
 Var
   TestOS,
   TestCPU,
   TestVersion,
+  TestCategory,
   DatabaseName,
   HostName,
   UserName,
@@ -125,6 +128,7 @@ begin
     coLogFile      : LogFileName:=Value;
     coOS           : TestOS:=Value;
     coCPU          : TestCPU:=Value;
+    coCategory     : TestCategory:=Value;
     coVersion      : TestVersion:=Value;
     coDate         : 
       begin
@@ -258,6 +262,7 @@ Var
   TestCPUID : Integer;
   TestOSID  : Integer;
   TestVersionID  : Integer;
+  TestCategoryID : Integer;
   TestRunID : Integer;
 
 Procedure GetIDs;
@@ -269,6 +274,12 @@ begin
   TestOSID  := GetOSID(TestOS);
   If TestOSID=-1 then
     Verbose(V_Error,'NO ID for OS "'+TestOS+'" found.');
+  TestCategoryID := GetCategoryID(TestCategory);
+  If TestCategoryID=-1 then
+    begin
+//    Verbose(V_Error,'NO ID for Category "'+TestCategory+'" found.');
+    TestCategoryID:=1;
+    end;
   TestVersionID  := GetVersionID(TestVersion);
   If TestVersionID=-1 then
     Verbose(V_Error,'NO ID for version "'+TestVersion+'" found.');
@@ -277,7 +288,7 @@ begin
   TestRunID:=GetRunID(TestOSID,TestCPUID,TestVersionID,TestDate);
   If (TestRunID=-1) then
     begin
-    TestRunID:=AddRun(TestOSID,TestCPUID,TestVersionID,TestDate);
+    TestRunID:=AddRun(TestOSID,TestCPUID,TestVersionID,TestCategoryID,TestDate);
     If TestRUnID=-1 then
       Verbose(V_Error,'Could not insert new testrun record!');
     end

tests/utils/dbtests.pp

@@ -20,9 +20,10 @@ Uses
 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 : 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;
@@ -105,7 +106,7 @@ Function RunQuery (Qry : String; Var res : TQueryResult) : Boolean ;
 
 begin
   Verbose(V_DEBUG,'Running query:'+Qry);
-  Result:=mysql_query(@Connection,PChar(qry))>=0;
+  Result:=mysql_query(@Connection,PChar(qry))=0;
   If Not Result then
     Verbose(V_WARNING,'Query : '+Qry+'Failed : '+Strpas(mysql_error(@connection)))
   else
@@ -207,6 +208,14 @@ 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;
 
@@ -222,24 +231,103 @@ begin
   Result:=IDQuery(Format(SFromIDS,[OSID,CPUID,VERSIONID,SQLDate(Date)]));
 end;
 
-Function AddRun(OSID, CPUID, VERSIONID : Integer; Date : TDateTime) : Integer;
+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_DATE)'+
+               '(TU_OS_FK,TU_CPU_FK,TU_VERSION_FK,TU_CATEGORY_FK,TU_DATE)'+
                ' VALUES '+
-               '(%d,%d,%d,"%s")';
+               '(%d,%d,%d,%d,"%s")';
 
 Var
   Res : TQueryResult;
 
 begin
-  If RunQuery(Format(SInsertRun,[OSID,CPUID,VERSIONID,SQLDate(Date)]),Res) then
+  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 := lowercase(TestSrcDir+Path+DirectorySeparator+copy(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;
 
@@ -253,8 +341,9 @@ Var
 
 begin
   Result:=-1;
-  If FileExists(TestSrcDir+Name) and
-     GetConfig(TestSrcDir+Name,Info) then
+  If (FileExists(TestSrcDir+Name) and
+     GetConfig(TestSrcDir+Name,Info)) or
+     GetUnitTestConfig(Name,Info) then
     begin
     If RunQuery(Format(SInsertTest,[Name]),Res) then
       begin