mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-06 13:39:17 +02:00
Thread safe results, CORS support (for pas2js)
This commit is contained in:
Michaël Van Canneyt
parent
f1eaecc649
commit
6802746529
@ -174,8 +174,8 @@ type
|
||||
function CreateServer(aOwner : TComponent) : TTestInsightServer; virtual;
|
||||
procedure NavigateTo(const {%H-}aClass, {%H-}aMethod,{%H-}aUnit,{%H-}aLocationFile : String; {%H-}aLocationLine : Integer); virtual;
|
||||
procedure DoneServer(aServer :TTestInsightServer); virtual;
|
||||
procedure ShowMessage(Const Msg : String); virtual;
|
||||
procedure HandleServerLog(Sender: TObject; const aMessage: String); virtual;
|
||||
procedure ShowMessage(aType : TInsightMessageType; Const Msg : String); virtual;
|
||||
procedure HandleServerLog(Sender: TObject; const aType : TInsightMessageType; const aMessage: String); virtual;
|
||||
Property Server : TTestInsightServer Read FServer;
|
||||
public
|
||||
end;
|
||||
@ -393,7 +393,7 @@ end;
|
||||
|
||||
procedure TTestInsightForm.NavigateTo(const aClass,aMethod, aUnit, aLocationFile: String; aLocationLine: Integer);
|
||||
begin
|
||||
ShowMessage(SNavigationNotAvailable);
|
||||
ShowMessage(imtInfo,SNavigationNotAvailable);
|
||||
end;
|
||||
|
||||
procedure TTestInsightForm.DoneServer(aServer: TTestInsightServer);
|
||||
@ -401,7 +401,7 @@ begin
|
||||
aServer.Free;
|
||||
end;
|
||||
|
||||
procedure TTestInsightForm.ShowMessage(const Msg: String);
|
||||
procedure TTestInsightForm.ShowMessage(aType: TInsightMessageType; const Msg: String);
|
||||
begin
|
||||
Dialogs.ShowMessage(Msg);
|
||||
end;
|
||||
@ -630,7 +630,7 @@ begin
|
||||
begin
|
||||
If not ExtractMethod(Itm.TestPath,aClass,aMethod) then
|
||||
begin
|
||||
ShowMessage(Format(rsCouldNotDete, [Itm.TestPath]));
|
||||
ShowMessage(imtInfo,Format(rsCouldNotDete, [Itm.TestPath]));
|
||||
exit;
|
||||
end;
|
||||
aUnit:='';
|
||||
@ -748,6 +748,7 @@ begin
|
||||
begin
|
||||
Res:=aResult[i];
|
||||
aName:=Res.TestName;
|
||||
Writeln('Analyizing test result',Res.TestClassName,' : ',Res.TestName);
|
||||
N:=FindNode(aName);
|
||||
if N=Nil then
|
||||
Res.Free
|
||||
@ -760,6 +761,8 @@ begin
|
||||
rtError : AddError(N,Itm);
|
||||
rtWarning : AddFailure(N,Itm);
|
||||
rtPassed : EndTest(N,Itm);
|
||||
else
|
||||
Writeln('Unknown test result',Res.TestClassName,' : ',Res.TestName);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
@ -795,9 +798,9 @@ begin
|
||||
pbBar.Refresh;
|
||||
end;
|
||||
|
||||
procedure TTestInsightForm.HandleServerLog(Sender: TObject; const aMessage: String);
|
||||
procedure TTestInsightForm.HandleServerLog(Sender: TObject; const aType: TInsightMessageType; const aMessage: String);
|
||||
begin
|
||||
ShowMessage(aMessage);
|
||||
ShowMessage(atype,aMessage);
|
||||
end;
|
||||
|
||||
|
||||
@ -1276,12 +1279,12 @@ procedure TTestInsightForm.RunTestProject(aExecutable: String; SendNamesOnly: Bo
|
||||
begin
|
||||
if TestRunning then
|
||||
begin
|
||||
ShowMessage(Format('The test project %s is still running',[aExecutable]));
|
||||
ShowMessage(imtInfo,Format('The test project %s is still running',[aExecutable]));
|
||||
Exit;
|
||||
end;
|
||||
if not FileExists(aExecutable) then
|
||||
begin
|
||||
ShowMessage(Format(SNoExecutableAvailable,[aExecutable]));
|
||||
ShowMessage(imtError,Format(SNoExecutableAvailable,[aExecutable]));
|
||||
Exit;
|
||||
end;
|
||||
CreateTestRunConfigFile(FConfStoreFile,SendNamesOnly);
|
||||
@ -1290,7 +1293,7 @@ begin
|
||||
PTest.Execute;
|
||||
except
|
||||
On E : Exception do
|
||||
ShowMessage(Format('Error %s while running test project %s: %s',[E.ClassName,aExecutable,E.Message]));
|
||||
ShowMessage(imtError,Format('Error %s while running test project %s: %s',[E.ClassName,aExecutable,E.Message]));
|
||||
end;
|
||||
FSelectedTestSuite:=Nil;
|
||||
end;
|
||||
|
||||
@ -21,7 +21,7 @@ Type
|
||||
TLazTestInsightForm = class(TTestInsightForm)
|
||||
private
|
||||
Public
|
||||
procedure ShowMessage(Const Msg : String); override;
|
||||
procedure ShowMessage(aType: TInsightMessageType; Const Msg : String); override;
|
||||
Function GetTestProject : String; override;
|
||||
procedure RunTestProject(aExecutable : string; SendNamesOnly : Boolean); override;
|
||||
procedure NavigateTo(const aClass, aMethod, aUnit, aLocationFile: String; aLocationLine: Integer); override;
|
||||
@ -265,11 +265,15 @@ end;
|
||||
|
||||
{ TLazTestInsightForm }
|
||||
|
||||
procedure TLazTestInsightForm.ShowMessage(const Msg: String);
|
||||
procedure TLazTestInsightForm.ShowMessage(aType: TInsightMessageType; const Msg: String);
|
||||
|
||||
Const
|
||||
MLU : Array[TInsightMessageType] of TMessageLineUrgency = (TMessageLineUrgency.mluImportant,TMessageLineUrgency.mluError);
|
||||
|
||||
begin
|
||||
Writeln('Message : ',Msg);
|
||||
if Assigned(IDEMessagesWindow) then
|
||||
IDEMessagesWindow.AddCustomMessage(TMessageLineUrgency.mluError,Msg,'',0,0,rsTestInsightTitle)
|
||||
|
||||
IDEMessagesWindow.AddCustomMessage(MLU[aType],Msg,'',0,0,rsTestInsightTitle)
|
||||
end;
|
||||
|
||||
function TLazTestInsightForm.GetTestProject: String;
|
||||
@ -313,7 +317,7 @@ begin
|
||||
if not NavOK then
|
||||
NavOK:=ShowMethod(aClass,aMethod,aUnit);
|
||||
if not NavOK then
|
||||
ShowMessage(Format('Failed to navigate to test %s.%s in unit %s',[aClass,aMethod,aUnit]));
|
||||
ShowMessage(imtError,Format('Failed to navigate to test %s.%s in unit %s',[aClass,aMethod,aUnit]));
|
||||
end;
|
||||
|
||||
function TLazTestInsightForm.ShowRefreshTestproject: Boolean;
|
||||
|
||||
@ -5,7 +5,7 @@ unit TestInsightServer;
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, types, fphttpserver, fpJSON, testinsightprotocol;
|
||||
Classes, SysUtils, types, httpdefs, syncobjs, fphttpserver, fpJSON, testinsightprotocol;
|
||||
|
||||
Type
|
||||
TTestItem = Class;
|
||||
@ -57,7 +57,8 @@ Type
|
||||
TTestResultEvent = Procedure(Sender : TObject; aResult : TTestInsightResultArray) of object;
|
||||
TTestsStartedEvent = Procedure(Sender : TObject; aCount : Integer) of object;
|
||||
TTestsOptionsEvent = Procedure(Sender : TObject; aOptions : TTestInsightOptions) of object;
|
||||
TTestInsightLogEvent = Procedure(Sender : TObject; const aMessage : String) of object;
|
||||
TInsightMessageType = (imtInfo,imtError);
|
||||
TTestInsightLogEvent = Procedure(Sender : TObject; const aType : TInsightMessageType; const aMessage : String) of object;
|
||||
|
||||
TTestInsightServer = class(TComponent)
|
||||
private
|
||||
@ -70,7 +71,6 @@ Type
|
||||
FOnSelectedTests: TSelectedTestsEvent;
|
||||
FOnSetTestNames: TTestNamesEvent;
|
||||
FOnTestResult: TtestResultEvent;
|
||||
FResultArray : TTestInsightResultArray;
|
||||
FSelectedTests : String;
|
||||
FTestInsightResultClass: TTestInsightResultClass;
|
||||
FTestSuite : TTestItem;
|
||||
@ -80,21 +80,22 @@ Type
|
||||
FThread: TThread;
|
||||
FServerPort : Word;
|
||||
FServerActive : Boolean;
|
||||
FCorsSupport : TCORSSupport;
|
||||
procedure CreateServer;
|
||||
procedure ExtractResults(anArray: TJSONArray);
|
||||
procedure FreeResults;
|
||||
function ExtractResults(anArray: TJSONArray): TTestInsightResultArray;
|
||||
procedure FreeResults(Results: TTestInsightResultArray);
|
||||
function GetPort: Word;
|
||||
procedure HandleStartThreadTerminate(Sender: TObject);
|
||||
procedure SetBasePath(AValue: String);
|
||||
procedure SetCorsSupport(AValue: TCORSSupport);
|
||||
procedure SetPort(AValue: Word);
|
||||
Protected
|
||||
Procedure DoLog(Const aMessage : String);
|
||||
Procedure DoLog(Const Fmt : String; Args : Array of const);
|
||||
Procedure DoLog(const aType : TInsightMessageType; const aMessage : String);
|
||||
Procedure DoLog(const aType : TInsightMessageType; const Fmt : String; Args : Array of const);
|
||||
// Override if you want to create a descendent.
|
||||
function CreateTestInsightOptions: TTestInsightOptions; virtual;
|
||||
// these are called in the main thread
|
||||
procedure DoGetSelectedTests; virtual;
|
||||
procedure DoResultEvent; virtual;
|
||||
procedure DoSetTestNames; virtual;
|
||||
procedure DoTestsStarted; virtual;
|
||||
procedure DoTestsFinished; virtual;
|
||||
@ -128,6 +129,8 @@ Type
|
||||
property Port: Word Read GetPort Write SetPort;
|
||||
// First part of URL. By default: /tests
|
||||
Property BasePath : String Read FBasePath Write SetBasePath;
|
||||
// CORS Support ?
|
||||
Property CorsSupport : TCORSSupport Read FCorsSupport Write SetCorsSupport;
|
||||
// Set the list of tests. Event handler must free JSON object.
|
||||
Property OnSetTestNames : TTestNamesEvent Read FOnSetTestNames Write FOnSetTestNames;
|
||||
// Get the list of selected tests. The server will free the received object.
|
||||
@ -271,12 +274,32 @@ end;
|
||||
|
||||
{ TTestInsightServer }
|
||||
|
||||
procedure TTestInsightServer.DoResultEvent;
|
||||
Type
|
||||
|
||||
{ TTransferTestResult }
|
||||
|
||||
TTransferTestResult = Class
|
||||
Private
|
||||
FEvent: TTestResultEvent;
|
||||
FSender : TObject;
|
||||
FResult : TTestInsightResultArray;
|
||||
Public
|
||||
constructor create (aEvent: TTestResultEvent; aSender : TObject; aResult : TTestInsightResultArray);
|
||||
procedure DoResultEvent;
|
||||
end;
|
||||
|
||||
constructor TTransferTestResult.create(aEvent: TTestResultEvent; aSender: TObject; aResult: TTestInsightResultArray);
|
||||
begin
|
||||
FEvent:=aEvent;
|
||||
FSender:=aSender;
|
||||
FResult:=aResult;
|
||||
end;
|
||||
|
||||
procedure TTransferTestResult.DoResultEvent;
|
||||
|
||||
begin
|
||||
if Assigned(OnTestResult) then
|
||||
OnTestResult(Self,FResultArray);
|
||||
FResultArray:=Nil;
|
||||
if Assigned(FEvent) then
|
||||
FEvent(FSender,FResult);
|
||||
end;
|
||||
|
||||
procedure TTestInsightServer.DoSetTestNames;
|
||||
@ -352,15 +375,16 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestInsightServer.ExtractResults(anArray : TJSONArray);
|
||||
Function TTestInsightServer.ExtractResults(anArray : TJSONArray) : TTestInsightResultArray;
|
||||
|
||||
Var
|
||||
i,aLen : Integer;
|
||||
Res: TTestInsightResult;
|
||||
|
||||
|
||||
begin
|
||||
aLen:=0;
|
||||
SetLength(FResultArray,anArray.Count);
|
||||
SetLength(Result,anArray.Count);
|
||||
For I:=0 to anArray.Count-1 do
|
||||
begin
|
||||
if anArray.Types[i]=jtObject then
|
||||
@ -369,11 +393,15 @@ begin
|
||||
try
|
||||
Res.FromJSOn(anArray.Objects[i]);
|
||||
except
|
||||
FreeAndNil(res);
|
||||
on E : Exception do
|
||||
begin
|
||||
FreeAndNil(res);
|
||||
DoLog(imtError,'Error %s extracting test result: %s',[E.ClassName, E.Message]);
|
||||
end;
|
||||
end;
|
||||
if Assigned(Res) then
|
||||
begin
|
||||
FResultArray[aLen]:=Res;
|
||||
Result[aLen]:=Res;
|
||||
Inc(aLen);
|
||||
end;
|
||||
end;
|
||||
@ -384,9 +412,11 @@ procedure TTestInsightServer.DoTestResults(ARequest: TFPHTTPConnectionRequest; a
|
||||
|
||||
Var
|
||||
D : TJSONData;
|
||||
Results : TTestInsightResultArray;
|
||||
Trans : TTransferTestResult;
|
||||
|
||||
begin
|
||||
FreeResults;
|
||||
Results:=Nil;
|
||||
try
|
||||
D:=GetJSON(aRequest.Content);
|
||||
except
|
||||
@ -400,36 +430,38 @@ begin
|
||||
if D is TJSONArray then
|
||||
begin
|
||||
Send200(aResponse);
|
||||
ExtractResults(D as TJSONArray);
|
||||
Results:=ExtractResults(D as TJSONArray);
|
||||
end
|
||||
else if (D is TJSONObject) and (D.Count=1) and (D.Items[0] is TJSONArray) then
|
||||
begin
|
||||
Send200(aResponse);
|
||||
ExtractResults(TJSONObject(D).Extract(0) as TJSONArray);
|
||||
Results:=ExtractResults(TJSONObject(D).Extract(0) as TJSONArray);
|
||||
end
|
||||
else
|
||||
Send400(aResponse,'Bad JSON message');
|
||||
finally
|
||||
D.Free;
|
||||
end;
|
||||
if Assigned(FResultArray) then
|
||||
begin
|
||||
if Assigned(OnTestResult) then
|
||||
TThread.Synchronize(TThread.CurrentThread,@DoResultEvent)
|
||||
else
|
||||
FreeResults;
|
||||
end;
|
||||
if not (Assigned(Results) and Assigned(OnTestResult)) then
|
||||
Exit;
|
||||
Trans:=TTransferTestResult.create(OnTestResult,Self,Results);
|
||||
try
|
||||
TThread.Synchronize(TThread.CurrentThread,@Trans.DoResultEvent);
|
||||
FreeResults(Results);
|
||||
finally
|
||||
Trans.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestInsightServer.FreeResults;
|
||||
procedure TTestInsightServer.FreeResults(Results : TTestInsightResultArray);
|
||||
|
||||
Var
|
||||
Res : TTestInsightResult;
|
||||
|
||||
begin
|
||||
For Res in FResultArray do
|
||||
Res.Free;
|
||||
SetLength(FResultArray,0);
|
||||
For Res in Results do
|
||||
Res.Free;
|
||||
SetLength(Results,0);
|
||||
end;
|
||||
|
||||
|
||||
@ -519,10 +551,13 @@ Var
|
||||
|
||||
begin
|
||||
aPath:=aRequest.PathInfo;
|
||||
DoLog(imtInfo,'Handling request %s %s',[aRequest.Method,aPath]);
|
||||
if not SameText(Copy(aPath,1,Length(BasePath)),BasePath) then
|
||||
Send404(aResponse)
|
||||
else
|
||||
begin
|
||||
if FCorsSupport.HandleRequest(aRequest,aResponse,[hcDetect, hcsend]) then
|
||||
exit;
|
||||
Delete(aPath,1,Length(BasePath));
|
||||
if (aPath='') then // '/tests'
|
||||
begin
|
||||
@ -542,7 +577,7 @@ begin
|
||||
if SameText(aPath,pathStarted) then
|
||||
begin
|
||||
if CheckMethod('POST') then
|
||||
DoStartTests(aResponse,StrToIntDef(aRequest.QueryFields.Values[qryTotalCount],-1));
|
||||
DoStartTests(aResponse,StrToIntDef(aRequest.QueryFields.Values[qryTotalCount],-1));
|
||||
end
|
||||
else if SameText(aPath,pathFinished) then
|
||||
begin
|
||||
@ -585,7 +620,7 @@ begin
|
||||
ErrClass:=SThread.StartErrorClass;
|
||||
ErrMsg:=SThread.StartErrorMessage;
|
||||
if ErrClass<>'' then
|
||||
DoLog('Error %s starting server: %s',[ErrClass,ErrMsg]);
|
||||
DoLog(imtError,'Error %s starting server: %s',[ErrClass,ErrMsg]);
|
||||
FThread:=Nil;
|
||||
FServerActive:=False;
|
||||
|
||||
@ -611,21 +646,28 @@ begin
|
||||
FBasePath:=AValue;
|
||||
end;
|
||||
|
||||
procedure TTestInsightServer.SetCorsSupport(AValue: TCORSSupport);
|
||||
begin
|
||||
if FCorsSupport=AValue then Exit;
|
||||
FCorsSupport.Assign(AValue);
|
||||
end;
|
||||
|
||||
procedure TTestInsightServer.SetPort(AValue: Word);
|
||||
begin
|
||||
FServer.Port:=aValue;
|
||||
FServerPort:=aValue;
|
||||
end;
|
||||
|
||||
procedure TTestInsightServer.DoLog(const aMessage: String);
|
||||
|
||||
procedure TTestInsightServer.DoLog(const aType : TInsightMessageType;const aMessage: String);
|
||||
begin
|
||||
If Assigned(FOnLog) then
|
||||
FOnLog(Self,aMessage);
|
||||
FOnLog(Self,aType,aMessage);
|
||||
end;
|
||||
|
||||
procedure TTestInsightServer.DoLog(const Fmt: String; Args: array of const);
|
||||
procedure TTestInsightServer.DoLog(const aType : TInsightMessageType;const Fmt: String; Args: array of const);
|
||||
begin
|
||||
DoLog(Format(Fmt,Args));
|
||||
DoLog(aType,Format(Fmt,Args));
|
||||
end;
|
||||
|
||||
procedure TTestInsightServer.Send400(aResponse: TFPHTTPConnectionResponse; aText : String);
|
||||
@ -673,6 +715,8 @@ begin
|
||||
BasePath:=pathTests;
|
||||
FTestInsightResultClass:=TTestInsightResult;
|
||||
FInsightOptions:=CreateTestInsightOptions;
|
||||
FCorsSupport:=TCORSSupport.Create;
|
||||
FCorsSupport.Enabled:=True;
|
||||
end;
|
||||
|
||||
|
||||
@ -681,10 +725,11 @@ begin
|
||||
StopServer;
|
||||
FreeAndNil(FServer);
|
||||
FreeAndNil(FInsightOptions);
|
||||
FreeAndNil(FCorsSupport);
|
||||
inherited destroy;
|
||||
end;
|
||||
|
||||
Procedure TTestInsightServer.CreateServer;
|
||||
procedure TTestInsightServer.CreateServer;
|
||||
|
||||
begin
|
||||
FServer:=TFPHttpServer.Create(Self);
|
||||
@ -706,6 +751,7 @@ begin
|
||||
FServer.OnRequest:=@DoRequest;
|
||||
FServerActive:=True;
|
||||
FThread:=TStartServerThread.Create(FServer,@HandleStartThreadTerminate);
|
||||
DoLog(imtInfo,'Starting test insight server on port %d',[Port]);
|
||||
end;
|
||||
|
||||
procedure TTestInsightServer.StopServer;
|
||||
@ -717,19 +763,19 @@ begin
|
||||
exit;
|
||||
FServer.OnRequest:=Nil;
|
||||
FServerActive:=False;
|
||||
DoLog('Deactivating server');
|
||||
DoLog(imtInfo,'Deactivating server');
|
||||
FServer.Active:=False;
|
||||
DoLog('Fake request');
|
||||
DoLog(imtInfo,'Fake request');
|
||||
Try
|
||||
TInetSocket.Create('localhost',FServer.Port,10,Nil).Free;
|
||||
except
|
||||
on E : Exception do
|
||||
DoLog('Fake request resulted in %s: %s',[E.ClassName,E.Message]);
|
||||
DoLog(imtError,'Fake request resulted in %s: %s',[E.ClassName,E.Message]);
|
||||
end;
|
||||
DoLog('Waiting for server thread to stop');
|
||||
DoLog(imtInfo,'Waiting for server thread to stop');
|
||||
If Assigned(FThread) then
|
||||
FThread.WaitFor;
|
||||
DoLog('Server thread stopped');
|
||||
DoLog(imtInfo,'Server thread stopped');
|
||||
end;
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user