Componentes.Terceros.RemObjects/internal/5.0.23.613/1/RemObjects SDK for Delphi/Source/uROWinMessageChannel.pas

unit uROWinMessageChannel;

{----------------------------------------------------------------------------}
{ RemObjects SDK Library - Core Library                                      }
{                                                                            }
{ compiler: Delphi 5 and up, Kylix 2 and up                                  }
{ platform: Win32, Linux                                                     }
{                                                                            }
{ (c)opyright RemObjects Software. all rights reserved.                      }
{                                                                            }
{ Using this code requires a valid license of the RemObjects SDK             }
{ which can be obtained at http://www.remobjects.com.                        }
{----------------------------------------------------------------------------}
{$I RemObjects.inc}

interface

{$WARN SYMBOL_DEPRECATED OFF} // This unit is only for Win32

uses
  {$IFDEF REMOBJECTS_TRIAL}uROTrial,{$ENDIF}
  Classes, uROClient, uROClientIntf, Forms, Messages, Windows, uROEventRepository;

type { TROWinMessageChannel }
     TROWinMessageChannel = class(TROTransportChannel, IROActiveEventChannel)
     private
       fServerHandle, fWindowHandle : HWND;
       fResponseRef : TStream;
       fStartServer: boolean;
       fServerID: string;
       fFileName: string;
       fParameters: string;
       fDefaultDirectory: string;
       fDelay: word;
       fActiveEvents: Boolean;
       fActiveGuid: TGUID;

       procedure WndProc(var Msg: TMessage);
       procedure SetFileName(const Value: string);
       procedure SetServerID(const Value: string);

     protected
       fEventReceiver: IROEventReceiver;
       procedure IntDispatch(aRequest, aResponse : TStream); override;
       procedure RegisterEventReceiver(aReceiver: IROEventReceiver);
       procedure UnregisterEventReceiver(aReceiver: IROEventReceiver);
       function QueryInterface(const IID: TGUID; out Obj): HRESULT; override; stdcall;
       procedure BeforeDispatch(aMessage: IROMessage); override;
       procedure OpenServer;
     public
       constructor Create(aOwner : TComponent); override;
       destructor Destroy; override;
       procedure CheckProperties; override;
     published
       property StartServer : boolean read fStartServer write fStartServer default false;
       property FileName : string read fFileName write SetFileName;
       property Parameters : string read fParameters write fParameters;
       property DefaultDirectory : string read fDefaultDirectory write fDefaultDirectory;
       property ServerID : string read fServerID write SetServerID;
       property Delay : word read fDelay write fDelay default 0;

       property ActiveEvents: Boolean read fActiveEvents write fActiveEvents default False;
       property ActiveGuid: TGUID read fActiveGuid write fActiveGuid;
     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

uses Dialogs, SysUtils, ShellAPI, uRORes, uROClasses;

{
  0 = Message Request/Response
  1 = Event back
  2 = Register me (guid arg)
  3 = Unregister me (guid arg)
}

{ TROWinMessageChannel }

procedure TROWinMessageChannel.BeforeDispatch(aMessage: IROMessage);
begin
  inherited;
  if fActiveEvents then begin
    if IsEqualGUID(fActiveGuid, EmptyGUID) then
      fActiveGuid := NewGuid;
    aMessage.ClientID := fActiveGuid;
  end;
end;

procedure TROWinMessageChannel.CheckProperties;
begin
  Check(ServerID = '', Name + '.ServerID must be set.');
  inherited;
end;

constructor TROWinMessageChannel.Create(aOwner: TComponent);
begin
  inherited;

  // Removed the check to make the component usable also at design time
  // There's no apparent problem with this
  {if not (csDesigning in ComponentState)
    then }fWindowHandle := AllocateHWnd(WndProc)
    //else fWindowHandle := 0;

  {Timeout := 30000; { ms }
end;

destructor TROWinMessageChannel.Destroy;
begin
  if (fWindowHandle>0)
    then DeallocateHWnd(fWindowHandle);
  inherited;
end;

procedure TROWinMessageChannel.IntDispatch(aRequest, aResponse: TStream);
var memstream : TMemoryStream;
    CDS : TCopyDataStruct;
    freememstream : boolean;
    //dwResult:Cardinal;
begin
  freememstream := not (aRequest is TMemoryStream);
  fResponseRef := aResponse;

  // Locates the server window
  OpenServer;

  if not freememstream then begin
    memstream := TMemoryStream(aRequest)
  end
  else begin
    memstream := TMemoryStream.Create;
    memstream.LoadFromStream(aRequest);
  end;

  memstream.Position := 0;
  try
    CDS.dwData := 0;
    CDS.cbData := memstream.Size;
    CDS.lpData := memstream.Memory;

    SendMessage(fServerHandle, WM_COPYDATA, fWindowHandle, Integer(@CDS));
    {if SendMessageTimeout(handle,WM_COPYDATA,fWindowHandle,Integer(@CDS),
                           SMTO_ABORTIFHUNG or SMTO_NORMAL,fTimeout,dwResult) = 0 then
        RaiseError(err_WinMessageFailed,[GetLastError()]);}

  finally
    if freememstream then memstream.Free;
    fResponseRef := nil;
  end;
end;

procedure TROWinMessageChannel.OpenServer;
begin
  CheckProperties;
  fServerHandle := FindWindow(NIL, PChar(ServerID));
  if (fServerHandle=0) then begin
    // Starts it
    if StartServer then begin
      ShellExecute(0, 'open', PChar(FileName), PChar(Parameters), PChar(DefaultDirectory), SW_NORMAL);
      Sleep(Delay);

      fServerHandle := FindWindow(NIL, PChar(ServerID));
    end;
  end;

  if (fServerHandle=0) then RaiseError(err_CannotFindServer, [ServerID]);
end;

function TROWinMessageChannel.QueryInterface(const IID: TGUID;
  out Obj): HRESULT;
begin
  if (IsEqualGUID(IROActiveEventChannel, iid)) and (not fActiveEvents) then begin
    Result := E_NOINTERFACE;
  end else
    result := inherited QueryInterface(IID, Obj);
end;

procedure TROWinMessageChannel.RegisterEventReceiver(
  aReceiver: IROEventReceiver);
var
  CDS : TCopyDataStruct;
begin
  fEventReceiver := aReceiver;
  if fEventReceiver <> nil then begin
    if IsEqualGUID(fActiveGuid, EmptyGUID) then
      fActiveGuid := NewGuid;

    OpenServer;

    CDS.dwData := 2;
    CDS.cbData := sizeof(fActiveGuid);
    CDS.lpData := @fActiveGuid;

    SendMessage(fServerHandle, WM_COPYDATA, fWindowHandle, Integer(@CDS));
  end;
end;

procedure TROWinMessageChannel.SetFileName(const Value: string);
begin
  fFileName := Value;
end;

procedure TROWinMessageChannel.SetServerID(const Value: string);
begin
  fServerID := Value;
end;

procedure TROWinMessageChannel.UnregisterEventReceiver(
  aReceiver: IROEventReceiver);
var
 CDS: TCopyDataStruct;
begin
  if fEventReceiver <> nil then begin
    if IsEqualGUID(fActiveGuid, EmptyGUID) then
      fActiveGuid := NewGuid;

    OpenServer;

    CDS.dwData := 3;
    CDS.cbData := sizeof(fActiveGuid);
    CDS.lpData := @fActiveGuid;

    SendMessage(fServerHandle, WM_COPYDATA, fWindowHandle, Integer(@CDS));
  end;
  fEventReceiver := nil;
end;

procedure TROWinMessageChannel.WndProc(var Msg: TMessage);
var WMMsg : TWMCopyData absolute Msg;
  lTmpStream: TMemoryStream;
begin
  with Msg do
    case Msg of
      WM_COPYDATA  : begin
        case WMMsg.CopyDataStruct.dwData of
          0: begin
            if fResponseRef = nil then exit;
            fResponseRef.Write(WMMsg.CopyDataStruct.lpData^, WMMsg.CopyDataStruct.cbData);
            fResponseRef.Position := 0;
          end;
          1: begin
            if fEventReceiver <> nil then begin
              lTmpStream := TMemoryStream.Create;
              try
                lTmpStream.Write(WMMsg.CopyDataStruct.lpData^, WMMsg.CopyDataStruct.cbData);
                lTmpStream.Position := 0;
                fEventReceiver.Dispatch(lTmpStream, nil);
              finally
                lTmpStream.Free;
              end;
            end;
          end;
        end;
      end;
      else result := DefWindowProc(FWindowHandle, Msg, wParam, lParam);
    end;
end;

initialization
  RegisterTransportChannelClass(TROWinMessageChannel);

finalization
  UnRegisterTransportChannelClass(TROWinMessageChannel);
end.