paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-11 15:36:31 +02:00
Code Issues Packages Projects Releases Wiki Activity

add cross-platform process termination and pipe event handlers

Browse Source 
git-svn-id: trunk@8256 -
This commit is contained in:
micha 2005-12-06 13:41:28 +00:00
parent a868189f89
commit 003833b777
14 changed files with 411 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
lcl/alllclunits.pp
View File

@ -42,7 +42,7 @@ uses
InterfaceBase,
IntfGraphics,
// components and functions
LCLClasses,
LCLClasses, AsyncProcess,
StdActns, Buttons, Extctrls, Calendar, Clipbrd, Forms, LCLIntf, Spin,
Comctrls, Graphics, StdCtrls, Arrow, Controls, ImgList, Menus, Toolwin,
Dialogs, Messages, Clistbox, ActnList, Grids, MaskEdit,

18
lcl/include/intfbaselcl.inc
View File

@ -31,6 +31,16 @@ procedure TWidgetSet.AddEventHandler(AHandle: THandle; AFlags: dword;
begin
end;
procedure TWidgetSet.AddProcessEventHandler(AHandle: THandle;
AEventHandler: TChildExitEvent; AData: PtrInt);
begin
end;
procedure TWidgetSet.AddPipeEventHandler(AHandle: THandle;
AEventHandler: TPipeEvent; AData: PtrInt);
begin
end;
procedure TWidgetSet.AttachMenuToWindow(AMenuObject: TComponent);
begin
end;
@ -553,6 +563,14 @@ procedure TWidgetSet.RemoveEventHandler(AHandle: THandle);
begin
end;
procedure TWidgetSet.RemoveProcessEventHandler(AHandle: THandle);
begin
end;
procedure TWidgetSet.RemovePipeEventHandler(AHandle: THandle);
begin
end;
function TWidgetSet.ReleaseDesignerDC(hWnd: HWND; DC: HDC): Integer;
begin
Result := ReleaseDC(hWnd, DC);

20
lcl/include/lclintf.inc
View File

@ -39,6 +39,16 @@ begin
WidgetSet.AddEventHandler(AHandle, AFlags, AEventHandler, AData);
end;
procedure AddPipeEventHandler(AHandle: THandle; AEventHandler: TPipeEvent; AData: PtrInt);
begin
WidgetSet.AddPipeEventHandler(AHandle, AEventHandler, AData);
end;
procedure AddProcessEventHandler(AHandle: THandle; AEventHandler: TChildExitEvent; AData: PtrInt);
begin
WidgetSet.AddProcessEventHandler(AHandle, AEventHandler, AData);
end;
procedure AttachMenuToWindow(AMenuObject: TComponent);
begin
WidgetSet.AttachMenuToWindow(AMenuObject);
@ -386,6 +396,16 @@ begin
WidgetSet.RemoveEventHandler(AHandle);
end;
procedure RemoveProcessEventHandler(AHandle: THandle);
begin
WidgetSet.RemoveProcessEventHandler(AHandle);
end;
procedure RemovePipeEventHandler(AHandle: THandle);
begin
WidgetSet.RemovePipeEventHandler(AHandle);
end;
function ReplaceBitmapMask(var Image, Mask: HBitmap; NewMask: HBitmap): boolean;
// for Delphi compatibility a TBitmap has a Handle and a MaskHandle.
// Some interfaces have only a combined Handle. To replace the mask use this

4
lcl/include/lclintfh.inc
View File

@ -38,6 +38,8 @@
//##apiwiz##sps## // Do not remove
procedure AddEventHandler(AHandle: THandle; AFlags: dword; AEventHandler: TWaitHandleEvent; AData: PtrInt); {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
procedure AddProcessEventHandler(AHandle: THandle; AEventHandler: TChildExitEvent; AData: PtrInt); {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
procedure AddPipeEventHandler(AHandle: THandle; AEventHandler: TPipeEvent; AData: PtrInt); {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
procedure AttachMenuToWindow(AMenuObject: TComponent); {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
procedure CallDefaultWndHandler(Sender: TObject; var Message); {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
@ -106,6 +108,8 @@ function RadialPieWithAngles(DC: HDC; X,Y,Width,Height,Angle1,Angle2: Integer):
function RegroupMenuItem(hndMenu: HMENU; GroupIndex: integer): Boolean; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
function ReleaseDesignerDC(hWnd: HWND; DC: HDC): Integer; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
procedure RemoveEventHandler(AHandle: THandle); {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
procedure RemoveProcessEventHandler(AHandle: THandle); {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
procedure RemovePipeEventHandler(AHandle: THandle); {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
function ReplaceBitmapMask(var Image, Mask: HBitmap; NewMask: HBitmap): boolean; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
function RequestInput(const InputCaption, InputPrompt : String; MaskInput : Boolean; var Value : String) : Boolean; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}

6
lcl/interfacebase.pp
View File

@ -37,8 +37,14 @@ uses
GraphType, GraphMath;
type
TChildExitReason = (cerExit, cerSignal);
TPipeReason = (prDataAvailable, prBroken, prCanWrite);
TPipeReasons = set of TPipeReason;
TApplicationMainLoop = procedure of object;
TWaitHandleEvent = procedure(AData: PtrInt; AFlags: dword) of object;
TChildExitEvent = procedure(AData: PtrInt; AReason: TChildExitReason; AInfo: dword) of object;
TPipeEvent = procedure(AData: PtrInt; AReasons: TPipeReasons) of object;
{ TWidgetSet }

12
lcl/interfaces/gtk/gtkint.pp
View File

@ -77,7 +77,7 @@ uses
{$ENDIF}
// Target OS specific
{$IFDEF UNIX}
x, xlib,
x, xlib, ctypes, baseunix, unix,
{$ENDIF}
// LCL
ExtDlgs, Dialogs, Controls, Forms, LCLStrConsts, LMessages,
@ -114,6 +114,7 @@ type
FStockWhitePen: HPEN;
FWaitHandles: PWaitHandleEventHandler;
FChildSignalHandlers: PChildSignalEventHandler;
{$Ifdef GTK2}
FDefaultFontDesc: PPangoFontDescription;
@ -129,6 +130,15 @@ type
procedure InitStockItems; virtual;
procedure FreeStockItems; virtual;
procedure PassCmdLineOptions; override;
{$ifdef UNIX}
procedure InitSynchronizeSupport;
procedure ProcessChildSignal;
procedure PrepareSynchronize(AObject: TObject);
{$endif}
procedure HandlePipeEvent(AData: PtrInt; AFlags: dword);
function RemoveEventHandlerData(AHandle: THandle): PtrInt;
// styles
procedure FreeAllStyles; virtual;

89
lcl/interfaces/gtk/gtklclintf.inc
View File

@ -57,11 +57,12 @@ begin
FWaitHandles := lEventHandler;
end;
procedure TGtkWidgetSet.RemoveEventHandler(AHandle: THandle);
function TGtkWidgetSet.RemoveEventHandlerData(AHandle: THandle): PtrInt;
var
lEventHandler: PWaitHandleEventHandler;
lPrevEventHandler: PPWaitHandleEventHandler;
begin
Result := 0;
lPrevEventHandler := @FWaitHandles;
while lPrevEventHandler^ <> nil do
begin
@ -70,6 +71,7 @@ begin
begin
g_source_remove(lEventHandler^.GSourceID);
lPrevEventHandler^ := lEventHandler^.NextHandler;
Result := lEventHandler^.UserData;
Dispose(lEventHandler);
exit;
end;
@ -77,6 +79,91 @@ begin
end;
end;
procedure TGtkWidgetSet.RemoveEventHandler(AHandle: THandle);
begin
RemoveEventHandlerData(AHandle);
end;
type
PPipeEventInfo = ^TPipeEventInfo;
TPipeEventInfo = record
Handle: THandle;
UserData: PtrInt;
OnEvent: TPipeEvent;
end;
procedure TGtkWidgetSet.AddPipeEventHandler(AHandle: THandle;
AEventHandler: TPipeEvent; AData: PtrInt);
var
lPipeEventInfo: PPipeEventInfo;
begin
if AEventHandler = nil then exit;
New(lPipeEventInfo);
lPipeEventInfo^.Handle := AHandle;
lPipeEventInfo^.UserData := AData;
lPipeEventInfo^.OnEvent := AEventHandler;
AddEventHandler(AHandle, G_IO_IN or G_IO_HUP or G_IO_OUT,
@HandlePipeEvent, PtrInt(lPipeEventInfo));
end;
procedure TGtkWidgetSet.HandlePipeEvent(AData: PtrInt; AFlags: dword);
var
lPipeEventInfo: PPipeEventInfo absolute AData;
lReasons: TPipeReasons;
begin
lReasons := [];
if AFlags and G_IO_IN = G_IO_IN then
Include(lReasons, prDataAvailable);
if AFlags and G_IO_OUT = G_IO_OUT then
Include(lReasons, prCanWrite);
if AFlags and G_IO_HUP = G_IO_HUP then
Include(lReasons, prBroken);
lPipeEventInfo^.OnEvent(lPipeEventInfo^.UserData, lReasons);
end;
procedure TGtkWidgetSet.RemovePipeEventHandler(AHandle: THandle);
var
lPipeEventInfo: PPipeEventInfo;
begin
lPipeEventInfo := PPipeEventInfo(RemoveEventHandlerData(AHandle));
if lPipeEventInfo <> nil then
Dispose(lPipeEventInfo);
end;
procedure TGtkWidgetSet.AddProcessEventHandler(AHandle: THandle;
AEventHandler: TChildExitEvent; AData: PtrInt);
var
lHandler: PChildSignalEventHandler;
begin
if AEventHandler = nil then exit;
New(lHandler);
lHandler^.PID := TPid(AHandle);
lHandler^.UserData := AData;
lHandler^.OnEvent := AEventHandler;
lHandler^.NextHandler := FChildSignalHandlers;
FChildSignalHandlers := lHandler;
end;
procedure TGtkWidgetSet.RemoveProcessEventHandler(AHandle: THandle);
var
lHandler: PChildSignalEventHandler;
lPrevHandler: PPChildSignalEventHandler;
begin
lPrevHandler := @FChildSignalHandlers;
while lPrevHandler^ <> nil do
begin
lHandler := lPrevHandler^;
if lHandler^.PID = TPid(AHandle) then
begin
lPrevHandler^ := lHandler^.NextHandler;
Dispose(lHandler);
exit;
end;
lPrevHandler := @lHandler^.NextHandler;
end;
end;
{------------------------------------------------------------------------------
function TGtkWidgetSet.DrawSplitter(DC: HDC; const ARect: TRect;
Horizontal: boolean): Integer;

6
lcl/interfaces/gtk/gtklclintfh.inc
View File

@ -31,6 +31,10 @@
//##apiwiz##sps## // Do not remove
procedure AddEventHandler(AHandle: THandle; AFlags: dword;
AEventHandler: TWaitHandleEvent; AData: PtrInt); override;
procedure AddPipeEventHandler(AHandle: THandle;
AEventHandler: TPipeEvent; AData: PtrInt); override;
procedure AddProcessEventHandler(AHandle: THandle;
AEventHandler: TChildExitEvent; AData: PtrInt); override;
function DrawSplitter(DC: HDC; const ARect: TRect; Horizontal: boolean): boolean; override;
function ExtUTF8Out(DC: HDC; X, Y: Integer; Options: Longint; Rect: PRect;
@ -47,6 +51,8 @@ function GetListBoxItemRect(ListBox: TComponent; Index: integer; var ARect: TRec
function IntfSendsUTF8KeyPress: boolean; override;
procedure RemoveEventHandler(AHandle: THandle); override;
procedure RemovePipeEventHandler(AHandle: THandle); override;
procedure RemoveProcessEventHandler(AHandle: THandle); override;
function ReplaceBitmapMask(var Image, Mask: HBitmap; NewMask: HBitmap): boolean; override;
//##apiwiz##eps## // Do not remove, no wizard declaration after this line

112
lcl/interfaces/gtk/gtkobject.inc
View File

@ -129,6 +129,31 @@ begin
end;
{$ifdef UNIX}
// TThread.Synchronize support
var
threadsync_pipein, threadsync_pipeout: cint;
threadsync_giochannel: pgiochannel;
childsig_pending: boolean;
procedure ChildEventHandler(sig: longint; siginfo: psiginfo; sigcontext: psigcontext); cdecl;
begin
childsig_pending := true;
WakeMainThread(nil);
end;
procedure InstallSignalHandler;
var
child_action: sigactionrec;
begin
child_action.sa_handler := @ChildEventHandler;
fpsigemptyset(child_action.sa_mask);
child_action.sa_flags := 0;
fpsigaction(SIGCHLD, @child_action, nil);
end;
{$endif}
{------------------------------------------------------------------------------
Method: TGtkWidgetSet.Create
@ -206,6 +231,11 @@ begin
ClipboardTypeAtoms[ctSecondarySelection]:=GDK_SELECTION_SECONDARY;
ClipboardTypeAtoms[ctClipboard]:=gdk_atom_intern('CLIPBOARD',GdkFalse);
InitSynchronizeSupport;
{$ifdef UNIX}
InstallSignalHandler;
{$endif}
GTKWidgetSet := Self;
end;
@ -481,10 +511,92 @@ begin
g_log_remove_handler(nil, FLogHandlerID);
GTKWidgetSet := nil;
WakeMainThread := nil;
inherited Destroy;
end;
{$ifdef UNIX}
procedure TGtkWidgetSet.PrepareSynchronize(AObject: TObject);
begin
// wake up GUI thread by send a byte through the threadsync pipe
fpwrite(threadsync_pipeout, ' ', 1);
end;
procedure TGtkWidgetSet.ProcessChildSignal;
var
pid: tpid;
reason: TChildExitReason;
status: integer;
info: dword;
handler: PChildSignalEventHandler;
begin
repeat
pid := fpwaitpid(-1, status, WNOHANG);
if pid <= 0 then break;
if wifexited(status) then
begin
reason := cerExit;
info := wexitstatus(status);
end else
if wifsignaled(status) then
begin
reason := cerSignal;
info := wtermsig(status);
end else
continue;
handler := FChildSignalHandlers;
while handler <> nil do
begin
if handler^.pid = pid then
begin
handler^.OnEvent(handler^.UserData, reason, info);
break;
end;
handler := handler^.NextHandler;
end;
until false;
end;
function threadsync_iocallback(source: PGIOChannel; condition: TGIOCondition;
data: gpointer): gboolean; cdecl;
var
thrashspace: char;
begin
// read the sent byte
fpread(threadsync_pipein, thrashspace, 1);
Result := true;
// one of children signaled ?
if childsig_pending then
begin
childsig_pending := false;
TGtkWidgetSet(data).ProcessChildSignal;
end;
// execute the to-be synchronized method
CheckSynchronize;
end;
procedure TGtkWidgetSet.InitSynchronizeSupport;
begin
{ TThread.Synchronize ``glue'' }
WakeMainThread := @PrepareSynchronize;
assignpipe(threadsync_pipein, threadsync_pipeout);
threadsync_giochannel := g_io_channel_unix_new(threadsync_pipein);
g_io_add_watch(threadsync_giochannel, G_IO_IN, @threadsync_iocallback, nil);
end;
{$else}
{$message warn TThread.Synchronize will not work on Gtk/Win32 }
procedure InitSynchronizeSupport;
begin
end;
{$endif}
{------------------------------------------------------------------------------
Method: TGtkWidgetSet.SetWindowSizeAndPosition
Params: Widget: PGtkWidget; AWinControl: TWinControl

50
lcl/interfaces/gtk/gtkproc.pp
View File

@ -69,6 +69,18 @@ type
NextHandler: PWaitHandleEventHandler;
end;
{$ifdef UNIX}
PPChildSignalEventHandler = ^PChildSignalEventHandler;
PChildSignalEventHandler = ^TChildSignalEventHandler;
TChildSignalEventHandler = record
PID: TPid;
UserData: PtrInt;
OnEvent: TChildExitEvent;
NextHandler: PChildSignalEventHandler;
end;
{$endif}
{$IFDEF gtk2}
const
gdkdll = gdklib;
@ -991,39 +1003,9 @@ end;
{$I gtkproc.inc}
{$I gtkcallback.inc}
// TThread.Synchronize support
var
threadsync_pipein, threadsync_pipeout: cint;
threadsync_giochannel: pgiochannel;
type
TSynchronizeGlue = class(TObject)
public
procedure PrepareSynchronize(AObject: TObject);
end;
procedure TSynchronizeGlue.PrepareSynchronize(AObject: TObject);
begin
// wake up GUI thread by send a byte through the threadsync pipe
fpwrite(threadsync_pipeout, ' ', 1);
end;
function threadsync_iocallback(source: PGIOChannel; condition: TGIOCondition;
data: gpointer): gboolean; cdecl;
var
thrashspace: char;
begin
// read the sent byte
fpread(threadsync_pipein, thrashspace, 1);
// execute the to-be synchronized method
CheckSynchronize;
Result := true;
end;
procedure InitGTKProc;
var
lgs: TLazGtkStyle;
needInstancePtr: TSynchronizeGlue;
begin
FillChar(MCharToVK, SizeOf(MCharToVK), $FF);
@ -1039,19 +1021,11 @@ begin
for lgs:=Low(TLazGtkStyle) to High(TLazGtkStyle) do
StandardStyles[lgs]:=nil;
{ TThread.Synchronize ``glue'' }
WakeMainThread := @needInstancePtr.PrepareSynchronize;
assignpipe(threadsync_pipein, threadsync_pipeout);
threadsync_giochannel := g_io_channel_unix_new(threadsync_pipein);
g_io_add_watch(threadsync_giochannel, G_IO_IN, @threadsync_iocallback, nil);
end;
procedure DoneGTKProc;
begin
DoneKeyboardTables;
WakeMainThread := nil;
end;
{$IFDEF GTK1}

15
lcl/interfaces/win32/win32int.pp
View File

@ -106,6 +106,15 @@ Type
OnEvent: TWaitHandleEvent;
end;
PPPipeEventHandler = ^PPipeEventHandler;
PPipeEventHandler = ^TPipeEventHandler;
TPipeEventHandler = record
Handle: THandle;
UserData: PtrInt;
OnEvent: TPipeEvent;
NextHandler: PPipeEventHandler;
end;
{ Win32 interface-object class }
TWin32WidgetSet = Class(TWidgetSet)
Private
@ -130,6 +139,7 @@ Type
FWaitHandleCount: dword;
FWaitHandles: array of HANDLE;
FWaitHandlers: array of TWaitHandler;
FWaitPipeHandlers: PPipeEventHandler;
FThemesActive: boolean;
FThemeLibrary: HMODULE;
@ -145,6 +155,11 @@ Type
procedure FillRawImageDescription(const BitmapInfo: Windows.TBitmap;
Desc: PRawImageDescription);
{ event handler helper functions }
procedure HandleProcessEvent(AData: PtrInt; AFlags: dword);
function RemoveEventHandlerData(AHandle: THandle): PtrInt;
procedure CheckPipeEvents;
Function WinRegister: Boolean;
Procedure NormalizeIconName(Var IconName: String);
Procedure NormalizeIconName(Var IconName: PChar);

82
lcl/interfaces/win32/win32lclintf.inc
View File

@ -47,13 +47,15 @@ begin
Inc(FWaitHandleCount);
end;
procedure TWin32WidgetSet.RemoveEventHandler(AHandle: THandle);
function TWin32WidgetSet.RemoveEventHandlerData(AHandle: THandle): PtrInt;
var
I: integer;
begin
Result := 0;
for I := 0 to FWaitHandleCount - 1 do
if FWaitHandles[I] = AHandle then
begin
Result := FWaitHandlers[I].UserData;
// swap with last one
if FWaitHandleCount >= 2 then
begin
@ -65,6 +67,84 @@ begin
end;
end;
procedure TWin32WidgetSet.RemoveEventHandler(AHandle: THandle);
begin
RemoveEventHandlerData(AHandle);
end;
procedure TWin32WidgetSet.AddPipeEventHandler(AHandle: THandle;
AEventHandler: TPipeEvent; AData: PtrInt);
var
lHandler: PPipeEventHandler;
begin
if AEventHandler = nil then exit;
New(lHandler);
lHandler^.Handle := AHandle;
lHandler^.UserData := AData;
lHandler^.OnEvent := AEventHandler;
lHandler^.NextHandler := FWaitPipeHandlers;
FWaitPipeHandlers := lHandler;
end;
procedure TWin32WidgetSet.RemovePipeEventHandler(AHandle: THandle);
var
lPrevHandler: PPPipeEventHandler;
lHandler: PPipeEventHandler;
begin
lPrevHandler := @FWaitPipeHandlers;
while lPrevHandler^ <> nil do
begin
lHandler := lPrevHandler^;
if lHandler^.Handle = AHandle then
begin
lPrevHandler^ := lHandler^.NextHandler;
Dispose(lHandler);
exit;
end;
lPrevHandler := @lHandler^.NextHandler;
end;
end;
type
PProcessEvent = ^TProcessEvent;
TProcessEvent = record
Handle: THandle;
UserData: PtrInt;
OnEvent: TChildExitEvent;
end;
procedure TWin32WidgetSet.AddProcessEventHandler(AHandle: THandle;
AEventHandler: TChildExitEvent; AData: PtrInt);
var
lProcessEvent: PProcessEvent;
begin
if AEventHandler = nil then exit;
New(lProcessEvent);
lProcessEvent^.Handle := AHandle;
lProcessEvent^.UserData := AData;
lProcessEvent^.OnEvent := AEventHandler;
AddEventHandler(AHandle, 0, @HandleProcessEvent, PtrInt(lProcessEvent));
end;
procedure TWin32WidgetSet.HandleProcessEvent(AData: PtrInt; AFlags: dword);
var
lProcessEvent: PProcessEvent absolute AData;
exitcode: dword;
begin
if not Windows.GetExitCodeProcess(lProcessEvent^.Handle, exitcode) then
exitcode := 0;
lProcessEvent^.OnEvent(lProcessEvent^.UserData, cerExit, exitcode);
end;
procedure TWin32WidgetSet.RemoveProcessEventHandler(AHandle: THandle);
var
lProcessEvent: PProcessEvent;
begin
lProcessEvent := PProcessEvent(RemoveEventHandlerData(AHandle));
if lProcessEvent <> nil then
Dispose(lProcessEvent);
end;
procedure TWin32WidgetSet.DrawArrow(Arrow: TComponent; Canvas: TPersistent);
const
{ up, down, left, right }

8
lcl/interfaces/win32/win32lclintfh.inc
View File

@ -31,7 +31,11 @@
procedure AddEventHandler(AHandle: THandle; AFlags: dword;
AEventHandler: TWaitHandleEvent; AData: PtrInt); override;
procedure AddPipeEventHandler(AHandle: THandle;
AEventHandler: TPipeEvent; AData: PtrInt); override;
procedure AddProcessEventHandler(AHandle: THandle;
AEventHandler: TChildExitEvent; AData: PtrInt); override;
procedure DrawArrow(Arrow: TComponent; Canvas: TPersistent); override;
function GetAcceleratorString(const AVKey: Byte; const AShiftState: TShiftState): String; override;
@ -39,6 +43,8 @@ function GetControlConstraints(Constraints: TObject): boolean; override;
function GetListBoxIndexAtY(ListBox: TComponent; y: integer): integer; override;
procedure RemoveEventHandler(AHandle: THandle); override;
procedure RemovePipeEventHandler(AHandle: THandle); override;
procedure RemoveProcessEventHandler(AHandle: THandle); override;
//##apiwiz##eps## // Do not remove, no wizard declaration after this line

32
lcl/interfaces/win32/win32object.inc
View File

@ -314,6 +314,24 @@ Begin
End;
End;
procedure TWin32WidgetSet.CheckPipeEvents;
var
lHandler: PPipeEventHandler;
lBytesAvail: dword;
begin
lHandler := FWaitPipeHandlers;
while lHandler <> nil do
begin
if PeekNamedPipe(lHandler^.Handle, nil, 0, nil, @lBytesAvail, nil) then
begin
if lBytesAvail <> 0 then
lHandler^.OnEvent(lHandler^.UserData, [prDataAvailable]);
end else
lHandler^.OnEvent(lHandler^.UserData, [prBroken]);
lHandler := lHandler^.NextHandler;
end;
end;
{------------------------------------------------------------------------------
Method: TWin32WidgetSet.AppWaitMessage
Params: None
@ -325,18 +343,28 @@ procedure TWin32WidgetSet.AppWaitMessage;
var
done: boolean;
retVal, index: dword;
timeout: dword;
begin
RedrawMenus;
Assert(False, 'Trace:TWin32WidgetSet.WaitMessage - Start');
done := false;
repeat
if FWaitPipeHandlers <> nil then
timeout := 100
else
timeout := INFINITE;
retVal := Windows.MsgWaitForMultipleObjects(FWaitHandleCount,
FWaitHandles[0], false, INFINITE, QS_ALLINPUT);
FWaitHandles[0], false, timeout, QS_ALLINPUT);
if (WAIT_OBJECT_0 <= retVal) and (retVal < WAIT_OBJECT_0 + FWaitHandleCount) then
begin
index := retVal-WAIT_OBJECT_0;
FWaitHandlers[index].OnEvent(FWaitHandlers[index].UserData, 0);
end else if retVal = WAIT_OBJECT_0 + FWaitHandleCount then
end else
if retVal = WAIT_TIMEOUT then
begin
CheckPipeEvents;
end else
if retVal = WAIT_OBJECT_0 + FWaitHandleCount then
done := true;
until done;
Assert(False,'Trace:Leave wait message');