* Test insight

packages/fpcunit/namespaced/TestInsight.Client.pp

@@ -0,0 +1,3 @@
+{$DEFINE FPC_DOTTEDUNITS}
+unit TestInsight.Client;
+{$i ../src/testinsightclient.pp}

packages/fpcunit/namespaced/TestInsight.FpcUnit.pp

@@ -0,0 +1,3 @@
+{$DEFINE FPC_DOTTEDUNITS}
+unit TestInsight.FpcUnit;
+{$i ../src/fpcunittestinsight.pp}

packages/fpcunit/namespaced/TestInsight.Protocol.pp

@@ -0,0 +1,3 @@
+{$DEFINE FPC_DOTTEDUNITS}
+unit TestInsight.Protocol;
+{$i ../src/testinsightprotocol.pp}

packages/fpcunit/src/fpcunittestinsight.pp

@@ -0,0 +1,379 @@
+{
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 2023 by Michael Van Canneyt
+
+    Test Insight FPCUnit test listener.
+    
+    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.
+
+ **********************************************************************}
+{$IFNDEF FPC_DOTTEDUNITS}
+unit fpcunittestinsight;
+{$ENDIF}
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+uses
+{$IFDEF FPC_DOTTEDUNITS}
+  System.Classes, System.SysUtils, System.Types, FpJson.Data, FpcUnit.Test, FpcUnit.Registry, TestInsight.Protocol, TestInsight.Client;
+{$ELSE}
+  Classes, SysUtils, types, fpjson, fpcunit, testregistry, testinsightprotocol, testinsightclient;
+{$ENDIF}
+
+type
+
+  { TFPCUnitTestInsightHelper }
+
+  TFPCUnitTestInsightHelper = Class helper for TTestInsightResult
+    Procedure FromTestFailure(ATest: TTest; aFailure: TTestFailure);
+  end;
+
+  { TTestInsightListener }
+
+  TTestInsightListener = class(ITestListener)
+  private
+    fClient: TAbstractTestInsightClient;
+    fSelectedTests: TStringDynArray;
+    FLastError : TTest;
+    FStart : TDateTime;
+    FRootTest : TTest;
+  Public
+    procedure AddFailure(ATest: TTest; aFailure: TTestFailure); override;
+    procedure AddError(ATest: TTest; aError: TTestFailure); override;
+    procedure StartTest(ATest: TTest); override;
+    procedure EndTest(ATest: TTest); override;
+    procedure StartTestSuite(ATestSuite: TTestSuite); override;
+    procedure EndTestSuite(ATestSuite: TTestSuite); override;
+    procedure SendTestSuite; virtual;
+  public
+    constructor Create(const aClient : TAbstractTestInsightClient; aRoot: TTest);
+    Property RootTest : TTest Read FRootTest;
+  end;
+
+
+procedure RunRegisteredTests(aClient : TAbstractTestinsightClient);
+procedure RunRegisteredTests(OnCreated,Onerror : TTestInsightClientEvent; const aConfig : String = ''; const baseUrl: string = DefaultUrl);
+procedure IsTestinsightListening(OnCreated,Onerror : TTestInsightClientEvent; const aConfig : String = ''; const baseUrl: string = DefaultUrl) ;
+Function DefaultTestConfigFileName : String;
+Function TestSuiteToJSON(aSuite : TTest) : TJSONObject;
+Procedure TestSuiteToJSON(aSuite : TTest; aJSON : TJSONObject);
+
+
+implementation
+
+uses
+{$IFDEF FPC_DOTTEDUNITS}
+  System.DateUtils;
+{$ELSE}  
+  DateUtils;
+{$ENDIF}
+
+Function DefaultTestConfigFileName : String;
+begin
+  Result:='TestInsightSettings.json';
+end;
+
+function TestSuiteToJSON(aSuite: TTest): TJSONObject;
+begin
+  Result:=TJSONObject.Create;
+  try
+   TestSuiteToJSOn(aSuite,Result);
+  except
+    Result.Free;
+    Raise;
+  end;
+end;
+
+procedure TestSuiteToJSON(aSuite: TTest; aJSON: TJSONObject);
+
+Var
+  T : TTest;
+  I : Integer;
+  j : TJSONObject;
+
+begin
+  For I:=0 to aSuite.GetChildTestCount-1 do
+    begin
+    T:=aSuite.GetChildTest(I);
+    if T is TTestSuite then
+      begin
+      J:=TJSONObject.Create;
+      aJSON.Add(T.TestName,J);
+      TestSuiteToJSON(T as TTestSuite,J);
+      end
+    else
+      aJSON.Add(T.TestName);
+    end;
+end;
+
+
+procedure CreateClient(OnCreated,Onerror : TTestInsightClientEvent; const aConfig : String = ''; const baseUrl: string = DefaultUrl);
+
+Var
+  aURL,Cfg : String;
+  aClient : TAbstractTestInsightClient;
+
+
+    Procedure DoLoad;
+    begin
+      TestInsightLog.Log('Configuration "%s" loaded',[Cfg]);
+      OnCreated(aClient);
+    end;
+
+    Procedure DoError;
+    begin
+      TestInsightLog.Log('Configuration "%s" not loaded',[Cfg]);
+      OnError(aClient);
+    end;
+
+
+begin
+  Cfg:=aConfig;
+  if (Cfg='') then
+    Cfg:=DefaultTestConfigFileName;
+  aURL:=baseURL;
+  if aURL='' then
+    aURL:=DefaultURL;
+  aClient:=TTestInsightHTTPClient.Create(aURL);
+  aClient.LoadConfig(Cfg,@DoLoad,@DoError);
+end;
+
+Procedure IsTestinsightListening(OnCreated,Onerror : TTestInsightClientEvent; const aConfig : String = ''; const baseUrl: string = DefaultUrl) ;
+
+  Procedure DoConfig(aClient : TAbstractTestInsightClient);
+  begin
+    aClient.GetServerOptions._then(function(j : jsvalue) : jsvalue
+      begin
+      if assigned(OnCreated) then
+        OnCreated(aClient);
+      end
+    ,function(j : jsvalue) : jsvalue
+    begin
+      Result:=False;
+      if assigned(OnError) then
+        OnError(aClient);
+    end);
+
+  end;
+
+  Procedure DoNoConfig(aClient : TAbstractTestInsightClient);
+  begin
+    aClient.GetServerOptions._then(function(j : jsvalue) : jsvalue
+      begin
+      if assigned(OnError) then
+        OnError(aClient);
+      end
+    ,function(j : jsvalue) : jsvalue
+    begin
+      Result:=False;
+     if assigned(OnError) then
+        OnError(aClient);
+    end);
+  end;
+
+begin
+  CreateClient(@DoConfig,@DoNoConfig,aConfig,BaseURL);
+end;
+
+Procedure AddSkips (aResult : TTestResult; aSuite : TTest; aAllowed : TTest);
+
+Var
+  I : Integer;
+  T : TTest;
+
+begin
+  if (aSuite=aAllowed) then exit;
+  for I:=0 to aSuite.GetChildTestCount-1 do
+    begin
+    T:=aSuite.GetChildTest(I);
+    if T is TTestCase then
+      aResult.AddToSkipList(T as TTestCase)
+    else
+      AddSkips(aResult,T,aAllowed)
+    end;
+end;
+
+procedure RunRegisteredTests(aClient: TAbstractTestInsightClient);
+
+var
+  Suite: TTest;
+  TestResult: TTestResult;
+  Listener: TTestInsightListener;
+
+begin
+  Suite := GetTestRegistry;
+  if not Assigned(Suite) then
+    Exit;
+  Listener:=TTestInsightListener.Create(aClient,Suite);
+  if aClient.Options.ExecuteTests then
+    begin
+    TestResult := TTestResult.Create;
+    if aClient.Options.TestSuite<>'' then
+      AddSkips(TestResult,Suite,Suite.FindTest(aClient.Options.TestSuite));
+    TestResult.AddListener(Listener);
+    Suite.Run(TestResult);
+    end
+  else
+    FreeAndNil(Listener);
+end;
+
+procedure RunRegisteredTests(OnCreated,Onerror : TTestInsightClientEvent; const aConfig : String = ''; const baseUrl: string = DefaultUrl);
+
+    procedure DoCreateOK(aClient: TAbstractTestInsightClient);
+
+    begin
+      RunRegisteredTests(aClient);
+      if Assigned(OnCreated) then
+        OnCreated(aClient);
+    end;
+
+    procedure DoCreateError(aClient: TAbstractTestInsightClient);
+    begin
+      TestInsightLog.Log('Error in config, attempting execute anyway');
+      if assigned(OnError) then
+        OnError(aClient);
+      DoCreateOK(aClient);
+    end;
+
+
+begin
+  if not Assigned(GetTestRegistry) then
+    Exit;
+  CreateClient(@DoCreateOK,@DoCreateError,aConfig,BaseURL);
+end;
+
+{ TFPCUnitTestInsightHelper }
+
+procedure TFPCUnitTestInsightHelper.FromTestFailure(ATest: TTest; aFailure: TTestFailure);
+
+Const
+  TestStepToPhase : Array[TTestStep] of TTestPhase
+    = (tpSetUp, tpRunTest, spTearDown, tpNothing);
+
+
+begin
+  TestName:=aTest.TestSuiteName+'.'+aTest.TestName;
+  TestClassName:=aTest.ClassName;
+  TestUnitName:=aTest.UnitName;
+  TestMethodName := aTest.TestName;
+  if not Assigned(aFailure) then
+    exit;
+  TestExceptionMessage := aFailure.ExceptionMessage;
+  TestExceptionClass:= aFailure.ExceptionClassName;
+  TestIsIgnored:=aFailure.IsIgnoredTest;
+  if aFailure.IsFailure then
+    TestResult:=rtFailed
+  else
+    TestResult:=rtError;
+  TestPhase:=TestStepToPhase[aFailure.TestLastStep];
+  FailureLineNumber:=aFailure.LineNumber;
+  FailureUnitName:=aFailure.UnitName;
+  FailureMethodName:=aFailure.FailedMethodName;
+  FailureSourceUnitName:=aFailure.SourceUnitName;
+//  FailureLocationInfo:=aFailure.LocationInfo;
+end;
+
+{ TTestInsightTestListener }
+
+constructor TTestInsightListener.Create(const aClient : TAbstractTestInsightClient; aRoot : TTest);
+
+  function HaveTests (t : JSValue) : JSValue;
+  begin
+    fSelectedTests:=TStringDynArray(t);
+  end;
+
+begin
+  inherited Create;
+  fClient := aClient;
+  fClient.GetTests._then(@haveTests);
+
+  FRootTest:=aRoot;
+  SendTestSuite;
+end;
+
+procedure TTestInsightListener.AddError(ATest: TTest; aError: TTestFailure);
+
+var
+  testResult: TTestInsightResult;
+begin
+  testResult := TTestInsightResult.Create;
+  testResult.FromTestFailure(aTest,aError);
+  testResult.TestResult := rtError;
+  fClient.PostResult(testResult,false);
+end;
+
+procedure TTestInsightListener.AddFailure(ATest: TTest; aFailure: TTestFailure);
+var
+  testResult: TTestInsightResult;
+begin
+  testResult := TTestInsightResult.Create;
+  testResult.FromTestFailure(aTest,aFailure);
+  if aFailure.ExceptionMessage = SAssertNotCalled then
+    testResult.TestResult := rtWarning
+  else
+    testResult.TestResult := rtFailed;
+  fClient.PostResult(testResult,False);
+  FLastError:=aTest;
+end;
+
+
+procedure TTestInsightListener.EndTestSuite(ATestSuite: TTestSuite);
+begin
+  if (aTestSuite=FRootTest) then
+    fClient.FinishedTesting;
+end;
+
+procedure TTestInsightListener.StartTestSuite(ATestSuite: TTestSuite);
+begin
+  if (aTestSuite=FRootTest) then
+    fClient.StartedTesting(FRootTest.CountTestCases);
+end;
+
+procedure TTestInsightListener.StartTest(ATest: TTest);
+
+begin
+  FStart:=Now;
+end;
+
+procedure TTestInsightListener.EndTest(ATest: TTest);
+
+var
+  testResult: TTestInsightResult;
+
+begin
+  if Not ({IsTestMethod(aTest) and} (fLastError <> Atest)) then
+    exit;
+  testResult := TTestInsightResult.Create;
+  TestResult.TestName:=aTest.TestSuiteName+'.'+aTest.TestName;
+  TestResult.TestResult:=rtPassed;
+  testResult.TestDuration := MilliSecondsBetween(Now,FStart);
+  testResult.TestUnitName := aTest.UnitName;
+  testResult.TestClassName := ATest.ClassName;
+  testResult.TestMethodName := aTest.TestName;
+  fClient.PostResult(testResult,False);
+end;
+
+
+procedure TTestInsightListener.SendTestSuite;
+
+Var
+  aJSON : TJSONObject;
+
+begin
+  aJSON:=TestSuiteToJSON(FRootTest);
+  try
+    fClient.SetTestNames(aJSON);
+  finally
+    aJSON.Free;
+  end;
+end;
+
+end.
+

packages/fpcunit/src/testinsightclient.pp

@@ -0,0 +1,465 @@
+{
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 2023 by Michael Van Canneyt
+
+    Test Insight client component.
+    
+    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.
+
+ **********************************************************************}
+{$IFNDEF FPC_DOTTEDUNITS} 
+unit testinsightclient;
+{$ENDIF}
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+uses
+{$IFDEF FPC_DOTTEDUNITS} 
+  System.Classes, System.SysUtils, System.Types, TestInsight.Protocol, FpWeb.Http.Client, FpJson.Data, System.Contnrs, System.IniFiles, JSAPi.JS;
+{$ELSE}
+  Classes, SysUtils, types, testinsightprotocol, weborworker, fpjson, contnrs, js;
+{$ENDIF}
+
+Type
+
+  { TAbstractTestInsightClient }
+  TLoadedProcedure = reference to procedure;
+
+  TAbstractTestInsightClient = class (TObject)
+  private
+    FOptions : TTestInsightOptions;
+    FPendingResultCount: Integer;
+    FRequestTimeOut: cardinal;
+    FResults : TFPObjectList;
+    FBaseURL : String;
+    procedure SetOptions(const value: TTestInsightOptions);
+  protected
+    function JSONToTests(const aJSON: string): TStringDynArray;
+    // URL is Relative to base URL
+    function ServerPost(const aURL: string; const aContent: string = ''): Boolean; async; virtual; abstract;
+    function ServerGet(const aURL: string) : string; async; virtual; abstract;
+    function ServerDelete(const aURL: string) : boolean; async; virtual; abstract;
+    Function ConcatURL(const aURL : String) : String; virtual;
+  Public
+    const
+      DefaultRequestTimeOut = 5000;
+  public
+    constructor Create(const aBaseURL : String); virtual;
+    destructor Destroy; override;
+    procedure LoadConfig(const aUrl : String; OnLoaded,OnError : TLoadedProcedure);
+    procedure LoadConfig(aConfig: TJSObject);
+    function GetServerOptions : TJSPromise;
+    // The client will free the result.
+    procedure PostResult(const testResult: TTestInsightResult; forceSend: Boolean);
+    // The client will free the results.
+    procedure PostResults(const testResults: array of TTestInsightResult; forceSend: Boolean);
+    procedure StartedTesting(const totalCount: Integer);
+    procedure FinishedTesting;
+    procedure ClearTests;
+    Procedure SetTestNames(aJSON : TJSONObject);
+    function GetTests: TJSPromise;
+    property Options: TTestInsightOptions read FOptions write SetOptions;
+    Property BaseURL : String Read FBaseURL;
+    Property PendingResultCount : Integer Read FPendingResultCount;
+    Property RequestTimeout: cardinal Read FRequestTimeOut Write FRequestTimeout;
+  end;
+
+  TTestInsightClientEvent = reference to Procedure(aClient : TAbstractTestInsightClient);
+  TTestInsightClientErrorEvent = reference to function(aClient : TAbstractTestInsightClient) : Boolean;
+
+  { TTestInsightHTTPClient }
+
+  TFetchConfigEvent = Procedure (Sender : TObject; aConfig : TJSObject) of object;
+
+  TTestInsightHTTPClient = class(TAbstractTestInsightClient)
+  private
+    FOnCreateFetchOptions: TFetchConfigEvent;
+  protected
+    function CreateFetchOptions(const aMethod: String): TJSObject; virtual;
+    function ServerPost(const aURL: string; const aContent: string = '') : boolean; async; override;
+    Function ServerGet(const aURL: string) : string; async; override;
+    function ServerDelete(const aURL: string) : boolean; async; override;
+  public
+    Constructor Create(Const aBaseURL : String); override;
+    Destructor Destroy; override;
+    Property OnCreateFetchOptions : TFetchConfigEvent Read FOnCreateFetchOptions Write FOnCreateFetchOptions;
+  end;
+
+  { TTestInsightLogger }
+
+  TTestInsightLogger = class(TObject)
+    Procedure Log(const Msg : string); virtual;
+    Procedure Log(const Fmt : string; args : array of const);
+    Procedure Debug(const value : JSValue); virtual;
+  end;
+
+var
+  TestInsightLog : TTestInsightLogger;
+
+implementation
+
+{ TTestInsightHTTPClient }
+
+Procedure WriteLog(const Msg : string);
+begin
+  if assigned(TestInsightLog) then
+    TestInsightLog.Log(Msg)
+end;
+
+Procedure DebugLog(const value : JSValue);
+
+begin
+  if assigned(TestInsightLog) then
+    TestInsightLog.Debug(Value)
+end;
+
+
+function TTestInsightHTTPClient.CreateFetchOptions(const aMethod : String) : TJSObject;
+
+begin
+  Result:=New(
+    ['method',aMethod,
+     'mode','cors',
+     'signal',TJSAbortSignal.timeout(FRequestTimeout),
+     'headers', new([
+       'Content-Type','application/json'
+     ])
+    ]);
+  If Assigned(FOnCreateFetchOptions) then
+    FOnCreateFetchOptions(Self,Result);
+end;
+
+function TTestInsightHTTPClient.ServerPost(const aURL: string; const aContent: string = '') : boolean;
+
+var
+  opts : TJSObject;
+  response: TJSResponse;
+
+begin
+  opts:=CreateFetchOptions('POST');
+  opts['body']:=aContent;
+  response:=await(TJSResponse,fetch(ConcatUrl(aURL),opts));
+  result:=(response.status div 100)=2;
+end;
+
+function TTestInsightHTTPClient.ServerGet(const aURL: string): string;
+
+var
+  opts : TJSObject;
+  response: TJSResponse;
+
+begin
+  opts:=CreateFetchOptions('GET');
+  try
+    response:=await(TJSResponse,fetch(ConcatUrl(aURL),opts));
+    if (response.status div 100)=2 then
+      Result:=await(Response.text)
+    else
+      Result:='';
+
+  except
+    on E : Exception do
+      Writeln('Exception : ',E.Message);
+    on JE : TJSError do
+      Writeln('Exception : ',JE.Message);
+  end;
+end;
+
+function TTestInsightHTTPClient.ServerDelete(const aURL: string) : boolean;
+
+var
+  opts : TJSObject;
+  response: TJSResponse;
+
+begin
+  opts:=CreateFetchOptions('GET');
+  response:=await(TJSResponse,fetch(ConcatUrl(aURL),opts));
+  Result:=(response.status div 100)=2;
+end;
+
+constructor TTestInsightHTTPClient.Create(const aBaseURL: String);
+begin
+  inherited Create(aBaseURL);
+end;
+
+destructor TTestInsightHTTPClient.Destroy;
+begin
+  inherited Destroy;
+end;
+
+
+{ TAbstractTestInsightClient }
+
+procedure TAbstractTestInsightClient.SetOptions(const value: TTestInsightOptions
+  );
+begin
+  FOptions.Assign(Value);
+end;
+
+
+function TAbstractTestInsightClient.JSONToTests(const aJSON: string): TStringDynArray;
+
+Var
+  D : TJSONData;
+  A : TJSONArray;
+  I : Integer;
+
+begin
+  Result:=[];
+  D:=GetJSON(aJSON);
+  try
+    if D=Nil then exit;
+    if D.JSONType=jtArray then
+      A:=D as TJSONArray
+    else if (D.Count=1) and (D.Items[0].JSONType=jtArray) then
+      A:=D.Items[0] as TJSONArray
+    else
+      A:=nil;
+    if A<>Nil then
+      begin
+      SetLength(Result,a.Count);
+      For I:=0 to Length(Result)-1 do
+        Result[i]:=A.Strings[i];
+      end;
+  finally
+    D.Free;
+  end;
+end;
+
+function TAbstractTestInsightClient.ConcatURL(const aURL: String): String;
+begin
+  Result:=fBaseURL;
+  if (Result<>'') and (aURL<>'') and (Result[Length(Result)]<>'/') then
+    Result:=Result+'/';
+  Result:=Result+aURL;
+end;
+
+constructor TAbstractTestInsightClient.Create(const aBaseURL: String);
+begin
+  FBaseURL:=aBaseURL;
+  FOptions:=TTestInsightOptions.Create;
+  FResults:=TFPObjectList.Create(False);
+  FRequestTimeOut:=DefaultRequestTimeOut;
+end;
+
+destructor TAbstractTestInsightClient.Destroy;
+begin
+  FResults.Clear;
+  FreeAndNil(FResults);
+  FreeAndNil(FOptions);
+  inherited Destroy;
+end;
+
+procedure TAbstractTestInsightClient.LoadConfig(const aUrl: String; OnLoaded, OnError: TLoadedProcedure);
+
+  function doerror(resp : jsvalue) : jsvalue;
+
+  begin
+    if assigned(OnError) then
+      OnError
+    else
+      begin
+      console.log('Error loading testinsight client config:');
+      console.debug(resp);
+      end;
+  end;
+
+  function jsonok(resp : jsvalue) : jsvalue;
+
+  var
+    V : TJSObject absolute resp;
+
+  begin
+    LoadConfig(V);
+    if assigned(OnLoaded) then
+      OnLoaded();
+  end;
+
+  function loadok(resp : jsvalue) : jsvalue;
+
+  var
+    Response : TJSResponse absolute resp;
+
+  begin
+    if Response.status=200 then
+      Response.json._then(@jsonok,@doError)
+    else
+      DoError(TJSError.New(Response.statusText));
+  end;
+
+
+var
+  Opts : TJSObject;
+
+begin
+  Opts:=New([
+    'method','GET',
+    'mode','cors',
+    'signal',TJSAbortSignal.timeout(FRequestTimeout)
+  ]);
+  Fetch(aUrl,Opts)._then(@LoadOK,@doError)
+end;
+
+procedure TAbstractTestInsightClient.LoadConfig(aConfig: TJSObject);
+
+begin
+  if aConfig.hasOwnProperty(KeyBaseURL) and isString(aConfig[KeyBaseURL]) then
+    FBaseURL:=string(aConfig[KeyBaseURL]);
+  if aConfig.hasOwnProperty(keyShowProgress) and isBoolean(aConfig[keyShowProgress]) then
+    Options.ShowProgress:=Boolean(aConfig[keyShowProgress]);
+  if aConfig.hasOwnProperty(KeyExecuteTests) and isBoolean(aConfig[KeyExecuteTests]) then
+    Options.ExecuteTests:=Boolean(aConfig[KeyExecuteTests]);
+  if aConfig.hasOwnProperty(KeySuite) and isString(aConfig[KeySuite]) then
+    Options.TestSuite:=String(aConfig[KeySuite]);
+end;
+
+function TAbstractTestInsightClient.GetServerOptions : TJSPromise;
+
+  procedure DoOptions(resolve, reject: TJSPromiseResolver); async;
+
+  var
+    S : String;
+
+  begin
+    try
+      S:=Await(ServerGet(PathOptions));
+      Options.FromJSON(S);
+      resolve(Options);
+    except
+      on E : Exception do
+        Reject(E);
+      on JE : TJSError do
+        Reject(JE);
+    end;
+  end;
+
+begin
+  Result:=TJSPromise.new(@DoOptions);
+end;
+
+procedure TAbstractTestInsightClient.PostResult(
+  const testResult: TTestInsightResult; forceSend: Boolean);
+begin
+  PostResults([testResult],forceSend);
+end;
+
+procedure TAbstractTestInsightClient.PostResults(
+  const testResults: array of TTestInsightResult; forceSend: Boolean);
+
+Var
+  Res : TTestInsightResult;
+  J : TJSONArray;
+  O : TJSONOBject;
+
+
+begin
+  if ForceSend or (Options.ShowProgress and Options.ExecuteTests) then
+    begin
+    J:=TJSONArray.Create;
+    try
+      For Res in testResults do
+        begin
+        O:=TJSONObject.Create;
+        J.Add(O);
+        Res.ToJSON(O);
+        Res.Free;
+        end;
+      ServerPost(pathResults,J.AsJSON);
+    finally
+      J.Free;
+    end;
+    end
+  else
+    For Res in TestResults do
+      FResults.Add(res);
+end;
+
+procedure TAbstractTestInsightClient.StartedTesting(const totalCount: Integer);
+begin
+  ServerPost(Format('%s?%s=%d', [pathStarted,qryTotalCount,Totalcount]),'');
+end;
+
+procedure TAbstractTestInsightClient.FinishedTesting;
+
+Var
+  A : Array of TTestInsightResult;
+  Len,I : Integer;
+
+begin
+  A:=[];
+  Len:=FResults.Count;
+  if (Len>0) then
+    begin
+    Setlength(A,Len);
+    For I:=0 to Len-1 do
+      A[I]:=TTestInsightResult(FResults[i]);
+    try
+      PostResults(A,True);
+    finally
+      FResults.Clear;
+    end;
+    end;
+  ServerPost(pathFinished,'');
+end;
+
+procedure TAbstractTestInsightClient.ClearTests;
+begin
+  ServerDelete(pathResults);
+end;
+
+procedure TAbstractTestInsightClient.SetTestNames(aJSON : TJSONObject);
+
+begin
+  ServerPost('',aJSON.AsJSON);
+end;
+
+function TAbstractTestInsightClient.GetTests: TJSPromise;
+
+  procedure DoGetTests(resolve, reject: TJSPromiseResolver); async;
+
+  begin
+    try
+      resolve(JSONToTests(await(ServerGet(''))));
+    except
+      on E : Exception do
+        Reject(E);
+      on JE : TJSError do
+        Reject(JE);
+    end;
+  end;
+
+begin
+  Result:=TJSPromise.New(@DoGetTests);
+end;
+
+
+{ TTestInsightLogger }
+
+procedure TTestInsightLogger.Log(const Msg: string);
+begin
+  console.log(Msg);
+end;
+
+
+procedure TTestInsightLogger.Log(const Fmt: string; args: array of const);
+begin
+  Log(Format(Fmt,Args));
+end;
+
+procedure TTestInsightLogger.Debug(const value: JSValue);
+begin
+  console.debug(Value);
+end;
+
+
+initialization
+  TestInsightLog:=TTestInsightLogger.Create;
+end.
+

packages/fpcunit/src/testinsightprotocol.pp

@@ -0,0 +1,403 @@
+{
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 2023 by Michael Van Canneyt
+
+    Test Insight protocol description.
+    
+    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.
+
+ **********************************************************************}
+{$IFNDEF FPC_DOTTEDUNITS} 
+unit testinsightprotocol;
+{$ENDIF}
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+uses
+{$IFDEF FPC_DOTTEDUNITS} 
+  System.Classes, System.SysUtils, FpJson.Data;
+{$ELSE}
+  Classes, SysUtils, fpJSON;
+{$ENDIF}
+
+Type
+  ETestInsight = class(Exception);
+
+  TTestResultType = (rtUnknown, rtPassed, rtFailed, rtError, rtWarning, rtSkipped, rtRunning);
+  TTestPhase = (tpSetUp, tpRunTest, spTearDown, tpNothing);
+
+
+  { TTestInsightResult }
+
+  TTestInsightResult = Class
+  Public
+    TestResult : TTestResultType;
+    TestName: string;
+    TestDuration: Integer;
+    TestUnitName: string;
+    TestClassName: string;
+    TestMethodName: string;
+    // Status
+    TestStatus: string;
+    TestExceptionMessage: string;
+    TestExceptionClass: string;
+    TestIsIgnored : Boolean;
+    TestPhase : TTestPhase;
+    // Failure info
+    FailureUnitName: string;
+    FailureMethodName: string;
+    FailureLineNumber: Integer;
+    FailureSourceUnitName : String; // Exception
+    FailureLocationInfo : String;
+    Constructor Create; virtual;
+    procedure FromJSON(const aJSON : TJSONStringType); overload;
+    procedure FromJSON(const aJSON : TJSONObject); overload;
+    function ToJSON: string;
+    Procedure ToJSON(aJSON : TJSONObject);
+  end;
+  TTestInsightResultClass = Class of TTestInsightResult;
+  TTestInsightResultArray = Array of TTestInsightResult;
+
+  { TTestInsightOptions }
+
+  TTestInsightOptions = Class (TPersistent)
+  Public
+    ExecuteTests: Boolean;
+    ShowProgress: Boolean;
+    TestSuite : String;
+    Constructor Create; virtual;
+    Procedure Assign(Source : TPersistent); override;
+    procedure FromJSON(const aJSON : TJSONStringType); overload;
+    procedure FromJSON(const aJSON : TJSONObject); overload;
+    function ToJSON: string;
+    Procedure ToJSON(aJSON : TJSONObject);
+  end;
+  TTestInsightOptionsClass = Class of TTestInsightOptions;
+
+Const
+  // Used in URLS
+  DefaultUrl = 'http://localhost:8081/tests';
+
+  pathTests = '/tests';
+  pathStarted = 'started';
+  pathFinished = 'finished';
+  pathResults = 'results';
+  pathOptions = 'options';
+  qryTotalCount = 'totalcount';
+
+  // Used in TTestInsightResult JSON encoding.
+  keyTestName = 'testname';
+  KeyTestUnitName = 'testunitname';
+  keyTestClassName = 'testclassname';
+  keyTestMethodName = 'testmethodname';
+  keyTestDuration = 'testduration';
+
+  keyResultType = 'testresulttype';
+  keyExceptionMessage = 'exceptionmessage';
+  KeyExceptionClass = 'exceptionclass';
+
+  keyfailureMethodName = 'failuremethodname';
+  keyFailureUnitName = 'failureunitname';
+  keyFailureLineNumber = 'failurelinenumber';
+  KeyFailureSourceUnitName = 'failuresourceunitname';
+  KeyFailureLocationInfo = 'location';
+
+  keyStatus = 'status';
+  keyIsIgnored = 'ignored';
+  KeyTestPhase = 'phase';
+
+  // Config file settings
+  SConfig = 'Config';
+  KeyBaseURL = 'BaseUrl';
+
+  // Used in TTestInsightOptions JSON encoding and Ini file
+  keyExecuteTests = 'ExecuteTests';
+  keyShowProgress = 'ShowProgress';
+  KeySuite = 'Suite';
+
+  ResultTypeNames: array[TTestResultType] of string
+    = ('?','Passed', 'Failed', 'Error', 'Warning', 'Skipped', 'Running');
+  TestPhaseNames: array[TTestPhase] of string
+    = ('Setup', 'Run', 'TearDown','');
+
+Function StringToResultType(const aValue : string) : TTestResultType;
+Function ResultTypeToString(aValue : TTestResultType) : string;
+
+Function StringToTestPhase(const aValue : string) : TTestPhase;
+Function TestPhaseToString(aValue : TTestPhase) : string;
+
+
+// Convert CR/LF separated list name to expected JSON format
+Function TestStringsToJSON(const aContent : String): TJSONObject;
+
+
+implementation
+
+Function ResultTypeToString(aValue : TTestResultType) : string;
+begin
+  Result:=ResultTypeNames[aValue];
+end;
+
+function StringToTestPhase(const aValue: string): TTestPhase;
+Var
+  T : TTestPhase;
+
+begin
+  Result:=tpNothing;
+  For T in TTestPhase do
+    if SameText(TestPhaseNames[T],aValue) then
+      Exit(T);
+end;
+
+function TestPhaseToString(aValue: TTestPhase): string;
+begin
+  Result:=TestPhaseNames[aValue];
+end;
+
+Function StringToResultType(const aValue : string) : TTestResultType;
+
+Var
+  T : TTestResultType;
+
+begin
+  Result:=rtFailed;
+  For T in TTestResultType do
+    if SameText(ResultTypeNames[T],aValue) then
+      Exit(T);
+end;
+
+Procedure AddTests(aParent : TJSONObject; aList : TStrings; const aPath : String; var aIdx : Integer);
+
+Var
+  P : integer;
+  Up : Boolean;
+  Curr,Sub : String;
+  Obj : TJSONObject;
+
+begin
+  Repeat
+    Curr:=aList[aIdx];
+    Up:=(aPath<>'') and Not SameText(Copy(Curr,1,Length(aPath)),aPath);
+    if not Up then
+      begin
+      Delete(Curr,1,Length(aPath));
+      if Curr[1]='.' then delete(Curr,1,1);
+      P:=Pos('.',Curr);
+      if P<>0 then
+        begin
+        Sub:=Copy(Curr,1,P-1);
+        Obj:=TJSONObject.Create;
+        aParent.Add(Sub,Obj);
+        if aPath<>'' then
+          AddTests(Obj,aList,APath+'.'+Sub,aIdx)
+        else
+          AddTests(Obj,aList,Sub,aIdx)
+        end
+      else
+        begin
+        aParent.Add(Curr,TJSONNull.Create);
+        Inc(aIdx);
+        end;
+      end
+  Until (aIdx>=aList.Count) or Up;
+end;
+
+
+Function TestStringsToJSON(const aContent : String): TJSONObject;
+
+Var
+  L : TStringList;
+  aPath : String;
+  aIdx : Integer;
+
+begin
+  Result:=nil;
+  L:=TStringList.Create;
+  try
+    L.Text:=aContent;
+    L.Sort;
+    Result:=TJSONObject.Create;
+    aPath:='';
+    aIdx:=0;
+    AddTests(Result,L,aPath,aIdx);
+  finally
+    L.Free;
+  end;
+end;
+
+{ TTestInsightOptions }
+
+constructor TTestInsightOptions.Create;
+begin
+  ExecuteTests:=True;
+  ShowProgress:=True;
+end;
+
+procedure TTestInsightOptions.Assign(Source: TPersistent);
+
+var
+  Src : TTestInsightOptions absolute source;
+
+begin
+  if Source is TTestInsightOptions then
+    begin
+    ExecuteTests:=Src.ExecuteTests;
+    ShowProgress:=Src.ShowProgress;
+    TestSuite:=Src.TestSuite;
+    end
+  else
+    inherited Assign(Source);
+end;
+
+procedure TTestInsightOptions.FromJSON(const aJSON: TJSONStringType);
+Var
+  D : TJSONData;
+
+begin
+  D:=GetJSON(aJSON);
+  try
+    if D is TJSONObject then
+      FromJSON(D as TJSONObject);
+  finally
+    D.Free;
+  end;
+end;
+
+procedure TTestInsightOptions.FromJSON(const aJSON: TJSONObject);
+
+begin
+  with aJSON do
+    begin
+    ExecuteTests:=Get(KeyExecuteTests,ExecuteTests);
+    ShowProgress:=Get(KeyShowProgress,ShowProgress);
+    TestSuite:=Get(KeySuite,TestSuite);
+    end;
+end;
+
+function TTestInsightOptions.ToJSON: string;
+
+Var
+  Obj : TJSONObject;
+
+begin
+  Obj:=TJSONObject.Create;
+  try
+    ToJSON(Obj);
+    Result := Obj.AsJSON;
+  finally
+    Obj.Free;
+  end;
+end;
+
+procedure TTestInsightOptions.ToJSON(aJSON: TJSONObject);
+
+begin
+  with aJSON do
+    begin
+    Add(KeyExecuteTests,ExecuteTests);
+    Add(KeyShowProgress,ShowProgress);
+    Add(KeySuite,TestSuite);
+    end;
+end;
+
+
+{ TTestInsightResult }
+
+constructor TTestInsightResult.Create;
+begin
+  TestResult:=rtUnknown;
+end;
+
+procedure TTestInsightResult.FromJSON(const aJSON: TJSONStringType);
+
+Var
+  D : TJSONData;
+
+begin
+  D:=GetJSON(aJSON);
+  try
+    if D is TJSONObject then
+      FromJSON(D as TJSONObject);
+  finally
+    D.Free;
+  end;
+end;
+
+procedure TTestInsightResult.FromJSON(const aJSON: TJSONObject);
+
+begin
+  With aJSON Do
+    begin
+    TestName:=Get(KeyTestName, TestName);
+    TestUnitName:=Get(KeyTestUnitName, TestUnitName);
+    TestClassName:=Get(KeyTestClassName, TestClassName);
+    TestMethodName:=Get(KeyTestMethodName, TestMethodName);
+
+    TestResult:=StringToResultType(Get(KeyResultType, ResultTypeNames[TestResult]));
+    TestDuration:=Get(KeyTestDuration, TestDuration);
+    TestStatus:=Get(Keystatus, TestStatus);
+    TestIsIgnored:=Get(keyIsIgnored,TestIsIgnored);
+    TestPhase:=StringToTestPhase(Get(KeyTestPhase,TestPhaseToString(TestPhase)));
+
+    TestExceptionMessage:=Get(KeyExceptionMessage, TestExceptionMessage);
+    TestExceptionClass:=Get(KeyExceptionClass, TestExceptionClass);
+
+    FailureUnitName:=Get(KeyFailureUnitName, FailureUnitName);
+    FailureMethodName:=Get(KeyFailureMethodName, FailureMethodName);
+    FailureLineNumber:=Get(KeyFailureLineNumber, FailureLineNumber);
+    FailureSourceUnitName:=Get(KeyFailureSourceUnitName,FailureSourceUnitName);
+    FailureLocationInfo:=Get(KeyFailureLocationInfo,FailureLocationInfo);
+    end;
+end;
+
+function TTestInsightResult.ToJSON: string;
+
+Var
+  Obj : TJSONObject;
+
+begin
+  Obj:=TJSONObject.Create;
+  try
+    ToJSON(Obj);
+    Result := Obj.AsJSON;
+  finally
+    Free;
+  end;
+end;
+
+procedure TTestInsightResult.ToJSON(aJSON: TJSONObject);
+begin
+  With aJSON do
+    begin
+    Add(KeyTestname, TestName);
+    Add(KeyTestUnitName, TestUnitName);
+    Add(KeyTestClassName, TestClassName);
+    Add(KeyTestMethodName,TestMethodName);
+
+    Add(KeyResultType, ResultTypeNames[TestResult]);
+    Add(KeyTestDuration, TestDuration);
+    Add(KeyStatus, TestStatus);
+    Add(keyIsIgnored,TestIsIgnored);
+    Add(KeyTestPhase,TestPhaseToString(TestPhase));
+
+    Add(KeyExceptionMessage, TestExceptionMessage);
+    Add(KeyExceptionClass, TestExceptionClass);
+
+    Add(KeyFailureUnitName, FailureUnitName);
+    Add(KeyFailureMethodName, FailureMethodName);
+    Add(KeyFailureLinenumber, FailureLineNumber);
+    Add(KeyFailureSourceUnitName,FailureSourceUnitName);
+    Add(KeyFailureLocationInfo,FailureLocationInfo);
+    end;
+end;
+
+
+end.
+

packages/knownaliases.lst

@@ -117,3 +117,6 @@ typinfo=*System.TypInfo
 libjitsimeet=*Api.JitsiMeet
 libkurento=*Api.Kurento
 libflatpickr=*Api.FlatPickr
+fpcunittestinsight=*TestInsight.FpcUnit
+testinsightclient=*TestInsight.Client
+testinsightprotocol=*TestInsight.Protocol

packages/namespaces.lst

@@ -117,3 +117,6 @@ rtl/src/typinfo.pas=rtl/namespaced/System.TypInfo.pas
 jitsimeet/src/libjitsimeet.pp=jitsimeet/namespaced/Api.JitsiMeet.pas
 kurento/src/libkurento.pp=kurento/namespaced/Api.Kurento.pas
 flatpickr/src/libflatpickr.pas=flatpickr/namespaced/Api.FlatPickr.pas
+fpcunit/src/fpcunittestinsight.pp=fpcunit/namespaced/TestInsight.FpcUnit.pp
+fpcunit/src/testinsightclient.pp=fpcunit/namespaced/TestInsight.Client.pp
+fpcunit/src/testinsightprotocol.pp=fpcunit/namesaced/TestInsight.Protocol.pp