340 lines
9.5 KiB
ObjectPascal
340 lines
9.5 KiB
ObjectPascal
unit uRONamedPipeChannel;
|
|
|
|
{----------------------------------------------------------------------------}
|
|
{ RemObjects SDK Library - Enterprise Library }
|
|
{ }
|
|
{ compiler: Delphi 5 and up }
|
|
{ platform: Win32 }
|
|
{ }
|
|
{ (c)opyright RemObjects Software. all rights reserved. }
|
|
{ }
|
|
{ Provided by Robert Love (robert.love@teamro.remobjects.com) }
|
|
{ }
|
|
{ Using this code requires a valid license of the RemObjects SDK }
|
|
{ which can be obtained at http://www.remobjects.com. }
|
|
{----------------------------------------------------------------------------}
|
|
|
|
|
|
{$I RemObjects.inc}
|
|
|
|
//TODO: Make sure with testing that client behaves well when server connection broken.
|
|
|
|
interface
|
|
|
|
uses
|
|
{$IFDEF REMOBJECTS_TRIAL}uROTrial,{$ENDIF}
|
|
Classes, Sysutils, uROClient, uROClientIntf, uROClasses, uROTypes, Windows;
|
|
|
|
type
|
|
TRONamedPipeChannel = class(TROTransportChannel,IROTransport)
|
|
private
|
|
fServerName: string;
|
|
fServerID: string;
|
|
FActive: Boolean;
|
|
FActivateOnDemand: Boolean;
|
|
procedure SetServerID(const Value: string);
|
|
procedure SetServerName(const Value: string);
|
|
procedure SetActive(const Value: Boolean);
|
|
procedure SetActivateOnDemand(const Value: Boolean);
|
|
protected
|
|
hPipe : THandle;
|
|
|
|
procedure IntDispatch(aRequest, aResponse : TStream); override;
|
|
function GetPipeName : string; virtual;
|
|
procedure SendAndRecv(aRequest, aResponse : TStream); virtual;
|
|
function DataWaiting: Boolean; virtual;
|
|
|
|
{ IROTransport }
|
|
function GetTransportObject : TObject; override;
|
|
|
|
public
|
|
constructor Create(Owner : TComponent); override;
|
|
destructor Destroy; override;
|
|
procedure Connect; virtual;
|
|
procedure Disconnect; virtual;
|
|
procedure CheckProperties; override;
|
|
published
|
|
property ActivateOnDemand : Boolean read FActivateOnDemand write SetActivateOnDemand default true;
|
|
property Active : Boolean read FActive write SetActive default false;
|
|
property ServerID : string read fServerID write SetServerID;
|
|
property ServerName : string read fServerName write SetServerName;
|
|
published
|
|
property SynchronizedProbing;
|
|
property OnSendStream;
|
|
property OnReceiveStream;
|
|
property ServerLocators;
|
|
property DispatchOptions;
|
|
property OnServerLocatorAssignment;
|
|
property ProbeServers;
|
|
property ProbeFrequency;
|
|
property OnBeforeProbingServers;
|
|
property OnAfterProbingServers;
|
|
property OnBeforeProbingServer;
|
|
property OnAfterProbingServer;
|
|
property OnLoginNeeded;
|
|
end;
|
|
implementation
|
|
{ TRONamedPipeChannel }
|
|
|
|
procedure TRONamedPipeChannel.connect;
|
|
var
|
|
dwmode : DWord;
|
|
begin
|
|
hPipe := CreateFile(
|
|
pchar(GetPipeName), // pipe name
|
|
GENERIC_READ or // read and write access
|
|
GENERIC_WRITE,
|
|
0, // no sharing
|
|
nil, // no security attributes
|
|
OPEN_EXISTING, // opens existing pipe
|
|
0, // default attributes
|
|
0); // no template file
|
|
|
|
FActive := not (hPipe= INVALID_HANDLE_VALUE);
|
|
if (GetLastError = ERROR_PIPE_BUSY) then
|
|
begin
|
|
// All pipe instances are busy, so wait for 20 seconds.
|
|
if (not WaitNamedPipe(pchar(GetPipeName), 20000) ) then
|
|
begin
|
|
FActive := False;
|
|
raise EROChannelBusy.Create('Named Pipe Server is Busy');
|
|
end;
|
|
hPipe := CreateFile(
|
|
pchar(GetPipeName), // pipe name
|
|
GENERIC_READ or // read and write access
|
|
GENERIC_WRITE,
|
|
0, // no sharing
|
|
nil, // no security attributes
|
|
OPEN_EXISTING, // opens existing pipe
|
|
0, // default attributes
|
|
0); // no template file
|
|
FActive := not (hPipe= INVALID_HANDLE_VALUE);
|
|
end;
|
|
if Not FActive then RaiseLastOSError;
|
|
|
|
dwMode := PIPE_READMODE_MESSAGE;
|
|
if not SetNamedPipeHandleState(
|
|
hPipe, // pipe handle
|
|
dwMode, // new pipe mode
|
|
nil, // don't set maximum bytes
|
|
nil) // don't set maximum time
|
|
Then
|
|
begin
|
|
Disconnect;
|
|
raise Exception.Create('Unable to change to Message Read Mode');
|
|
end;
|
|
end;
|
|
|
|
procedure TRONamedPipeChannel.Disconnect;
|
|
begin
|
|
CloseHandle(hPipe);
|
|
FActive := False;
|
|
end;
|
|
|
|
constructor TRONamedPipeChannel.Create(Owner: TComponent);
|
|
begin
|
|
inherited Create(Owner);
|
|
FActivateOnDemand := true;
|
|
FActive := false;
|
|
FServerID := 'RONamedPipeServer';
|
|
fServerName := '.'; // localhost
|
|
end;
|
|
|
|
function TRONamedPipeChannel.GetTransportObject: TObject;
|
|
begin
|
|
result := self;
|
|
end;
|
|
|
|
procedure TRONamedPipeChannel.IntDispatch(aRequest, aResponse: TStream);
|
|
begin
|
|
if (Not FActive) and (Not FActivateOnDemand) then
|
|
raise Exception.Create('Operation can not be performed on a closed connection.');
|
|
if (Not Factive) then
|
|
Connect;
|
|
SendAndRecv(aRequest,aResponse);
|
|
if FActivateOnDemand then
|
|
Disconnect;
|
|
end;
|
|
|
|
function TRONamedPipeChannel.GetPipeName: string;
|
|
begin
|
|
CheckProperties;
|
|
result := '\\' + fServerName + '\pipe\' + fServerID;
|
|
end;
|
|
|
|
procedure TRONamedPipeChannel.SendAndRecv(aRequest, aResponse: TStream);
|
|
var
|
|
fBuf : PChar;
|
|
FSize : Integer;
|
|
fSuccess : BOOL;
|
|
FBytes : DWord;
|
|
BufSize : integer;
|
|
begin
|
|
// ViktorT changed
|
|
BufSize := 4096;
|
|
GetMem(fBuf, BufSize);
|
|
|
|
try
|
|
try
|
|
aRequest.Position := 0;
|
|
FSize := aRequest.Size;
|
|
// Send Request size to recipient (server)
|
|
fSuccess := WriteFile(hPipe, FSize, sizeof(FSize), FBytes, nil);
|
|
|
|
if not FSuccess then
|
|
RaiseLastOSError;
|
|
|
|
while FSize > 0 do
|
|
begin
|
|
FBytes := aRequest.Read(fBuf^, BufSize);
|
|
dec(FSize, FBytes);
|
|
fSuccess := WriteFile(hPipe, fBuf^, FBytes, FBytes, nil);
|
|
|
|
if not FSuccess then
|
|
RaiseLastOSError;
|
|
end;
|
|
|
|
if not FSuccess then
|
|
RaiseLastOSError;
|
|
|
|
fSuccess := ReadFile(hPipe, FSize, sizeof(FSize), FBytes, nil);
|
|
|
|
if not FSuccess then
|
|
RaiseLastOSError;
|
|
|
|
while FSize > 0 do
|
|
begin
|
|
fSuccess := ReadFile(hPipe, fBuf^, BufSize, FBytes, nil);
|
|
|
|
if (not fSuccess) and (GetLastError <> ERROR_MORE_DATA) then
|
|
RaiseLastOSError;
|
|
|
|
if FBytes > 0 then
|
|
aResponse.Write(fBuf^, FBytes);
|
|
|
|
dec(FSize, FBytes);
|
|
end;
|
|
except
|
|
on e: Exception do
|
|
begin
|
|
Factive := False;
|
|
CloseHandle(hPipe);
|
|
end;
|
|
end;
|
|
finally
|
|
FreeMem(fBuf);
|
|
end;
|
|
(*
|
|
FSize := aRequest.Size;
|
|
GetMem(fBuf,FSize);
|
|
try
|
|
FillChar(fBuf^,FSize,0);
|
|
aRequest.Seek(0,soFromBeginning);
|
|
aRequest.ReadBuffer(fBuf[0],FSize);
|
|
// Send Buffer to Server
|
|
fSuccess := WriteFile(
|
|
hPipe, // pipe handle
|
|
fBuf[0], // message
|
|
FSize, // message length
|
|
FBytes, // bytes written
|
|
nil) ; // not overlapped
|
|
if not FSuccess then
|
|
begin
|
|
// ViktorT
|
|
Factive := False;
|
|
RaiseLastOSError;
|
|
end;
|
|
While Not DataWaiting do
|
|
Sleep(10);
|
|
|
|
while DataWaiting do
|
|
begin
|
|
// Read from the pipe.
|
|
fSuccess := ReadFile(
|
|
hPipe, // pipe handle
|
|
fBuf[0], // buffer to receive reply
|
|
fSize, // size of buffer
|
|
FBytes, // number of bytes read
|
|
nil); // not overlapped
|
|
if (Not fSuccess) and (GetLastError <> ERROR_MORE_DATA) then
|
|
begin
|
|
// ViktorT
|
|
Factive := False;
|
|
RaiseLastOSError;
|
|
end;
|
|
if Fbytes > 0 then
|
|
aResponse.WriteBuffer(FBuf[0],fBytes);
|
|
end;
|
|
finally
|
|
FreeMem(fBuf);
|
|
end; // finally
|
|
*)
|
|
end; // SendAndRecv
|
|
|
|
|
|
function TRONamedPipeChannel.DataWaiting: Boolean;
|
|
var
|
|
fSuccess : BOOL;
|
|
BytesAvail : Integer;
|
|
begin
|
|
FSuccess := PeekNamedPipe(hPipe,nil,0,nil,@BytesAvail,nil);
|
|
if not FSuccess then
|
|
begin
|
|
// ViktorT
|
|
Factive := False;
|
|
RaiseLastOSError;
|
|
end;
|
|
result := (BytesAvail >0);
|
|
end; // DataWaiting
|
|
|
|
|
|
procedure TRONamedPipeChannel.SetActivateOnDemand(const Value: Boolean);
|
|
begin
|
|
FActivateOnDemand := Value;
|
|
end;
|
|
|
|
procedure TRONamedPipeChannel.SetActive(const Value: Boolean);
|
|
begin
|
|
if FActive <> Value then
|
|
begin
|
|
if Value
|
|
then Connect
|
|
else Disconnect;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TRONamedPipeChannel.SetServerID(const Value: string);
|
|
begin
|
|
fServerID := Value;
|
|
end;
|
|
|
|
procedure TRONamedPipeChannel.SetServerName(const Value: string);
|
|
begin
|
|
fServerName := Value;
|
|
end;
|
|
|
|
|
|
procedure TRONamedPipeChannel.CheckProperties;
|
|
begin
|
|
Check(ServerID = '', Name+'.ServerID must be set.');
|
|
Check(ServerName = '', Name+'.ServerName must be set.');
|
|
inherited;
|
|
end;
|
|
|
|
destructor TRONamedPipeChannel.Destroy;
|
|
begin
|
|
if FActive then begin
|
|
Disconnect;
|
|
end;
|
|
inherited;
|
|
end;
|
|
|
|
initialization
|
|
RegisterTransportChannelClass(TRONamedPipeChannel);
|
|
|
|
finalization
|
|
UnRegisterTransportChannelClass(TRONamedPipeChannel);
|
|
|
|
end.
|