+arm/wince more fcl units : simpleipc

git-svn-id: trunk@2053 -

.gitattributes

@@ -1044,6 +1044,7 @@ fcl/wince/ezcgi.inc svneol=native#text/plain
 fcl/wince/fileinfo.pp svneol=native#text/plain
 fcl/wince/pipes.inc svneol=native#text/plain
 fcl/wince/process.inc svneol=native#text/plain
+fcl/wince/simpleipc.inc svneol=native#text/plain
 fcl/xml/Makefile svneol=native#text/plain
 fcl/xml/Makefile.fpc svneol=native#text/plain
 fcl/xml/README -text

fcl/Makefile

@@ -392,7 +392,7 @@ ifeq ($(FULL_TARGET),i386-netwlibc)
 override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  resolve ssockets syncobjs
 endif
 ifeq ($(FULL_TARGET),i386-wince)
-override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process fileinfo
+override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process fileinfo simpleipc
 endif
 ifeq ($(FULL_TARGET),m68k-linux)
 override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process resolve ssockets fpasync syncobjs simpleipc msgintf dbugintf
@@ -452,7 +452,7 @@ ifeq ($(FULL_TARGET),arm-linux)
 override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process resolve ssockets fpasync syncobjs simpleipc msgintf dbugintf
 endif
 ifeq ($(FULL_TARGET),arm-wince)
-override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process fileinfo
+override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process fileinfo simpleipc
 endif
 ifeq ($(FULL_TARGET),powerpc64-linux)
 override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls avl_tree xmlreg registry eventlog custapp cgiapp wformat whtml wtex rttiutils bufstream streamex  process resolve ssockets fpasync syncobjs simpleipc msgintf dbugintf

fcl/Makefile.fpc

@@ -33,7 +33,7 @@ units_netbsd=process ssockets resolve fpasync simpleipc msgintf dbugintf
 units_openbsd=process ssockets resolve fpasync simpleipc msgintf dbugintf
 units_linux=process resolve ssockets fpasync syncobjs simpleipc msgintf dbugintf
 units_win32=process fileinfo resolve ssockets syncobjs simpleipc msgintf dbugintf
-units_wince=process fileinfo
+units_wince=process fileinfo simpleipc
 units_os2=resolve ssockets
 units_emx=resolve ssockets
 units_netware=resolve ssockets

fcl/wince/simpleipc.inc

@@ -0,0 +1,291 @@
+{
+    This file is part of the Free Component library.
+    Copyright (c) 2005 by Michael Van Canneyt, member of
+    the Free Pascal development team
+
+    Windows implementation of one-way IPC between 2 processes
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+uses Windows,messages;
+
+Const
+  MsgWndClassName : pwidechar = 'FPCMsgWindowCls';
+
+Resourcestring
+  SErrFailedToRegisterWindowClass = 'Failed to register message window class';
+  SErrFailedToCreateWindow = 'Failed to create message window %s';
+
+var
+  MsgWindowClass: TWndClass = (
+    style: 0;
+    lpfnWndProc: Nil;
+    cbClsExtra: 0;
+    cbWndExtra: 0;
+    hInstance: 0;
+    hIcon: 0;
+    hCursor: 0;
+    hbrBackground: 0;
+    lpszMenuName: nil;
+    lpszClassName: Nil);
+
+{ ---------------------------------------------------------------------
+    TWinMsgServerComm
+  ---------------------------------------------------------------------}
+
+Type
+  TWinMsgServerComm = Class(TIPCServerComm)
+  Private
+    FHWND : HWND;
+    FWindowName : Widestring;
+    FDataPushed : Boolean;
+    Function AllocateHWnd(const cwsWindowName : widestring) : HWND;
+  Public
+    Constructor Create(AOwner : TSimpleIPCServer); override;
+    procedure ReadMsgData(var Msg: TMsg);
+    Procedure StartServer; override;
+    Procedure StopServer; override;
+    Function  PeekMessage(TimeOut : Integer) : Boolean; override;
+    Procedure ReadMessage ; override;
+    Function GetInstanceID : String;override;
+    Property WindowName : WideString Read FWindowName;
+  end;
+
+
+function MsgWndProc(HWindow: HWnd; Message, WParam, LParam: Longint): Longint;stdcall;
+
+Var
+  I   : TWinMsgServerComm;
+  Msg : TMsg;
+
+begin
+  Result:=0;
+  If (Message=WM_COPYDATA) then
+    begin
+    I:=TWinMsgServerComm(GetWindowLong(HWindow,GWL_USERDATA));
+    If (I<>NIl) then
+      begin
+      Msg.Message:=Message;
+      Msg.WParam:=WParam;
+      Msg.LParam:=LParam;
+      I.ReadMsgData(Msg);
+      I.FDataPushed:=True;
+      If Assigned(I.Owner.OnMessage) then
+        I.Owner.ReadMessage;
+      Result:=1;
+      end
+    end
+  else
+    Result:=DefWindowProc(HWindow,Message,WParam,LParam);
+end;
+
+
+function TWinMsgServerComm.AllocateHWnd(const cwsWindowName: Widestring): HWND;
+
+var
+  cls: LPWNDCLASS;
+  isreg : Boolean;
+
+begin
+  Pointer(MsgWindowClass.lpfnWndProc):=@MsgWndProc;
+  MsgWindowClass.hInstance := HInstance;
+  MsgWindowClass.lpszClassName:=MsgWndClassName;
+  isreg:=GetClassInfo(HInstance,MsgWndClassName,cls);
+  if not isreg then
+    if (Windows.RegisterClass(MsgWindowClass)=0) then
+      Owner.DoError(SErrFailedToRegisterWindowClass,[]);
+  Result:=CreateWindowEx(WS_EX_TOOLWINDOW, MsgWndClassName,
+    PWidechar(cwsWindowName), WS_POPUP {!0}, 0, 0, 0, 0, 0, 0, HInstance, nil);
+  if (Result=0) then
+    Owner.DoError(SErrFailedToCreateWindow,[cwsWindowName]);
+  SetWindowLong(Result,GWL_USERDATA,Longint(Self));
+end;
+
+constructor TWinMsgServerComm.Create(AOWner: TSimpleIPCServer);
+begin
+  inherited Create(AOWner);
+  FWindowName:=Owner.ServerID;
+  If not Owner.Global then
+    FWindowName:=FWindowName+'_'+InstanceID;
+end;
+
+procedure TWinMsgServerComm.StartServer;
+
+begin
+  FHWND:=AllocateHWND(FWindowName);
+end;
+
+procedure TWinMsgServerComm.StopServer;
+begin
+  DestroyWindow(FHWND);
+  FHWND:=0;
+end;
+
+function TWinMsgServerComm.PeekMessage(TimeOut: Integer): Boolean;
+
+Var
+  Msg : Tmsg;
+  B : Boolean;
+  R : DWORD;
+
+begin
+  Result:=FDataPushed;
+  If Result then
+    Exit;
+  B:=Windows.PeekMessage(Msg, FHWND, 0, 0, PM_NOREMOVE);
+  If not B then
+    // No message yet. Wait for a message to arrive available within specified time.
+    begin
+    if (TimeOut=0) then
+      TimeOut:=Integer(INFINITE);
+    R:=MsgWaitForMultipleObjects(1,FHWND,False,TimeOut,QS_SENDMESSAGE);
+    B:=(R<>WAIT_TIMEOUT);
+    end;
+  If B then
+    Repeat
+    B:=Windows.PeekMessage(Msg, FHWND, 0, 0, PM_NOREMOVE);
+    if B then
+      begin
+      Result:=(Msg.Message=WM_COPYDATA);
+      // Remove non WM_COPY messages from Queue
+      if not Result then
+        GetMessage(@Msg,FHWND,0,0);
+      end;
+    Until Result or (not B);
+end;
+
+procedure TWinMsgServerComm.ReadMsgData(var Msg: TMsg);
+
+Var
+  CDS : PCopyDataStruct;
+
+begin
+  CDS:=PCopyDataStruct(Msg.Lparam);
+  Owner.FMsgData.Seek(0,soFrombeginning);
+  Owner.FMsgData.WriteBuffer(CDS^.lpData^,CDS^.cbData);
+end;
+
+procedure TWinMsgServerComm.ReadMessage;
+
+Var
+  Msg : TMsg;
+
+begin
+  If FDataPushed then
+    FDataPushed:=False
+  else
+    If Windows.PeekMessage(Msg, FHWND, 0, 0, PM_REMOVE) then
+      if (Msg.Message=WM_COPYDATA) then
+        ReadMsgData(Msg);
+end;
+
+function TWinMsgServerComm.GetInstanceID: String;
+begin
+  Result:=IntToStr(HInstance);
+end;
+
+{ ---------------------------------------------------------------------
+    TWinMsgClientComm
+  ---------------------------------------------------------------------}
+  
+Type
+  TWinMsgClientComm = Class(TIPCClientComm)
+  Private
+    FWindowName: String;
+    FHWND : HWnd;
+  Public
+    Constructor Create(AOWner : TSimpleIPCClient); override;
+    Procedure Connect; override;
+    Procedure Disconnect; override;
+    Procedure SendMessage(MsgType : TMessageType; Stream : TStream); override;
+    Function  ServerRunning : Boolean; override;
+    Property WindowName : String Read FWindowName;
+  end;
+
+
+constructor TWinMsgClientComm.Create(AOWner: TSimpleIPCClient);
+begin
+  inherited Create(AOWner);
+  FWindowName:=Owner.ServerID;
+  If (Owner.ServerInstance<>'') then
+    FWindowName:=FWindowName+'_'+Owner.ServerInstance;
+end;
+
+procedure TWinMsgClientComm.Connect;
+begin
+  FHWND:=FindWindow(MsgWndClassName,Pwidechar(FWindowName));
+  If (FHWND=0) then
+    Owner.DoError(SErrServerNotActive,[Owner.ServerID]);
+end;
+
+procedure TWinMsgClientComm.Disconnect;
+begin
+  FHWND:=0;
+end;
+
+procedure TWinMsgClientComm.SendMessage(MsgType: TMessageType; Stream: TStream
+  );
+Var
+  CDS : TCopyDataStruct;
+  Data,FMemstr : TMemorySTream;
+
+begin
+  If Stream is TMemoryStream then
+    begin
+    Data:=TMemoryStream(Stream);
+    FMemStr:=Nil
+    end
+  else
+    begin
+    FMemStr:=TMemoryStream.Create;
+    Data:=FMemstr;
+    end;
+  Try
+    If Assigned(FMemStr) then
+      begin
+      FMemStr.CopyFrom(Stream,0);
+      FMemStr.Seek(0,soFromBeginning);
+      end;
+    CDS.lpData:=Data.Memory;
+    CDS.cbData:=Data.Size;
+    Windows.SendMessage(FHWnd,WM_COPYDATA,0,Integer(@CDS));
+  Finally
+    FreeAndNil(FMemStr);
+  end;
+end;
+
+function TWinMsgClientComm.ServerRunning: Boolean;
+begin
+  Result:=FindWindow(MsgWndClassName,PWidechar(FWindowName))<>0;
+end;
+
+{ ---------------------------------------------------------------------
+    Set TSimpleIPCClient / TSimpleIPCServer defaults.
+  ---------------------------------------------------------------------}
+
+
+Function TSimpleIPCServer.CommClass : TIPCServerCommClass;
+
+begin
+  if (DefaultIPCServerClass<>Nil) then
+    Result:=DefaultIPCServerClass
+  else  
+    Result:=TWinMsgServerComm;
+end;
+
+Function TSimpleIPCClient.CommClass : TIPCClientCommClass;
+
+begin
+  if (DefaultIPCClientClass<>Nil) then
+    Result:=DefaultIPCClientClass
+  else  
+    Result:=TWinMsgClientComm;
+end;
+