@@ -33,18 +33,24 @@ interface
33
33
Delphi.WebMock.Dynamic.RequestStub, Delphi.WebMock.Response,
34
34
Delphi.WebMock.ResponseBodySource, Delphi.WebMock.ResponseStatus,
35
35
IdContext, IdCustomHTTPServer, IdGlobal, IdHTTPServer,
36
- System.Classes, System.Generics.Collections, System.RegularExpressions;
36
+ System.Classes, System.Generics.Collections, System.RegularExpressions,
37
+ System.SysUtils;
37
38
38
39
type
40
+ EWebMockError = class (Exception);
41
+ EWebMockExceededBindAttempts = class (EWebMockError);
42
+
39
43
TWebWockPort = TIdPort;
40
44
41
45
TWebMock = class (TObject)
46
+ class var NextPort: Integer;
42
47
private
43
48
FServer: TIdHTTPServer;
44
49
FBaseURL: string;
45
50
FStubRegistry: TList<IWebMockRequestStub>;
46
51
FHistory: TList<IWebMockHTTPRequest>;
47
52
procedure InitializeServer (const APort: TWebWockPort);
53
+ procedure StartServer (const APort: TWebWockPort);
48
54
procedure OnServerRequest (AContext: TIdContext;
49
55
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
50
56
function GetRequestStub (ARequestInfo: IWebMockHTTPRequest) : IWebMockRequestStub;
@@ -56,9 +62,11 @@ TWebMock = class(TObject)
56
62
const AResponseHeaders: TStrings);
57
63
procedure SetResponseStatus (AResponseInfo: TIdHTTPResponseInfo;
58
64
const AResponseStatus: TWebMockResponseStatus);
65
+ function GetNextPort : Integer;
66
+ function GetPort : Integer;
59
67
property Server: TIdHTTPServer read FServer write FServer;
60
68
public
61
- constructor Create(const APort: TWebWockPort = 8080 );
69
+ constructor Create(const APort: TWebWockPort = 0 );
62
70
destructor Destroy; override;
63
71
function Assert : TWebMockAssertion;
64
72
procedure PrintStubRegistry ;
@@ -75,16 +83,18 @@ TWebMock = class(TObject)
75
83
property BaseURL: string read FBaseURL;
76
84
property History: TList<IWebMockHTTPRequest> read FHistory;
77
85
property StubRegistry: TList<IWebMockRequestStub> read FStubRegistry;
86
+ property Port: Integer read GetPort;
78
87
end ;
79
88
80
89
implementation
81
90
82
91
uses
83
92
Delphi.WebMock.HTTP.Request,
84
93
Delphi.WebMock.HTTP.RequestMatcher,
94
+ IdException,
85
95
IdHTTP,
86
96
IdSocketHandle,
87
- System.SysUtils ;
97
+ IdStack ;
88
98
89
99
{ TWebMock }
90
100
@@ -93,7 +103,7 @@ function TWebMock.Assert: TWebMockAssertion;
93
103
Result := TWebMockAssertion.Create(History);
94
104
end ;
95
105
96
- constructor TWebMock.Create(const APort: TWebWockPort = 8080 );
106
+ constructor TWebMock.Create(const APort: TWebWockPort = 0 );
97
107
begin
98
108
inherited Create;
99
109
FStubRegistry := TList<IWebMockRequestStub>.Create;
@@ -109,6 +119,22 @@ destructor TWebMock.Destroy;
109
119
inherited ;
110
120
end ;
111
121
122
+ function TWebMock.GetNextPort : Integer;
123
+ var
124
+ FIsInitial: Boolean;
125
+ begin
126
+ AtomicCmpExchange(NextPort, 8080 , 0 , FIsInitial);
127
+ if FIsInitial then
128
+ Exit(NextPort);
129
+
130
+ Result := AtomicIncrement(NextPort);
131
+ end ;
132
+
133
+ function TWebMock.GetPort : Integer;
134
+ begin
135
+ Result := Server.Bindings.Items[0 ].Port;
136
+ end ;
137
+
112
138
function TWebMock.GetRequestStub (ARequestInfo: IWebMockHTTPRequest) : IWebMockRequestStub;
113
139
var
114
140
LRequestStub: IWebMockRequestStub;
@@ -131,11 +157,9 @@ procedure TWebMock.InitializeServer(const APort: TWebWockPort);
131
157
132
158
FServer := TIdHTTPServer.Create;
133
159
Server.ServerSoftware := ' Delphi WebMocks' ;
134
- Server.DefaultPort := APort;
135
160
Server.OnCommandGet := OnServerRequest;
136
161
Server.OnCommandOther := OnServerRequest;
137
- Server.Active := True;
138
- FBaseURL := Format(' http://127.0.0.1:%d/' , [Server.DefaultPort]);
162
+ StartServer(APort);
139
163
end ;
140
164
141
165
procedure TWebMock.OnServerRequest (AContext: TIdContext;
@@ -209,6 +233,44 @@ procedure TWebMock.SetResponseStatus(AResponseInfo: TIdHTTPResponseInfo;
209
233
AResponseInfo.ResponseText := AResponseStatus.Text;
210
234
end ;
211
235
236
+ procedure TWebMock.StartServer (const APort: TWebWockPort);
237
+ var
238
+ LAttempt, LMaxAttempts: Integer;
239
+ LPort: Integer;
240
+ LSocketHandle: TIdSocketHandle;
241
+ begin
242
+ LAttempt := 0 ;
243
+ LMaxAttempts := 3 ;
244
+ while not Server.Active do
245
+ begin
246
+ Inc(LAttempt);
247
+ if LAttempt >= LMaxAttempts then
248
+ raise EWebMockExceededBindAttempts.Create(' Exceeded attempts to bind port.' );
249
+ if APort > 0 then
250
+ LPort := APort
251
+ else
252
+ LPort := GetNextPort;
253
+ Server.Bindings.Clear;
254
+ LSocketHandle := Server.Bindings.Add;
255
+ LSocketHandle.Port := LPort;
256
+ try
257
+ Server.Active := True;
258
+ FBaseURL := Format(' http://127.0.0.1:%d/' , [LSocketHandle.Port]);
259
+ except
260
+ on E: EIdCouldNotBindSocket do
261
+ begin
262
+ Server.Active := False;
263
+ StartServer(APort);
264
+ end ;
265
+ on E: EIdSocketError do
266
+ begin
267
+ Server.Active := False;
268
+ StartServer(APort);
269
+ end ;
270
+ end ;
271
+ end ;
272
+ end ;
273
+
212
274
function TWebMock.StubRequest (
213
275
const AMatcher: TWebMockDynamicRequestMatcher): TWebMockDynamicRequestStub;
214
276
var
0 commit comments