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

unit uROWinMessageServer;

{----------------------------------------------------------------------------}
{ 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

uses
  {$IFDEF REMOBJECTS_TRIAL}uROTrial,{$ENDIF}
  Classes, Windows, Messages, uROClientIntf, uROServer, uROEventRepository, uROServerIntf;

type { TROWinMessageServer }
     TROWinMessageServer = class(TROServer, IROTransport, IROActiveEventServer)
     private
       fWindowHandle : HWND;
       fServerID     : string;
       fTransport    : IROTransport;
       fActiveEventRepository : TROEventRepository;
       fActiveEventMap: TStringList;

       procedure WndProc(var Msg: TMessage);
       procedure DispatchEvent(anEventDataItem: TROEventData; aSessionReference: TGUID; aSender: TObject);
       procedure EventsRegistered(aSender: TObject; aClient: TGUID);
     protected
       { Internals }
       procedure IntSetActive(const Value: boolean); override;
       function IntGetActive : boolean; override;

       { IROTransport }
       function GetTransportObject : TObject;
       function QueryInterface(const IID: TGUID; out Obj): HRESULT; override; stdcall;

     public
       constructor Create(aOwner : TComponent); override;
       destructor Destroy; override;
       procedure CheckProperties; override;
     published
       property ServerID : string read fServerID write fServerID;
       property ActiveEventRepository : TROEventRepository read fActiveEventRepository write fActiveEventRepository;
     end;

implementation

uses Forms, Controls, SysUtils, uRORes, uROClasses;

var
  ROWindowClass: TWndClass = (
    style: 0;
    lpfnWndProc: @DefWindowProc;
    cbClsExtra: 0;
    cbWndExtra: 0;
    hInstance: 0;
    hIcon: 0;
    hCursor: 0;
    hbrBackground: 0;
    lpszMenuName: nil;
    lpszClassName: 'ROUtilWindow');

function AllocateHWnd(const aWindowName : string; Method: TWndMethod): HWND;
var tmpclass: TWndClass;
    isclsregistered: Boolean;
begin
  ROWindowClass.hInstance := HInstance;
  isclsregistered := GetClassInfo(HInstance, ROWindowClass.lpszClassName, tmpclass);

  if not isclsregistered or (tmpclass.lpfnWndProc <> @DefWindowProc) then begin
    if isclsregistered then Windows.UnregisterClass(ROWindowClass.lpszClassName, HInstance);
    Windows.RegisterClass(ROWindowClass);
  end;

  Result := CreateWindowEx(WS_EX_TOOLWINDOW, ROWindowClass.lpszClassName,
    PChar(aWindowName), WS_POPUP {!0}, 0, 0, 0, 0, 0, 0, HInstance, nil);

  if Assigned(Method)
    then SetWindowLong(Result, GWL_WNDPROC, Longint({$IFDEF DELPHI6UP}Classes.{$ENDIF}MakeObjectInstance(Method)));
end;

{ TROWinMessageServer }

constructor TROWinMessageServer.Create(aOwner: TComponent);
begin
  inherited;
  Supports(Self, IROTransport, fTransport);
  fWindowHandle := 0;
  fActiveEventMap := TStringList.Create;
end;

destructor TROWinMessageServer.Destroy;
begin
  if (fWindowHandle>1) then {$IFDEF DELPHI6UP}Classes.{$ENDIF}DeallocateHWnd(fWindowHandle);
  fActiveEventMap.Free;
  inherited;
end;

procedure TROWinMessageServer.WndProc(var Msg: TMessage);
var WMMsg : TWMCopyData absolute Msg;
    requeststream,
    responsestream : TMemoryStream;
    CDS: TCopyDataStruct;
    s: string;
    i: Integer;
begin
  requeststream := NIL;
  responsestream := NIL;

  with Msg do
    case Msg of
      WM_COPYDATA  : try
        case WMMsg.CopyDataStruct.dwData of
          0: begin
            requeststream := TMemoryStream.Create;
            responsestream := TMemoryStream.Create;

            requeststream.Write(WMMsg.CopyDataStruct.lpData^, WMMsg.CopyDataStruct.cbData);
            requeststream.Position := 0;

            //ProcessMessage(MessageIntf, fTransport, requeststream, responsestream);
            DispatchMessage(fTransport, requeststream, responsestream);

            CDS.dwData := 0;
            CDS.cbData := responsestream.Size;
            CDS.lpData := responsestream.Memory;

            SendMessage(WMMsg.From, WM_COPYDATA, 0, Integer(@CDS));
          end;
          2:
            begin
              if WMMsg.CopyDataStruct.cbData = sizeof(TGuid) then begin
                s := GuidToString(PGuid(WMMsg.CopyDataStruct.lpData)^);
                fActiveEventMap.Values[s] := IntToStr(WMMsg.From);
                if assigned(fActiveEventRepository) then
                  fActiveEventRepository.AddSession(PGuid(WMMsg.CopyDataStruct.lpData)^, Self)
              end;
            end;
          3:
            begin
              if WMMsg.CopyDataStruct.cbData = sizeof(TGuid) then begin
                s := GuidToString(PGuid(WMMsg.CopyDataStruct.lpData)^);
                i := fActiveEventMap.IndexOfName(s);
                if i <> -1 then
                  fActiveEventMap.Delete(i);
                if assigned(fActiveEventRepository) then
                  fActiveEventRepository.RemoveSession(PGuid(WMMsg.CopyDataStruct.lpData)^);
              end;
            end;
        end;
      finally
        responsestream.Free;
        requeststream.Free;
      end;
      else result := DefWindowProc(FWindowHandle, Msg, wParam, lParam);
    end;
end;

function TROWinMessageServer.IntGetActive: boolean;
begin
  result := (fWindowHandle>0);
end;

procedure TROWinMessageServer.IntSetActive(const Value: boolean);
begin
  if Value then begin
    if not (csDesigning in ComponentState)
      then begin
        CheckProperties;
        fWindowHandle := AllocateHWnd(ServerID, WndProc);
      end  
      else fWindowHandle := 1; // To save the property value
  end
  else begin
    if (fWindowHandle>0) then begin
      if (fWindowHandle>1) then {$IFDEF DELPHI6UP}Classes.{$ENDIF}DeallocateHWnd(fWindowHandle);
      fWindowHandle := 0;
    end;
  end;
end;

function TROWinMessageServer.GetTransportObject: TObject;
begin
  result := Self;
end;

function TROWinMessageServer.QueryInterface(const IID: TGUID;
  out Obj): HRESULT;
begin
  if IsEqualGUID(IROActiveEventServer, IID) and not assigned(fActiveEventRepository) then
    result := E_NOINTERFACE
  else
    result := inherited QueryInterface(IID, Obj) 
end;

procedure TROWinMessageServer.DispatchEvent(anEventDataItem: TROEventData;
  aSessionReference: TGUID; aSender: TObject);
var
  lHandle: HWND;
  cds: TCopyDataStruct;
begin
  lHandle := StrToIntDef(fActiveEventMap.Values[GUIDToString(aSessionReference)], 0);
  if lHandle = 0 then exit; // doesn't exist.
  CDS.dwData := 1;
  CDS.cbData := TMemoryStream(anEventDataItem.Data).Size;
  CDS.lpData := TMemoryStream(anEventDataItem.Data).Memory;

  SendMessage(lHandle, WM_COPYDATA, 0, Integer(@CDS));
end;

procedure TROWinMessageServer.EventsRegistered(aSender: TObject;
  aClient: TGUID);
begin

end;

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

initialization
  RegisterServerClass(TROWinMessageServer);
finalization
  UnregisterServerClass(TROWinMessageServer);
end.