paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-23 07:59:44 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Allow to compile with prehistoric FPC 3.2.0

Browse Source
This commit is contained in:
Michaël Van Canneyt 2023-12-26 19:35:36 +01:00
parent 29634d9193
commit 1ef62a70d7
1 changed files with 19 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
components/fpcunit/ide/testinsightserver.pas
View File

@ -7,6 +7,11 @@ interface
uses
Classes, SysUtils, types, httpdefs, syncobjs, fphttpserver, fpJSON, testinsightprotocol;
{$IF DECLARED(TCORSSUPPORT)}
{$DEFINE USECORS}
{$ENDIF}
Type
TTestItem = Class;
@ -80,14 +85,18 @@ Type
FThread: TThread;
FServerPort : Word;
FServerActive : Boolean;
{$IFDEF USECORS}
FCorsSupport : TCORSSupport;
{$ENDIF}
procedure CreateServer;
function ExtractResults(anArray: TJSONArray): TTestInsightResultArray;
procedure FreeResults(Results: TTestInsightResultArray);
function GetPort: Word;
procedure HandleStartThreadTerminate(Sender: TObject);
procedure SetBasePath(AValue: String);
{$IFDEF USECORS}
procedure SetCorsSupport(AValue: TCORSSupport);
{$ENDIF}
procedure SetPort(AValue: Word);
Protected
Procedure DoLog(const aType : TInsightMessageType; const aMessage : String);
@ -130,7 +139,9 @@ Type
// First part of URL. By default: /tests
Property BasePath : String Read FBasePath Write SetBasePath;
// CORS Support ?
{$IFDEF USECORS}
Property CorsSupport : TCORSSupport Read FCorsSupport Write SetCorsSupport;
{$ENDIF}
// 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.
@ -556,8 +567,10 @@ begin
Send404(aResponse)
else
begin
{$IFDEF USECORS}
if FCorsSupport.HandleRequest(aRequest,aResponse,[hcDetect, hcsend]) then
exit;
{$ENDIF}
Delete(aPath,1,Length(BasePath));
if (aPath='') then // '/tests'
begin
@ -646,11 +659,13 @@ begin
FBasePath:=AValue;
end;
{$IFDEF USECORS}
procedure TTestInsightServer.SetCorsSupport(AValue: TCORSSupport);
begin
if FCorsSupport=AValue then Exit;
FCorsSupport.Assign(AValue);
end;
{$ENDIF}
procedure TTestInsightServer.SetPort(AValue: Word);
begin
@ -715,8 +730,10 @@ begin
BasePath:=pathTests;
FTestInsightResultClass:=TTestInsightResult;
FInsightOptions:=CreateTestInsightOptions;
{$IFDEF USECORS}
FCorsSupport:=TCORSSupport.Create;
FCorsSupport.Enabled:=True;
{$ENDIF}
end;
@ -725,7 +742,9 @@ begin
StopServer;
FreeAndNil(FServer);
FreeAndNil(FInsightOptions);
{$IFDEF USECORS}
FreeAndNil(FCorsSupport);
{$ENDIF}
inherited destroy;
end;