THRIFT-2195 Delphi: Add event handlers for server and processing events
Patch: Jens Geyer
diff --git a/lib/delphi/src/Thrift.Transport.Pipes.pas b/lib/delphi/src/Thrift.Transport.Pipes.pas
index bf07e1e..c2696f4 100644
--- a/lib/delphi/src/Thrift.Transport.Pipes.pas
+++ b/lib/delphi/src/Thrift.Transport.Pipes.pas
@@ -172,7 +172,7 @@
FClientAnonWrite : THandle;
protected
- function AcceptImpl: ITransport; override;
+ function Accept(const fnAccepting: TProc): ITransport; override;
function CreateAnonPipe : Boolean;
@@ -197,9 +197,10 @@
FTimeout : DWORD;
FHandle : THandle;
FConnected : Boolean;
-
-
protected
- function AcceptImpl: ITransport; override;
+
+
+ protected
+ function Accept(const fnAccepting: TProc): ITransport; override;
function CreateNamedPipe : THandle;
function CreateTransportInstance : ITransport;
@@ -558,10 +559,13 @@
end;
-function TAnonymousPipeServerTransportImpl.AcceptImpl: ITransport;
+function TAnonymousPipeServerTransportImpl.Accept(const fnAccepting: TProc): ITransport;
var buf : Byte;
br : DWORD;
begin
+ if Assigned(fnAccepting)
+ then fnAccepting();
+
// This 0-byte read serves merely as a blocking call.
if not ReadFile( FReadHandle, buf, 0, br, nil)
and (GetLastError() <> ERROR_MORE_DATA)
@@ -668,55 +672,62 @@
end;
-function TNamedPipeServerTransportImpl.AcceptImpl: ITransport;
+function TNamedPipeServerTransportImpl.Accept(const fnAccepting: TProc): ITransport;
var dwError, dwWait, dwDummy : DWORD;
overlapped : TOverlapped;
- event : TEvent;
-begin
+ event : TEvent;
+begin
FillChar( overlapped, SizeOf(overlapped), 0);
event := TEvent.Create( nil, TRUE, FALSE, ''); // always ManualReset, see MSDN
try
- overlapped.hEvent := event.Handle;
-
- ASSERT( not FConnected);
- while not FConnected do begin
+ overlapped.hEvent := event.Handle;
+
+ ASSERT( not FConnected);
+ while not FConnected do begin
InternalClose;
if FStopServer then Abort;
CreateNamedPipe;
+ if Assigned(fnAccepting)
+ then fnAccepting();
+
// Wait for the client to connect; if it succeeds, the
// function returns a nonzero value. If the function returns
// zero, GetLastError should return ERROR_PIPE_CONNECTED.
- if ConnectNamedPipe( Handle, @overlapped)
- then FConnected := TRUE
- else begin
- // ConnectNamedPipe() returns FALSE for OverlappedIO, even if connected.
- // We have to check GetLastError() explicitly to find out
- dwError := GetLastError;
- case dwError of
- ERROR_PIPE_CONNECTED : begin
- FConnected := TRUE; // special case: pipe immediately connected
- end;
-
- ERROR_IO_PENDING : begin
- dwWait := WaitForSingleObject( overlapped.hEvent, DEFAULT_THRIFT_PIPE_TIMEOUT);
- FConnected := (dwWait = WAIT_OBJECT_0)
- and GetOverlappedResult( Handle, overlapped, dwDummy, TRUE);
- end;
-
- else
- InternalClose;
- raise TTransportException.Create( TTransportException.TExceptionType.NotOpen,
- 'Client connection failed');
- end;
- end;
- end;
+ if ConnectNamedPipe( Handle, @overlapped) then begin
+ FConnected := TRUE;
+ Break;
+ end;
+
+ // ConnectNamedPipe() returns FALSE for OverlappedIO, even if connected.
+ // We have to check GetLastError() explicitly to find out
+ dwError := GetLastError;
+ case dwError of
+ ERROR_PIPE_CONNECTED : begin
+ FConnected := not FStopServer; // special case: pipe immediately connected
+ end;
+
+ ERROR_IO_PENDING : begin
+ repeat
+ dwWait := WaitForSingleObject( overlapped.hEvent, DEFAULT_THRIFT_PIPE_TIMEOUT);
+ until (dwWait <> WAIT_TIMEOUT) or FStopServer;
+ FConnected := (dwWait = WAIT_OBJECT_0)
+ and GetOverlappedResult( Handle, overlapped, dwDummy, TRUE)
+ and not FStopServer;
+ end;
+
+ else
+ InternalClose;
+ raise TTransportException.Create( TTransportException.TExceptionType.NotOpen,
+ 'Client connection failed');
+ end;
+ end;
// create the transport impl
result := CreateTransportInstance;
finally
- event.Free;
+ event.Free;
end;
end;
@@ -730,9 +741,9 @@
FConnected := FALSE;
result := TNamedPipeTransportServerEndImpl.Create( hPipe, TRUE);
except
- ClosePipeHandle(hPipe);
- raise;
- end;
+ ClosePipeHandle(hPipe);
+ raise;
+ end;
end;