diff --git a/lcl/alllclunits.pp b/lcl/alllclunits.pp index bd5f2304c1..f9fa7d0b93 100644 --- a/lcl/alllclunits.pp +++ b/lcl/alllclunits.pp @@ -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, diff --git a/lcl/include/intfbaselcl.inc b/lcl/include/intfbaselcl.inc index bb7455e802..b65921b845 100644 --- a/lcl/include/intfbaselcl.inc +++ b/lcl/include/intfbaselcl.inc @@ -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); diff --git a/lcl/include/lclintf.inc b/lcl/include/lclintf.inc index e605cd7d2a..45af12712f 100644 --- a/lcl/include/lclintf.inc +++ b/lcl/include/lclintf.inc @@ -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 diff --git a/lcl/include/lclintfh.inc b/lcl/include/lclintfh.inc index ac6fde59bf..439a855e11 100644 --- a/lcl/include/lclintfh.inc +++ b/lcl/include/lclintfh.inc @@ -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} diff --git a/lcl/interfacebase.pp b/lcl/interfacebase.pp index 23da855b42..9f15033ec0 100644 --- a/lcl/interfacebase.pp +++ b/lcl/interfacebase.pp @@ -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 } diff --git a/lcl/interfaces/gtk/gtkint.pp b/lcl/interfaces/gtk/gtkint.pp index 6bc983f5d0..eb81ee98ae 100644 --- a/lcl/interfaces/gtk/gtkint.pp +++ b/lcl/interfaces/gtk/gtkint.pp @@ -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; diff --git a/lcl/interfaces/gtk/gtklclintf.inc b/lcl/interfaces/gtk/gtklclintf.inc index a472ae4900..53592be3ce 100644 --- a/lcl/interfaces/gtk/gtklclintf.inc +++ b/lcl/interfaces/gtk/gtklclintf.inc @@ -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; diff --git a/lcl/interfaces/gtk/gtklclintfh.inc b/lcl/interfaces/gtk/gtklclintfh.inc index 36e8350cfc..55c40a117b 100644 --- a/lcl/interfaces/gtk/gtklclintfh.inc +++ b/lcl/interfaces/gtk/gtklclintfh.inc @@ -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 diff --git a/lcl/interfaces/gtk/gtkobject.inc b/lcl/interfaces/gtk/gtkobject.inc index c3373c90e5..33e80faa81 100644 --- a/lcl/interfaces/gtk/gtkobject.inc +++ b/lcl/interfaces/gtk/gtkobject.inc @@ -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 diff --git a/lcl/interfaces/gtk/gtkproc.pp b/lcl/interfaces/gtk/gtkproc.pp index 66764f6abe..0ea750a9fa 100644 --- a/lcl/interfaces/gtk/gtkproc.pp +++ b/lcl/interfaces/gtk/gtkproc.pp @@ -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} diff --git a/lcl/interfaces/win32/win32int.pp b/lcl/interfaces/win32/win32int.pp index f9e8551ab9..c1620bb3ff 100644 --- a/lcl/interfaces/win32/win32int.pp +++ b/lcl/interfaces/win32/win32int.pp @@ -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); diff --git a/lcl/interfaces/win32/win32lclintf.inc b/lcl/interfaces/win32/win32lclintf.inc index ec94c8bcf7..fa5ee33c05 100644 --- a/lcl/interfaces/win32/win32lclintf.inc +++ b/lcl/interfaces/win32/win32lclintf.inc @@ -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 } diff --git a/lcl/interfaces/win32/win32lclintfh.inc b/lcl/interfaces/win32/win32lclintfh.inc index 2d8d91296a..a3064dfe89 100644 --- a/lcl/interfaces/win32/win32lclintfh.inc +++ b/lcl/interfaces/win32/win32lclintfh.inc @@ -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 diff --git a/lcl/interfaces/win32/win32object.inc b/lcl/interfaces/win32/win32object.inc index 9fe9fa107f..8320791a16 100644 --- a/lcl/interfaces/win32/win32object.inc +++ b/lcl/interfaces/win32/win32object.inc @@ -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');