paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-11 18:49:14 +02:00
Code Issues Packages Projects Releases Wiki Activity

# revisions: 32859,32989,32994,32997,32999

Browse Source 
git-svn-id: branches/fixes_3_0@33765 -
This commit is contained in:
marco 2016-05-23 18:36:55 +00:00
parent 26fb374730
commit 99a9e1fd62
6 changed files with 593 additions and 599 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitattributes vendored
View File

@ -2574,9 +2574,8 @@ packages/fcl-process/src/unix/process.inc svneol=native#text/plain
packages/fcl-process/src/unix/simpleipc.inc svneol=native#text/plain
packages/fcl-process/src/win/pipes.inc svneol=native#text/plain
packages/fcl-process/src/win/process.inc svneol=native#text/plain
packages/fcl-process/src/win/simpleipc.inc svneol=native#text/plain
packages/fcl-process/src/winall/simpleipc.inc svneol=native#text/plain
packages/fcl-process/src/wince/process.inc svneol=native#text/plain
packages/fcl-process/src/wince/simpleipc.inc svneol=native#text/plain
packages/fcl-registry/Makefile svneol=native#text/plain
packages/fcl-registry/Makefile.fpc svneol=native#text/plain
packages/fcl-registry/Makefile.fpc.fpcmake svneol=native#text/plain

2
packages/fcl-process/fpmake.pp
View File

@ -29,6 +29,7 @@ begin
P.SourcePath.Add('src');
P.IncludePath.Add('src/unix',AllUnixOSes);
P.IncludePath.Add('src/winall',AllWindowsOSes);
P.IncludePath.Add('src/win',[win32,win64]);
P.IncludePath.Add('src/amicommon',AllAmigaLikeOSes);
P.IncludePath.Add('src/$(OS)',AllOSes-[win32,win64]-AllUnixOSes-AllAmigaLikeOSes);
@ -37,6 +38,7 @@ begin
P.Dependencies.add('morphunits',[morphos]);
P.Dependencies.add('arosunits',[aros]);
P.Dependencies.add('amunits',[amiga]);
P.Dependencies.add('fcl-base');
T:=P.Targets.AddUnit('pipes.pp');
T.Dependencies.AddInclude('pipes.inc');

42
packages/fcl-process/src/simpleipc.pp
View File

@ -28,7 +28,15 @@ Const
//Message types
mtUnknown = 0;
mtString = 1;
type
TIPCMessageOverflowAction = (ipcmoaNone, ipcmoaDiscardOld, ipcmoaDiscardNew, ipcmoaError);
var
// Currently implemented only for Windows platform!
DefaultIPCMessageOverflowAction: TIPCMessageOverflowAction = ipcmoaNone;
DefaultIPCMessageQueueLimit: Integer = 0;
Type
TMessageType = LongInt;
@ -48,7 +56,7 @@ Type
FOwner : TSimpleIPCServer;
Protected
Function GetInstanceID : String; virtual; abstract;
Procedure DoError(Msg : String; Args : Array of const);
Procedure DoError(const Msg : String; const Args : Array of const);
Procedure SetMsgType(AMsgType: TMessageType);
Function MsgData : TStream;
Public
@ -71,7 +79,7 @@ Type
FBusy: Boolean;
FActive : Boolean;
FServerID : String;
Procedure DoError(Msg : String; Args : Array of const);
Procedure DoError(const Msg: String; const Args: array of const);
Procedure CheckInactive;
Procedure CheckActive;
Procedure Activate; virtual; abstract;
@ -99,13 +107,13 @@ Type
Function CommClass : TIPCServerCommClass; virtual;
Procedure Activate; override;
Procedure Deactivate; override;
Procedure ReadMessage;
Public
Constructor Create(AOwner : TComponent); override;
Destructor Destroy; override;
Procedure StartServer;
Procedure StopServer;
Function PeekMessage(TimeOut : Integer; DoReadMessage : Boolean): Boolean;
Procedure ReadMessage;
Property StringMessage : String Read GetStringMessage;
Procedure GetMessageData(Stream : TStream);
Property MsgType: TMessageType Read FMsgType;
@ -122,7 +130,7 @@ Type
private
FOwner: TSimpleIPCClient;
protected
Procedure DoError(Msg : String; Args : Array of const);
Procedure DoError(const Msg : String; const Args : Array of const);
Public
Constructor Create(AOwner : TSimpleIPCClient); virtual;
Property Owner : TSimpleIPCClient read FOwner;
@ -195,7 +203,7 @@ begin
FOwner:=AOWner;
end;
Procedure TIPCServerComm.DoError(Msg : String; Args : Array of const);
Procedure TIPCServerComm.DoError(const Msg : String; const Args : Array of const);
begin
FOwner.DoError(Msg,Args);
@ -222,7 +230,7 @@ begin
FOwner:=AOwner;
end;
Procedure TIPCClientComm.DoError(Msg : String; Args : Array of const);
Procedure TIPCClientComm.DoError(const Msg : String; const Args : Array of const);
begin
FOwner.DoError(Msg,Args);
@ -232,9 +240,15 @@ end;
TSimpleIPC
---------------------------------------------------------------------}
procedure TSimpleIPC.DoError(Msg: String; Args: array of const);
Procedure TSimpleIPC.DoError(const Msg: String; const Args: array of const);
var
FullMsg: String;
begin
Raise EIPCError.Create(Name+': '+Format(Msg,Args));
if Length(Name) > 0
then FullMsg := Name + ': '
else FullMsg := '';
FullMsg := FullMsg + Format(Msg, Args);
raise EIPCError.Create(FullMsg);
end;
procedure TSimpleIPC.CheckInactive;
@ -351,10 +365,16 @@ begin
FActive:=False;
end;
function TSimpleIPCServer.PeekMessage(TimeOut: Integer; DoReadMessage: Boolean
): Boolean;
// TimeOut values:
// > 0 -- number of milliseconds to wait
// = 0 -- return immediately
// = -1 -- wait infinitely
// < -1 -- wait infinitely (force to -1)
function TSimpleIPCServer.PeekMessage(TimeOut: Integer; DoReadMessage: Boolean): Boolean;
begin
CheckActive;
if TimeOut < -1 then
TimeOut := -1;
FBusy:=True;
Try
Result:=FIPCComm.PeekMessage(Timeout);

294
packages/fcl-process/src/win/simpleipc.inc
View File

@ -1,294 +0,0 @@
{
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 : pchar = 'FPCMsgWindowCls';
Resourcestring
SErrFailedToRegisterWindowClass = 'Failed to register message window class';
SErrFailedToCreateWindow = 'Failed to create message window %s';
var
MsgWindowClass: TWndClassA = (
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 : String;
FDataPushed : Boolean;
FUnction AllocateHWnd(Const aWindowName : String) : 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 : String 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(GetWindowLongPtr(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 aWindowName: String): HWND;
var
cls: TWndClassA;
isreg : Boolean;
begin
Pointer(MsgWindowClass.lpfnWndProc):=@MsgWndProc;
MsgWindowClass.hInstance := HInstance;
MsgWindowClass.lpszClassName:=MsgWndClassName;
isreg:=GetClassInfoA(HInstance,MsgWndClassName,cls);
if not isreg then
if (Windows.RegisterClassA(MsgWindowClass)=0) then
Owner.DoError(SErrFailedToRegisterWindowClass,[]);
Result:=CreateWindowExA(WS_EX_TOOLWINDOW, MsgWndClassName,
PChar(aWindowName), WS_POPUP {!0}, 0, 0, 0, 0, 0, 0, HInstance, nil);
if (Result=0) then
Owner.DoError(SErrFailedToCreateWindow,[aWindowName]);
SetWindowLongPtr(Result,GWL_USERDATA,PtrInt(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.FMsgType:=CDS^.dwData;
Owner.FMsgData.Size:=0;
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:=FindWindowA(MsgWndClassName,PChar(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.dwData:=MsgType;
CDS.lpData:=Data.Memory;
CDS.cbData:=Data.Size;
Windows.SendMessage(FHWnd,WM_COPYDATA,0,PtrInt(@CDS));
Finally
FreeAndNil(FMemStr);
end;
end;
function TWinMsgClientComm.ServerRunning: Boolean;
begin
Result:=FindWindowA(MsgWndClassName,PChar(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;

559
packages/fcl-process/src/winall/simpleipc.inc Normal file
View File

@ -0,0 +1,559 @@
{
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,contnrs;
const
MsgWndClassName: WideString = 'FPCMsgWindowCls';
resourcestring
SErrFailedToRegisterWindowClass = 'Failed to register message window class';
SErrFailedToCreateWindow = 'Failed to create message window %s';
SErrMessageQueueOverflow = 'Message queue overflow (limit %s)';
var
MsgWindowClass: TWndClassW = (
style: 0;
lpfnWndProc: nil;
cbClsExtra: 0;
cbWndExtra: 0;
hInstance: 0;
hIcon: 0;
hCursor: 0;
hbrBackground: 0;
lpszMenuName: nil;
lpszClassName: nil);
type
TWinMsgServerMsg = class
strict private
FStream: TStream;
FMsgType: TMessageType;
public
constructor Create;
destructor Destroy; override;
property Stream: TStream read FStream;
property MsgType: TMessageType read FMsgType write FMsgType;
end;
TWinMsgServerMsgQueue = class
strict private
FList: TFPObjectList;
FMaxCount: Integer;
FMaxAction: TIPCMessageOverflowAction;
function GetCount: Integer;
procedure DeleteAndFree(Index: Integer);
function PrepareToPush: Boolean;
public
constructor Create;
destructor Destroy; override;
procedure Clear;
procedure Push(AItem: TWinMsgServerMsg);
function Pop: TWinMsgServerMsg;
property Count: Integer read GetCount;
property MaxCount: Integer read FMaxCount write FMaxCount;
property MaxAction: TIPCMessageOverflowAction read FMaxAction write FMaxAction;
end;
TWinMsgServerComm = Class(TIPCServerComm)
strict private
FHWND : HWND;
FWindowName : String;
FWndProcException: Boolean;
FWndProcExceptionMsg: String;
FMsgQueue: TWinMsgServerMsgQueue;
function AllocateHWnd(const aWindowName: WideString) : HWND;
procedure ProcessMessages;
procedure ProcessMessagesWait(TimeOut: Integer);
procedure HandlePostedMessage(const Msg: TMsg); inline;
function HaveQueuedMessages: Boolean; inline;
function CountQueuedMessages: Integer; inline;
procedure CheckWndProcException; inline;
private
procedure ReadMsgData(var Msg: TMsg);
function TryReadMsgData(var Msg: TMsg; out Error: String): Boolean;
procedure SetWndProcException(const ErrorMsg: String); inline;
public
constructor Create(AOwner : TSimpleIPCServer); override;
destructor Destroy; override;
Procedure StartServer; override;
Procedure StopServer; override;
Function PeekMessage(TimeOut : Integer) : Boolean; override;
Procedure ReadMessage ; override;
Function GetInstanceID : String;override;
Property WindowName : String Read FWindowName;
end;
{ ---------------------------------------------------------------------
TWinMsgServerMsg / TWinMsgServerMsgQueue
---------------------------------------------------------------------}
constructor TWinMsgServerMsg.Create;
begin
FMsgType := 0;
FStream := TMemoryStream.Create;
end;
destructor TWinMsgServerMsg.Destroy;
begin
FStream.Free;
end;
constructor TWinMsgServerMsgQueue.Create;
begin
FMaxCount := DefaultIPCMessageQueueLimit;
FMaxAction := DefaultIPCMessageOverflowAction;
FList := TFPObjectList.Create(False); // FreeObjects = False!
end;
destructor TWinMsgServerMsgQueue.Destroy;
begin
Clear;
FList.Free;
end;
procedure TWinMsgServerMsgQueue.Clear;
begin
while FList.Count > 0 do
DeleteAndFree(FList.Count - 1);
end;
procedure TWinMsgServerMsgQueue.DeleteAndFree(Index: Integer);
begin
FList[Index].Free; // Free objects manually!
FList.Delete(Index);
end;
function TWinMsgServerMsgQueue.GetCount: Integer;
begin
Result := FList.Count;
end;
function TWinMsgServerMsgQueue.PrepareToPush: Boolean;
begin
Result := True;
case FMaxAction of
ipcmoaDiscardOld:
begin
while (FList.Count >= FMaxCount) do
DeleteAndFree(FList.Count - 1);
end;
ipcmoaDiscardNew:
begin
Result := (FList.Count < FMaxCount);
end;
ipcmoaError:
begin
if (FList.Count >= FMaxCount) then
// Caller is expected to catch this exception, so not using Owner.DoError()
raise EIPCError.CreateFmt(SErrMessageQueueOverflow, [IntToStr(FMaxCount)]);
end;
end;
end;
procedure TWinMsgServerMsgQueue.Push(AItem: TWinMsgServerMsg);
begin
if PrepareToPush then
FList.Insert(0, AItem);
end;
function TWinMsgServerMsgQueue.Pop: TWinMsgServerMsg;
var
Index: Integer;
begin
Index := FList.Count - 1;
if Index >= 0 then
begin
// Caller is responsible for freeing the object.
Result := TWinMsgServerMsg(FList[Index]);
FList.Delete(Index);
end
else
Result := nil;
end;
{ ---------------------------------------------------------------------
MsgWndProc
---------------------------------------------------------------------}
function MsgWndProc(Window: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
Var
Server: TWinMsgServerComm;
Msg: TMsg;
MsgError: String;
begin
Result:=0;
if (uMsg=WM_COPYDATA) then
begin
// Post WM_USER to wake up GetMessage call.
PostMessage(Window, WM_USER, 0, 0);
// Read message data and add to message queue.
Server:=TWinMsgServerComm(GetWindowLongPtr(Window,GWL_USERDATA));
if Assigned(Server) then
begin
Msg.Message:=uMsg;
Msg.wParam:=wParam;
Msg.lParam:=lParam;
// Exceptions thrown inside WindowProc may not propagate back
// to the caller in some circumstances (according to MSDN),
// so capture it and raise it outside of WindowProc!
if Server.TryReadMsgData(Msg, MsgError) then
Result:=1 // True
else
begin
Result:=0; // False
Server.SetWndProcException(MsgError);
end;
end;
end
else
begin
Result:=DefWindowProcW(Window,uMsg,wParam,lParam);
end;
end;
{ ---------------------------------------------------------------------
TWinMsgServerComm
---------------------------------------------------------------------}
function TWinMsgServerComm.AllocateHWnd(const aWindowName: WideString): HWND;
var
cls: TWndClassW;
isreg : Boolean;
begin
MsgWindowClass.lpfnWndProc:=@MsgWndProc;
MsgWindowClass.hInstance := HInstance;
MsgWindowClass.lpszClassName:=PWideChar(MsgWndClassName);
isreg:=GetClassInfoW(HInstance,PWideChar(MsgWndClassName),@cls);
if not isreg then
if (Windows.RegisterClassW(MsgWindowClass)=0) then
Owner.DoError(SErrFailedToRegisterWindowClass,[]);
Result:=CreateWindowExW(WS_EX_TOOLWINDOW, PWideChar(MsgWndClassName),
PWideChar(aWindowName), WS_POPUP {!0}, 0, 0, 0, 0, 0, 0, HInstance, nil);
if (Result=0) then
Owner.DoError(SErrFailedToCreateWindow,[aWindowName]);
SetWindowLongPtr(Result,GWL_USERDATA,PtrInt(Self));
end;
constructor TWinMsgServerComm.Create(AOwner: TSimpleIPCServer);
begin
inherited Create(AOwner);
FWindowName := Owner.ServerID;
If not Owner.Global then
FWindowName := FWindowName+'_'+InstanceID;
FWndProcException := False;
FWndProcExceptionMsg := '';
FMsgQueue := TWinMsgServerMsgQueue.Create;
end;
destructor TWinMsgServerComm.Destroy;
begin
StopServer;
FMsgQueue.Free;
inherited;
end;
procedure TWinMsgServerComm.StartServer;
begin
StopServer;
FHWND := AllocateHWND(WideString(FWindowName));
end;
procedure TWinMsgServerComm.StopServer;
begin
FMsgQueue.Clear;
if FHWND <> 0 then
begin
DestroyWindow(FHWND);
FHWND := 0;
end;
end;
procedure TWinMsgServerComm.SetWndProcException(const ErrorMsg: String); inline;
begin
FWndProcException := True;
FWndProcExceptionMsg := ErrorMsg;
end;
procedure TWinMsgServerComm.CheckWndProcException; inline;
var
Msg: String;
begin
if FWndProcException then
begin
Msg := FWndProcExceptionMsg;
FWndProcException := False;
FWndProcExceptionMsg := '';
Owner.DoError(Msg, []);
end;
end;
function TWinMsgServerComm.HaveQueuedMessages: Boolean; inline;
begin
Result := (FMsgQueue.Count > 0);
end;
function TWinMsgServerComm.CountQueuedMessages: Integer; inline;
begin
Result := FMsgQueue.Count;
end;
procedure TWinMsgServerComm.HandlePostedMessage(const Msg: TMsg); inline;
begin
if Msg.message <> WM_USER then
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end
end;
procedure TWinMsgServerComm.ProcessMessages;
var
Msg: TMsg;
begin
// Windows.PeekMessage dispatches incoming sent messages by directly
// calling associated WindowProc, and then checks the thread message queue
// for posted messages and retrieves a message if any available.
// Note: WM_COPYDATA is a sent message, not posted, so it will be processed
// directly via WindowProc inside of Windows.PeekMessage call.
while Windows.PeekMessage(Msg, FHWND, 0, 0, PM_REMOVE) do
begin
// Empty the message queue by processing all posted messages.
HandlePostedMessage(Msg);
end;
end;
procedure TWinMsgServerComm.ProcessMessagesWait(TimeOut: Integer);
var
Msg: TMsg;
TimerID: UINT_PTR;
GetMessageResult: BOOL;
begin
// Not allowed to wait.
if TimeOut = 0 then
Exit;
// Setup a timer to post WM_TIMER to wake up GetMessage call.
if TimeOut > 0 then
TimerID := SetTimer(FHWND, 0, TimeOut, nil)
else
TimerID := 0;
// Wait until a message arrives.
try
// We either need to wait infinitely or we have a timer.
if (TimeOut < 0) or (TimerID <> 0) then
begin
// Windows.GetMessage dispatches incoming sent messages until a posted
// message is available for retrieval. Note: WM_COPYDATA will not actually
// wake up Windows.GetMessage, so we must post a dummy message when
// we receive WM_COPYDATA inside of WindowProc.
GetMessageResult := Windows.GetMessage(Msg, FHWND, 0, 0);
case LongInt(GetMessageResult) of
-1, 0: ;
else HandlePostedMessage(Msg);
end;
end;
finally
// Destroy timer.
if TimerID <> 0 then
KillTimer(FHWND, TimerID);
end;
end;
function TWinMsgServerComm.PeekMessage(TimeOut: Integer): Boolean;
begin
// Process incoming messages.
ProcessMessages;
// Do we have queued messages?
Result := HaveQueuedMessages;
// Wait for incoming messages.
if (not Result) and (TimeOut <> 0) then
begin
ProcessMessagesWait(TimeOut);
Result := HaveQueuedMessages;
end;
// Check for exception raised inside WindowProc.
CheckWndProcException;
end;
procedure TWinMsgServerComm.ReadMsgData(var Msg: TMsg);
var
CDS: PCopyDataStruct;
MsgItem: TWinMsgServerMsg;
begin
CDS := PCopyDataStruct(Msg.lParam);
MsgItem := TWinMsgServerMsg.Create;
try
MsgItem.MsgType := CDS^.dwData;
MsgItem.Stream.WriteBuffer(CDS^.lpData^,CDS^.cbData);
except
FreeAndNil(MsgItem);
// Caller is expected to catch this exception, so not using Owner.DoError()
raise;
end;
FMsgQueue.Push(MsgItem);
end;
function TWinMsgServerComm.TryReadMsgData(var Msg: TMsg; out Error: String): Boolean;
begin
Result := True;
try
ReadMsgData(Msg);
except on E: Exception do
begin
Result := False;
Error := E.Message;
end;
end;
end;
procedure TWinMsgServerComm.ReadMessage;
var
MsgItem: TWinMsgServerMsg;
begin
MsgItem := FMsgQueue.Pop;
if Assigned(MsgItem) then
try
// Load message from the queue into the owner's message data.
MsgItem.Stream.Position := 0;
Owner.FMsgData.Size := 0;
Owner.FMsgType := MsgItem.MsgType;
Owner.FMsgData.CopyFrom(MsgItem.Stream, MsgItem.Stream.Size);
finally
// We are responsible for freeing the message from the queue.
MsgItem.Free;
end;
end;
function TWinMsgServerComm.GetInstanceID: String;
begin
Result:=IntToStr(HInstance);
end;
{ ---------------------------------------------------------------------
TWinMsgClientComm
---------------------------------------------------------------------}
Type
TWinMsgClientComm = Class(TIPCClientComm)
Private
FWindowName: String;
FHWND : HWND;
function FindServerWindow: HWND;
function FindServerWindow(const aWindowName: WideString): 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;
function TWinMsgClientComm.FindServerWindow: HWND;
begin
Result := FindServerWindow(WideString(FWindowName));
end;
function TWinMsgClientComm.FindServerWindow(const aWindowName: WideString): HWND;
begin
Result := FindWindowW(PWideChar(MsgWndClassName), PWideChar(aWindowName));
end;
procedure TWinMsgClientComm.Connect;
begin
FHWND:=FindServerWindow;
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.dwData:=MsgType;
CDS.lpData:=Data.Memory;
CDS.cbData:=Data.Size;
Windows.SendMessage(FHWND,WM_COPYDATA,0,PtrInt(@CDS));
finally
FreeAndNil(FMemStr);
end;
end;
function TWinMsgClientComm.ServerRunning: Boolean;
begin
Result:=FindServerWindow<>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;

292
packages/fcl-process/src/wince/simpleipc.inc
View File

@ -1,292 +0,0 @@
{
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.Size:=0;
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: WideString;
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 : WideString 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;