I've been beating my head for over a day now, going through tons of resources trying to figure out how to receive the WM_POWERBROADCAST Windows message from within a thread.
Currently, I am using AllocateHWnd(WndMethod) inside of a stand-alone component. When I create an instance of said component in a standard VCL Forms Application, everything works fine, and I receive the WM_POWERBROADCAST message every time, as needed.
However, when I create an instance of the very same component from within a TThread, I'm no longer receiving this particular Windows message. I'm receiving all kinds of other messages, just not this particular one.
In my searching for a solution, I've found many resources related to how a Windows Service requires some extra work in order to receive this message. But I'm not using a service, at least not yet. I've also found a couple people mention that a thread needs to have a message loop in order to receive this message, and I've implemented a thread from another answer here, but again, I never receive this particular message.
Below is the complete component how I'm receiving this message, which again works perfectly if this is in a VCL application's main thread. I'm guessing the main thread needs to receive this message and forward it into the thread.
How do I make this receive the WM_POWERBROADCAST message when inside of a TThread?
unit JD.Power.Monitor;
(*
JD Power Monitor
by Jerry Dodge
Purpose: To monitor the current state of power on the computer, and trigger
events when different power related changes occur.
Component: TPowerMonitor
- Create an instance of TPowerMonitor component
- Choose desired power settings to get notified of using Settings property
- Implement event handlers for those events you wish to monitor
- Component automatically takes care of the rest of the work
*)
interface
uses
System.Classes, System.SysUtils, System.Generics.Collections,
Winapi.ActiveX, Winapi.Windows, Winapi.Messages;
type
TPowerSetting = (psACDCPowerSource, psBatteryPercentage,
psConsoleDisplayState, psGlobalUserPresence, psIdleBackgroundTask,
psMonitorPower, psPowerSaving, psPowerSchemePersonality,
psSessionDisplayStatus, psSessionUserPresence, psSystemAwayMode);
TPowerSettings = set of TPowerSetting;
TPowerSource = (poAC, poDC, poHot);
TPowerDisplayState = (pdOff, pdOn, pdDimmed);
TPowerUserPresence = (puPresent = 0, puInactive = 2);
TPowerSavingStatus = (psSaverOff, psSaverOn);
TPowerAwayMode = (paExiting, paEntering);
TPowerPersonality = (ppHighPerformance, ppPowerSaver, ppAutomatic);
TPowerMonitorSettingHandles = array[TPowerSetting] of HPOWERNOTIFY;
TPowerQueryEndSessionEvent = procedure(Sender: TObject; var EndSession: Boolean) of object;
TPowerEndSessionEvent = procedure(Sender: TObject) of object;
TPowerSettingSourceChangeEvent = procedure(Sender: TObject;
const Src: TPowerSource) of object;
TPowerSettingBatteryPercentEvent = procedure(Sender: TObject;
const Perc: Single) of object;
TPowerSettingDisplayStateEvent = procedure(Sender: TObject;
const State: TPowerDisplayState) of object;
TPowerSettingUserPresenceEvent = procedure(Sender: TObject;
const Presence: TPowerUserPresence) of object;
TPowerSettingSavingEvent = procedure(Sender: TObject;
const Status: TPowerSavingStatus) of object;
TPowerAwayModeEvent = procedure(Sender: TObject;
const Mode: TPowerAwayMode) of object;
TPowerPersonalityEvent = procedure(Sender: TObject;
const Personality: TPowerPersonality) of object;
TPowerMonitor = class(TComponent)
private
FHandle: HWND;
FSettingHandles: TPowerMonitorSettingHandles;
FSettings: TPowerSettings;
FBatteryPresent: Boolean;
FOnQueryEndSession: TPowerQueryEndSessionEvent;
FOnEndSession: TPowerEndSessionEvent;
FOnPowerStatusChange: TNotifyEvent;
FOnResumeAutomatic: TNotifyEvent;
FOnResumeSuspend: TNotifyEvent;
FOnSuspend: TNotifyEvent;
FOnSourceChange: TPowerSettingSourceChangeEvent;
FOnBatteryPercent: TPowerSettingBatteryPercentEvent;
FOnConsoleDisplayState: TPowerSettingDisplayStateEvent;
FOnGlobalUserPresence: TPowerSettingUserPresenceEvent;
FOnIdleBackgroundTask: TNotifyEvent;
FOnMonitorPower: TPowerSettingDisplayStateEvent;
FOnPowerSavingStatus: TPowerSettingSavingEvent;
FOnSessionDisplayState: TPowerSettingDisplayStateEvent;
FOnSessionUserPresence: TPowerSettingUserPresenceEvent;
FOnAwayMode: TPowerAwayModeEvent;
FOnPersonality: TPowerPersonalityEvent;
procedure UnregisterSettings;
procedure RegisterSettings;
procedure SetSettings(const Value: TPowerSettings);
protected
procedure HandlePowerSetting(const Val: PPowerBroadcastSetting);
procedure WndMethod(var Msg: TMessage);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Settings: TPowerSettings read FSettings write SetSettings;
property OnQueryEndSession: TPowerQueryEndSessionEvent
read FOnQueryEndSession write FOnQueryEndSession;
property OnEndSession: TPowerEndSessionEvent
read FOnEndSession write FOnEndSession;
property OnPowerStatusChange: TNotifyEvent
read FOnPowerStatusChange write FOnPowerStatusChange;
property OnResumeAutomatic: TNotifyEvent
read FOnResumeAutomatic write FOnResumeAutomatic;
property OnResumeSuspend: TNotifyEvent
read FOnResumeSuspend write FOnResumeSuspend;
property OnSuspend: TNotifyEvent
read FOnSuspend write FOnSuspend;
property OnSourceChange: TPowerSettingSourceChangeEvent
read FOnSourceChange write FOnSourceChange;
property OnBatteryPercent: TPowerSettingBatteryPercentEvent
read FOnBatteryPercent write FOnBatteryPercent;
property OnConsoleDisplayState: TPowerSettingDisplayStateEvent
read FOnConsoleDisplayState write FOnConsoleDisplayState;
property OnGlobalUserPresence: TPowerSettingUserPresenceEvent
read FOnGlobalUserPresence write FOnGlobalUserPresence;
property OnIdleBackgroundTask: TNotifyEvent
read FOnIdleBackgroundTask write FOnIdleBackgroundTask;
property OnMonitorPower: TPowerSettingDisplayStateEvent
read FOnMonitorPower write FOnMonitorPower;
property OnPowerSavingStatus: TPowerSettingSavingEvent
read FOnPowerSavingStatus write FOnPowerSavingStatus;
property OnSessionDisplayState: TPowerSettingDisplayStateEvent
read FOnSessionDisplayState write FOnSessionDisplayState;
property OnSessionUserPresence: TPowerSettingUserPresenceEvent
read FOnSessionUserPresence write FOnSessionUserPresence;
property OnAwayMode: TPowerAwayModeEvent
read FOnAwayMode write FOnAwayMode;
property OnPersonality: TPowerPersonalityEvent
read FOnPersonality write FOnPersonality;
end;
implementation
{ TPowerMonitor }
constructor TPowerMonitor.Create(AOwner: TComponent);
begin
inherited;
FBatteryPresent:= False;
FHandle := AllocateHWnd(WndMethod);
end;
destructor TPowerMonitor.Destroy;
begin
UnregisterSettings;
DeallocateHWnd(FHandle);
inherited;
end;
procedure TPowerMonitor.SetSettings(const Value: TPowerSettings);
begin
UnregisterSettings;
FSettings := Value;
RegisterSettings;
end;
procedure TPowerMonitor.WndMethod(var Msg: TMessage);
var
Handled: Boolean;
begin
Handled := True;
case Msg.Msg of
WM_POWERBROADCAST: begin
//TODO: Why is this never received when inside of a thread?
case Msg.WParam of
PBT_APMPOWERSTATUSCHANGE: begin
//Power status has changed.
if Assigned(FOnPowerStatusChange) then
FOnPowerStatusChange(Self);
end;
PBT_APMRESUMEAUTOMATIC: begin
//Operation is resuming automatically from a low-power state.
//This message is sent every time the system resumes.
if Assigned(FOnResumeAutomatic) then
FOnResumeAutomatic(Self);
end;
PBT_APMRESUMESUSPEND: begin
//Operation is resuming from a low-power state. This message
//is sent after PBT_APMRESUMEAUTOMATIC if the resume is triggered
//by user input, such as pressing a key.
if Assigned(FOnResumeSuspend) then
FOnResumeSuspend(Self);
end;
PBT_APMSUSPEND: begin
//System is suspending operation.
if Assigned(FOnSuspend) then
FOnSuspend(Self);
end;
PBT_POWERSETTINGCHANGE: begin
//A power setting change event has been received.
HandlePowerSetting(PPowerBroadcastSetting(Msg.LParam));
end;
else begin
end;
end;
end
else Handled := False;
end;
if Handled then
Msg.Result := 0
else
Msg.Result := DefWindowProc(FHandle, Msg.Msg,
Msg.WParam, Msg.LParam);
end;
procedure TPowerMonitor.HandlePowerSetting(const Val: PPowerBroadcastSetting);
var
Pers: TPowerPersonality;
function ValAsDWORD: DWORD;
begin
Result:= DWORD(Val.Data[0]);
end;
function ValAsGUID: TGUID;
begin
Result:= StringToGUID('{00000000-0000-0000-0000-000000000000}'); //Default
if SizeOf(TGUID) = Val.DataLength then begin
Move(Val.Data, Result, Val.DataLength);
end;
end;
function IsVal(G: String): Boolean;
begin
Result:= Assigned(Val);
if Result then
Result:= IsEqualGUID(StringToGUID(G), Val.PowerSetting);
end;
function IsValGuid(G: String): Boolean;
begin
Result:= Assigned(Val);
if Result then
Result:= IsEqualGUID(StringToGUID(G), ValAsGUID);
end;
begin
if IsVal('{5d3e9a59-e9D5-4b00-a6bd-ff34ff516548}') then begin
//GUID_ACDC_POWER_SOURCE
if Assigned(FOnSourceChange) then
FOnSourceChange(Self, TPowerSource(ValAsDWORD));
end else
if IsVal('{a7ad8041-b45a-4cae-87a3-eecbb468a9e1}') then begin
//GUID_BATTERY_PERCENTAGE_REMAINING
//We assume that if we get this message, that there is a battery connected.
//Otherwise if this never occurs, then a battery is not present.
//TODO: How to handle if battery is detached and no longer present?
FBatteryPresent:= True;
if Assigned(FOnBatteryPercent) then
FOnBatteryPercent(Self, ValAsDWORD);
end else
if IsVal('{6fe69556-704a-47a0-8f24-c28d936fda47}') then begin
//GUID_CONSOLE_DISPLAY_STATE
if Assigned(FOnConsoleDisplayState) then
FOnConsoleDisplayState(Self, TPowerDisplayState(ValAsDWORD));
end else
if IsVal('{786E8A1D-B427-4344-9207-09E70BDCBEA9}') then begin
//GUID_GLOBAL_USER_PRESENCE
if Assigned(FOnGlobalUserPresence) then
FOnGlobalUserPresence(Self, TPowerUserPresence(ValAsDWORD));
end else
if IsVal('{515c31d8-f734-163d-a0fd-11a08c91e8f1}') then begin
//GUID_IDLE_BACKGROUND_TASK
if Assigned(FOnIdleBackgroundTask) then
FOnIdleBackgroundTask(Self);
end else
if IsVal('{02731015-4510-4526-99e6-e5a17ebd1aea}') then begin
//GUID_MONITOR_POWER_ON
if Assigned(FOnMonitorPower) then
FOnMonitorPower(Self, TPowerDisplayState(ValAsDWORD));
end else
if IsVal('{E00958C0-C213-4ACE-AC77-FECCED2EEEA5}') then begin
//GUID_POWER_SAVING_STATUS
if Assigned(FOnPowerSavingStatus) then
FOnPowerSavingStatus(Self, TPowerSavingStatus(ValAsDWORD));
end else
if IsVal('{245d8541-3943-4422-b025-13A784F679B7}') then begin
//GUID_POWERSCHEME_PERSONALITY
if IsValGuid('{8c5e7fda-e8bf-4a96-9a85-a6e23a8c635c}') then begin
Pers:= TPowerPersonality.ppHighPerformance;
end else
if IsValGuid('{a1841308-3541-4fab-bc81-f71556f20b4a}') then begin
Pers:= TPowerPersonality.ppPowerSaver;
end else
if IsValGuid('{381b4222-f694-41f0-9685-ff5bb260df2e}') then begin
Pers:= TPowerPersonality.ppAutomatic;
end else begin
//TODO: Handle unrecognized GUID
Pers:= TPowerPersonality.ppAutomatic;
end;
if Assigned(FOnPersonality) then
FOnPersonality(Self, Pers);
end else
if IsVal('{2B84C20E-AD23-4ddf-93DB-05FFBD7EFCA5}') then begin
//GUID_SESSION_DISPLAY_STATUS
if Assigned(FOnSessionDisplayState) then
FOnSessionDisplayState(Self, TPowerDisplayState(ValAsDWORD));
end else
if IsVal('{3C0F4548-C03F-4c4d-B9F2-237EDE686376}') then begin
//GUID_SESSION_USER_PRESENCE
if Assigned(FOnSessionUserPresence) then
FOnSessionUserPresence(Self, TPowerUserPresence(ValAsDWORD));
end else
if IsVal('{98a7f580-01f7-48aa-9c0f-44352c29e5C0}') then begin
//GUID_SYSTEM_AWAYMODE
if Assigned(FOnAwayMode) then
FOnAwayMode(Self, TPowerAwayMode(ValAsDWORD));
end else begin
//TODO: Handle Unrecognized GUID
end;
end;
function PowerSettingGUID(const Setting: TPowerSetting): TGUID;
begin
case Setting of
psACDCPowerSource: Result:= StringToGUID('{5d3e9a59-e9D5-4b00-a6bd-ff34ff516548}');
psBatteryPercentage: Result:= StringToGUID('{a7ad8041-b45a-4cae-87a3-eecbb468a9e1}');
psConsoleDisplayState: Result:= StringToGUID('{6fe69556-704a-47a0-8f24-c28d936fda47}');
psGlobalUserPresence: Result:= StringToGUID('{786E8A1D-B427-4344-9207-09E70BDCBEA9}');
psIdleBackgroundTask: Result:= StringToGUID('{515c31d8-f734-163d-a0fd-11a08c91e8f1}');
psMonitorPower: Result:= StringToGUID('{02731015-4510-4526-99e6-e5a17ebd1aea}');
psPowerSaving: Result:= StringToGUID('{E00958C0-C213-4ACE-AC77-FECCED2EEEA5}');
psPowerSchemePersonality: Result:= StringToGUID('{245d8541-3943-4422-b025-13A784F679B7}');
psSessionDisplayStatus: Result:= StringToGUID('{2B84C20E-AD23-4ddf-93DB-05FFBD7EFCA5}');
psSessionUserPresence: Result:= StringToGUID('{3C0F4548-C03F-4c4d-B9F2-237EDE686376}');
psSystemAwayMode: Result:= StringToGUID('{98a7f580-01f7-48aa-9c0f-44352c29e5C0}');
end;
end;
procedure TPowerMonitor.RegisterSettings;
var
V: TPowerSetting;
begin
for V := Low(TPowerSetting) to High(TPowerSetting) do begin
if V in FSettings then begin
FSettingHandles[V]:= RegisterPowerSettingNotification(FHandle,
PowerSettingGUID(V), 0);
end;
end;
end;
procedure TPowerMonitor.UnregisterSettings;
var
V: TPowerSetting;
begin
for V := Low(TPowerSetting) to High(TPowerSetting) do begin
if V in FSettings then begin
UnregisterPowerSettingNotification(FSettingHandles[V]);
end;
end;
end;
end.
Further, based on the other answer as mentioned, here's how I'm attempting to capture this message using only a thread, although I'm sure this is not actually what I need since WM_POWERBROADCAST is not a posted message:
unit JD.ThreadTest;
interface
uses
System.Classes, Winapi.Messages, Winapi.Windows;
type
TDataThread = class(TThread)
private
FTitle: String;
FWnd: HWND;
FWndClass: WNDCLASS;
procedure HandlePower(AMsg: TMsg);
protected
procedure Execute; override;
procedure DoTerminate; override;
public
constructor Create(const Title: String); reintroduce;
end;
implementation
constructor TDataThread.Create(const Title: String);
begin
inherited Create(True);
FTitle := Title;
with FWndClass do begin
Style := 0;
lpfnWndProc := #DefWindowProc;
cbClsExtra := 0;
cbWndExtra := 0;
hInstance := HInstance;
hIcon := 0;
hCursor := LoadCursor(0, IDC_ARROW);
hbrBackground := COLOR_WINDOW;
lpszMenuName := nil;
lpszClassName := PChar(Self.ClassName);
end;
end;
procedure TDataThread.Execute;
var
Msg: TMsg;
begin
if Winapi.Windows.RegisterClass(FWndClass) = 0 then Exit;
FWnd := CreateWindow(FWndClass.lpszClassName, PChar(FTitle), WS_DLGFRAME,
0, 0, 698, 517, 0, 0, HInstance, nil);
if FWnd = 0 then Exit;
while GetMessage(Msg, FWnd, 0, 0) = True do begin
if Terminated then Break;
case Msg.message of
WM_POWERBROADCAST: begin
HandlePower(Msg); //Never receives this message
end;
else begin
TranslateMessage(msg);
DispatchMessage(msg)
end;
end;
end;
end;
procedure TDataThread.HandlePower(AMsg: TMsg);
begin
end;
procedure TDataThread.DoTerminate;
begin
if FWnd <> 0 then DestroyWindow(FWnd);
Winapi.Windows.UnregisterClass(PChar(Self.ClassName), FWndClass.hInstance);
inherited;
end;
end.
PS: The end goal is to make this component re-usable, and to be using it inside of a thread, which will be spawned inside of a service.
EDIT
Just to show some perspective, here's a screenshot of my results, when I put my computer into sleep mode. The form on the left is my 100% working UI application, without any worker thread. It receives many messages through the WM_POWERBROADCAST message. The one on the right is where I attempt to capture this message inside of a thread - updated with the code below in Remy's answer.
Obviously the "Power Setting" specific messages are not received, because I haven't called RegisterPowerSettingNotification - but there are other cases when I should still receive this message regardless, such as PBT_APMSUSPEND.
unit JD.ThreadTest;
interface
uses
System.Classes, System.SysUtils, Winapi.Messages, Winapi.Windows;
type
TMessageEvent = procedure(Sender: TObject; Message: TMessage) of object;
TDataThread = class(TThread)
private
FTitle: String;
FWnd: HWND;
FWndClass: WNDCLASS;
FOnMessage: TMessageEvent;
FMsg: TMessage;
procedure HandleMessage(var Message: TMessage);
protected
procedure Execute; override;
procedure DoTerminate; override;
procedure DoOnMessage;
public
constructor Create(const Title: String); reintroduce;
property OnMessage: TMessageEvent read FOnMessage write FOnMessage;
end;
implementation
function DataThreadWndProc(Wnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
Thread: TDataThread;
Message: TMessage;
begin
if Msg = WM_NCCREATE then
begin
Thread := TDataThread(PCREATESTRUCT(lParam)^.lpCreateParams);
SetWindowLongPtr(Wnd, GWLP_USERDATA, LONG_PTR(Thread));
end else
Thread := TDataThread(GetWindowLongPtr(Wnd, GWLP_USERDATA));
if Thread <> nil then
begin
Message.Msg := Msg;
Message.WParam := wParam;
Message.LParam := lParam;
Message.Result := 0;
Thread.HandleMessage(Message);
Result := Message.Result;
end else
Result := DefWindowProc(Wnd, Msg, wParam, lParam);
end;
constructor TDataThread.Create(const Title: String);
begin
inherited Create(True);
FTitle := Title;
with FWndClass do
begin
Style := 0;
lpfnWndProc := #DataThreadWndProc;
cbClsExtra := 0;
cbWndExtra := 0;
hInstance := HInstance;
hIcon := 0;
hCursor := LoadCursor(0, IDC_ARROW);
hbrBackground := COLOR_WINDOW;
lpszMenuName := nil;
lpszClassName := 'TDataThread';
end;
end;
procedure TDataThread.Execute;
var
Msg: TMsg;
begin
if Winapi.Windows.RegisterClass(FWndClass) = 0 then Exit;
FWnd := CreateWindow(FWndClass.lpszClassName, PChar(FTitle), WS_DLGFRAME, 0, 0, 698, 517, 0, 0, HInstance, Self);
if FWnd = 0 then Exit;
while GetMessage(Msg, 0, 0, 0) do
begin
if Terminated then Exit;
TranslateMessage(msg);
DispatchMessage(msg);
end;
end;
procedure TDataThread.DoOnMessage;
begin
if Assigned(FOnMessage) then
FOnMessage(Self, FMsg);
end;
procedure TDataThread.DoTerminate;
begin
if FWnd <> 0 then DestroyWindow(FWnd);
Winapi.Windows.UnregisterClass(FWndClass.lpszClassName, HInstance);
inherited;
end;
procedure TDataThread.HandleMessage(var Message: TMessage);
begin
FMsg:= Message;
Synchronize(DoOnMessage);
case Message.Msg of
WM_POWERBROADCAST:
begin
end;
else
Message.Result := DefWindowProc(FWnd, Message.Msg, Message.WParam, Message.LParam);
end;
end;
end.
WM_POWERBROADCAST is not a posted message, so your message loop will never see it. You need a window procedure to receive that message. Your thread code is using DefWindowProc() directly as the window procedure. Change the call to RegisterClass() to register a custom procedure instead, that then calls DefWindowProc() for unhandled messages. GetMessage() will dispatch any sent message directly to the window procedure, and DispatchMessage() will dispatch any posted messages to the same window procedure.
unit JD.ThreadTest;
interface
uses
System.Classes, Winapi.Messages, Winapi.Windows;
type
TDataThread = class(TThread)
private
FTitle: String;
FWnd: HWND;
FWndClass: WNDCLASS;
procedure HandleMessage(var Message: TMessage);
protected
procedure Execute; override;
procedure DoTerminate; override;
public
constructor Create(const Title: String); reintroduce;
end;
implementation
function DataThreadWndProc(Wnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
Thread: TDataThread;
Message: TMessage;
begin
if Msg = WM_NCCREATE then
begin
Thread := TDataThread(PCREATESTRUCT(lParam)^.lpCreateParams);
SetWindowLongPtr(Wnd, GWLP_USERDATA, LONG_PTR(Thread));
end else
Thread := TDataThread(GetWindowLongPtr(Wnd, GWLP_USERDATA));
if Thread <> nil then
begin
Message.Msg := Msg;
Message.WParam := wParam;
Message.LParam := lParam;
Message.Result := 0;
Thread.HandleMessage(Message);
Result := Message.Result;
end else
Result := DefWindowProc(Wnd, Msg, wParam, lParam);
end;
constructor TDataThread.Create(const Title: String);
begin
inherited Create(True);
FTitle := Title;
with FWndClass do
begin
Style := 0;
lpfnWndProc := #DataThreadWndProc;
cbClsExtra := 0;
cbWndExtra := 0;
hInstance := HInstance;
hIcon := 0;
hCursor := LoadCursor(0, IDC_ARROW);
hbrBackground := COLOR_WINDOW;
lpszMenuName := nil;
lpszClassName := 'TDataThread';
end;
end;
procedure TDataThread.Execute;
var
Msg: TMsg;
begin
if Winapi.Windows.RegisterClass(FWndClass) = 0 then Exit;
FWnd := CreateWindow(FWndClass.lpszClassName, PChar(FTitle), WS_OVERLAPPED, 0, 0, 0, 0, 0, 0, HInstance, Self);
if FWnd = 0 then Exit;
while GetMessage(Msg, 0, 0, 0) do
begin
if Terminated then Exit;
TranslateMessage(msg);
DispatchMessage(msg);
end;
end;
procedure TDataThread.DoTerminate;
begin
if FWnd <> 0 then DestroyWindow(FWnd);
Winapi.Windows.UnregisterClass(FWndClass.lpszClassName, HInstance);
inherited;
end;
procedure TDataThread.HandleMessage(var Message: TMessage);
begin
case Message.Msg of
WM_POWERBROADCAST:
begin
// ...
end;
else
Message.Result := DefWindowProc(FWnd, Message.Msg, Message.WParam, Message.LParam);
end;
end;
end.
Related
I'm having trouble to receive a byte array containg a PNG file.
When the code is executed in OnClientRead event it works fine, already when transfered for a thread, happens an error of MemoryStream that says:
Out of memory while expanding memory stream.
At this point:
if SD.State = ReadingSize then
I want to know how to solve this specific trouble and also how can I check if I'm receiving a data that contains a file or a simple String?
The code:
type
TSock_Thread = class(TThread)
private
Socket: TCustomWinSocket;
public
constructor Create(aSocket: TCustomWinSocket);
procedure Execute; override;
end;
type
TInt32Bytes = record
case Integer of
0: (Bytes: array[0..SizeOf(Int32)-1] of Byte);
1: (Value: Int32);
end;
TSocketState = (ReadingSize, ReadingStream);
TSocketData = class
public
Stream: TMemoryStream;
Png: TPngImage;
State: TSocketState;
Size: TInt32Bytes;
Offset: Integer;
constructor Create;
destructor Destroy; override;
end;
{ ... }
constructor TSock_Thread.Create(aSocket: TCustomWinSocket);
begin
inherited Create(true);
Socket := aSocket;
FreeOnTerminate := true;
end;
procedure TSock_Thread.Execute;
var
s: String;
BytesReceived: Integer;
BufferPtr: PByte;
SD: TSocketData;
Item: TListItem;
begin
inherited;
while Socket.Connected do
begin
if Socket.ReceiveLength > 0 then
begin
s := Socket.ReceiveText;
{ SD := TSocketData(Socket.Data);
if SD.State = ReadingSize then
begin
while SD.Offset < SizeOf(Int32) do
begin
BytesReceived := Socket.ReceiveBuf(SD.Size.Bytes[SD.Offset],
SizeOf(Int32) - SD.Offset);
if BytesReceived <= 0 then
Exit;
Inc(SD.Offset, BytesReceived);
end;
SD.Size.Value := ntohl(SD.Size.Value);
SD.State := ReadingStream;
SD.Offset := 0;
SD.Stream.Size := SD.Size.Value;
end;
if SD.State = ReadingStream then
begin
if SD.Offset < SD.Size.Value then
begin
BufferPtr := PByte(SD.Stream.Memory);
Inc(BufferPtr, SD.Offset);
repeat
BytesReceived := Socket.ReceiveBuf(BufferPtr^,
SD.Size.Value - SD.Offset);
if BytesReceived <= 0 then
Exit;
Inc(BufferPtr, BytesReceived);
Inc(SD.Offset, BytesReceived);
until SD.Offset = SD.Size.Value;
end;
try
SD.Stream.Position := 0;
SD.Png.LoadFromStream(SD.Stream);
SD.Stream.Clear;
except
SD.Png.Assign(nil);
end;
Item := Form1.ListView1.Selected;
if (Item <> nil) and (Item.Data = Socket) then
Form1.img1.Picture.Graphic := SD.Png;
SD.State := ReadingSize;
SD.Offset := 0;
end; }
end;
Sleep(100);
end;
end;
procedure TForm1.ServerSocket1Accept(Sender: TObject; Socket: TCustomWinSocket);
var
TST: TSock_Thread;
begin
TST := TSock_Thread.Create(Socket);
TST.Resume;
end;
UPDATE:
The code in the answer is not working for me because ServerType=stThreadBlocking blocks all clients connections with the server. And because of this, I'm searching for something like this (ServerType=stNonBlocking, TThread and OnAccept event):
type
TSock_Thread = class(TThread)
private
Png: TPngImage;
Socket: TCustomWinSocket;
public
constructor Create(aSocket: TCustomWinSocket);
procedure Execute; override;
procedure PngReceived;
end;
// ...
// ===============================================================================
constructor TSock_Thread.Create(aSocket: TCustomWinSocket);
begin
inherited Create(true);
Socket := aSocket;
FreeOnTerminate := true;
end;
// ===============================================================================
procedure TSock_Thread.PngReceived;
var
Item: TListItem;
begin
Item := Form1.ListView1.Selected;
if (Item <> nil) and (Item.Data = Socket) then
Form1.img1.Picture.Graphic := Png;
end;
procedure TSock_Thread.Execute;
var
Reciving: Boolean;
DataSize: Integer;
Data: TMemoryStream;
s, sl: String;
begin
inherited;
while Socket.Connected do
begin
if Socket.ReceiveLength > 0 then
begin
s := Socket.ReceiveText;
if not Reciving then
begin
SetLength(sl, StrLen(PChar(s)) + 1);
StrLCopy(#sl[1], PChar(s), Length(sl) - 1);
DataSize := StrToInt(sl);
Data := TMemoryStream.Create;
Png := TPngImage.Create;
Delete(s, 1, Length(sl));
Reciving := true;
end;
try
Data.Write(s[1], Length(s));
if Data.Size = DataSize then
begin
Data.Position := 0;
Png.LoadFromStream(Data);
Synchronize(PngReceived);
Data.Free;
Reciving := false;
end;
except
Png.Assign(nil);
Png.Free;
Data.Free;
end;
end;
Sleep(100);
end;
end;
procedure TForm1.ServerSocket1Accept(Sender: TObject; Socket: TCustomWinSocket);
var
TST: TSock_Thread;
begin
TST := TSock_Thread.Create(Socket);
TST.Resume;
end;
This code has an error of conversion of data at this line:
DataSize := StrToInt(sl);
How can I fix this?
how solve this specific trouble
You are not using TServerSocket threading the way it is meant to be used.
If you want to use TServerSocket in stThreadBlocking mode (see my other answer for how to use TServerSocket in stNonBlocking mode), the correct way is to:
derive a thread class from TServerClientThread
override its virtual ClientExecute() method to do your I/O work (via TWinSocketStream)
use the TServerSocket.OnGetThread event to instantiate the thread.
If you don't do this, TServerSocket will create its own default threads (to fire the OnClient(Read|Write) events in the main thread), which will interfere with your manual threads.
Also, you don't need the state machine that I showed you in my answer to your other question. That was for event-driven code. Threaded I/O code can be written linearly instead.
Try something more like this:
type
TSock_Thread = class(TServerClientThread)
private
Png: TPngImage;
procedure PngReceived;
protected
procedure ClientExecute; override;
end;
type
TInt32Bytes = record
case Integer of
0: (Bytes: array[0..SizeOf(Int32)-1] of Byte);
1: (Value: Int32);
end;
procedure TSock_Thread.ClientExecute;
var
SocketStrm: TWinSocketStream;
Buffer: TMemoryStream;
Size: TInt32Bytes;
Offset: Integer;
BytesReceived: Integer;
BufferPtr: PByte;
begin
SocketStrm := TWinSocketStream.Create(ClientSocket, 5000);
try
Buffer := TMemoryStream.Create;
try
Png := TPngImage.Create;
try
while ClientSocket.Connected do
begin
if not SocketStrm.WaitForData(100) then Continue;
Offset := 0;
while Offset < SizeOf(Int32) do
begin
BytesReceived := SocketStrm.Read(Size.Bytes[Offset], SizeOf(Int32) - Offset);
if BytesReceived <= 0 then Exit;
Inc(Offset, BytesReceived);
end;
Size.Value := ntohl(Size.Value);
Buffer.Size := Size.Value;
BufferPtr := PByte(Buffer.Memory);
Offset := 0;
while Offset < Size.Value do
begin
BytesReceived := SocketStrm.Read(BufferPtr^, Size.Value - Offset);
if BytesReceived <= 0 then Exit;
Inc(BufferPtr, BytesReceived);
Inc(Offset, BytesReceived);
end;
Buffer.Position := 0;
try
Png.LoadFromStream(Buffer);
except
Png.Assign(nil);
end;
Synchronize(PngReceived);
end;
finally
Png.Free;
end;
finally
Buffer.Free;
end;
finally
SocketStrm.Free;
end;
end;
procedure TSock_Thread.PngReceived;
var
Item: TListItem;
begin
Item := Form1.ListView1.Selected;
if (Item <> nil) and (Item.Data = ClientSocket) then
Form1.img1.Picture.Graphic := Png;
end;
procedure TForm1.ServerSocket1GetThread(Sender: TObject; ClientSocket: TServerClientWinSocket; var SocketThread: TServerClientThread);
begin
SocketThread := TSock_Thread.Create(False, ClientSocket);
end;
how i can check if i'm receiving a data that contains a file or a simple String?
The client needs to send that information to your server. You are already sending a value to specify the data size before sending the actual data. You should also preceed the data with a value to specify the data's type. Then you can handle the data according to its type as needed.
Function
function DownloadString(AUrl: string): string;
var
LHttp: TIdHttp;
begin
LHttp := TIdHTTP.Create;
try
LHttp.HandleRedirects := true;
result := LHttp.Get('http://127.0.0.1/a.php?n='+AUrl);
finally
LHttp.Free;
end;
end;
Boot
procedure TForm1.Button1Click(Sender: TObject);
var
LUrlArray: TArray<String>;
begin
LUrlArray := form1.listbox1.Items.ToStringArray;
TThread.CreateAnonymousThread(
procedure
var
LResult: string;
LUrl: string;
begin
for LUrl in LUrlArray do
begin
LResult := DownloadString(LUrl);
TThread.Synchronize(nil,
procedure
begin
if Pos('DENEGADA',LResult)>0 then
begin
Memo1.Lines.Add(LResult);
end
else
begin
Memo1.Lines.Add(LResult + 'DIE');
end;
end
);
end;
end
).Start;
end;
Listbox Lines
http://127.0.0.1/a.php?n=4984
http://127.0.0.1/a.php?n=4986
http://127.0.0.1/a.php?n=4989
in this case only one thread will download all URL's content but I would like to make it creates a thread for each item...
example:
thread1 - check item1 listbox - http://127.0.0.1/a.php?n=4984
thread2 - check next item 4986
thread3 - check next item 4989
how make this? Is there any way to do this ?, I believe that this method will be more effective.
In order to create separate threads, you have to bind the url variable value like this:
procedure TForm1.Button1Click(Sender: TObject);
var
LUrlArray: TArray<String>;
LUrl: String;
function CaptureThreadTask(const s: String) : TProc;
begin
Result :=
procedure
var
LResult : String;
begin
LResult := DownloadString(s);
TThread.Synchronize(nil,
procedure
begin
if Pos('DENEGADA',LResult)>0 then
begin
Memo1.Lines.Add(LResult);
end
else
begin
Memo1.Lines.Add(LResult + 'DIE');
end;
end
);
end;
end;
begin
LUrlArray := form1.listbox1.Items.ToStringArray;
for LUrl in LUrlArray do
// Bind variable LUrl value like this
TThread.CreateAnonymousThread( CaptureThreadTask(LUrl)
).Start;
end;
See Anonymous Methods Variable Binding
You can try using ForEach pattern of omnithreadlibrary :
http://otl.17slon.com/book/chap04.html#highlevel-foreach
http://otl.17slon.com/book/chap04.html#leanpub-auto-iomniblockingcollection
Draft is like that:
TMyForm = class(TForm)
private
DownloadedStrings: iOmniBlockingCollection;
published
DownloadingProgress: TTimer;
MemoSourceURLs: TMemo;
MemoResults: TMemo;
...
published
procedure DownloadingProgressOnTimer( Sender: TObject );
procedure StartButtonClick ( Sender: TObject );
.....
private
property InDownloadProcess: boolean write SetInDownloadProcess;
procedure FlushCollectedData;
end;
procedure TMyForm.StartButtonClick ( Sender: TObject );
begin
DownloadedStrings := TOmniBlockingCollection.Create;
Parallel.ForEach<string>(MemoSourceURLs.Lines)
.NumTasks(10) // we do not want to overload computer by millions of threads when given a long list. We are not "fork bomb"
// .PreserveOrder - usually not a needed option
.Into(DownloadedStrings) // - or you would have to manually seal the container by calling .CompleteAdding AFTER the loop is over in .OnStop option
.NoWait
.Execute(
procedure (const URL: string; var res: TOmniValue)
var Data: string; Success: Boolean;
begin
if my_IsValidUrl(URL) then begin
Success := my_DownloadString( URL, Data);
if Success and my_IsValidData(Data) then begin
if ContainsText(Data, 'denegada') then
Data := Data + ' DIE';
res := Data;
end;
end
);
InDownloadProcess := true;
end;
procedure TMyForm.SetInDownloadProcess(const process: Boolean);
begin
if process then begin
StartButton.Hide;
Prohibit-Form-Closing := true;
MemoSourceURLs.ReadOnly := true;
MemoResults.Clear;
with DownloadingProgress do begin
Interval := 333; // update data in form 3 times per second - often enough
OnTimer := DownloadingProgressOnTimer;
Enabled := True;
end;
end else begin
DownloadingProgress.Enabled := false;
if nil <> DownloadedStrings then
FlushCollectedData; // one last time
Prohibit-Form-Closing := false;
MemoSourceURLs.ReadOnly := false;
StartButton.Show;
end;
end;
procedure TMyForm.FlushCollectedData;
var s: string; value: TOmniValue;
begin
while DownloadedStrings.TryTake(value) do begin
s := value;
MemoResults.Lines.Add(s);
end;
PostMessage( MemoResults.Handle, .... ); // not SendMessage, not Perform
// I do not remember, there was something very easy to make the memo auto-scroll to the last line added
end;
procedure TMyForm.DownloadingProgressOnTimer( Sender: TObject );
begin
if nil = DownloadedStrings then begin
InDownloadProcess := false;
exit;
end;
FlushCollectedData;
if DownloadedStrings.IsCompleted then begin
InDownloadProcess := false; // The ForEach loop is over, everything was downloaded
DownloadedStrings := nil; // free memory
end;
end;
http://docwiki.embarcadero.com/Libraries/XE4/en/System.StrUtils.ContainsText
http://docwiki.embarcadero.com/Libraries/Seattle/en/Vcl.ExtCtrls.TTimer_Properties
PS. note that the online version of the book is old, you perhaps would have to update it to features in the current version of the omnithreadlibrarysources.
PPS: your code has a subtle error:
for LUrl in LUrlArray do
begin
LResult := DownloadString(LUrl);
Given your implementation of DownloadString that means in the case of HTTP error your function would re-return the previous value of LResult again and again and again and.... until the no-error downloading happened.
That is why I changed your function definition to be clear when error happens and no output data is given.
I'm trying (in D7) to set up a thread with a message pump, which eventually I want to transplant into a DLL.
Here's the relevant/non-trivial parts of my code:
const
WM_Action1 = WM_User + 1;
scThreadClassName = 'MyThreadClass';
type
TThreadCreatorForm = class;
TWndThread = class(TThread)
private
FTitle: String;
FWnd: HWND;
FWndClass: WNDCLASS;
FCreator : TForm;
procedure HandleAction1;
protected
procedure Execute; override;
public
constructor Create(ACreator: TForm; const Title: String);
end;
TThreadCreatorForm = class(TForm)
btnCreate: TButton;
btnAction1: TButton;
Label1: TLabel;
btnQuit: TButton;
btnSend: TButton;
edSend: TEdit;
procedure FormShow(Sender: TObject);
procedure btnCreateClick(Sender: TObject);
procedure btnAction1Click(Sender: TObject);
procedure btnQuitClick(Sender: TObject);
procedure btnSendClick(Sender: TObject);
procedure WMAction1(var Msg : TMsg); message WM_Action1;
procedure FormCreate(Sender: TObject);
public
{ Public declarations }
WndThread : TWndThread;
ThreadID : Integer;
ThreadHWnd : HWnd;
end;
var
ThreadCreatorForm: TThreadCreatorForm;
implementation
{$R *.DFM}
procedure SendStringViaWMCopyData(HSource, HDest : THandle; const AString : String);
var
Cds : TCopyDataStruct;
Res : Integer;
begin
FillChar(Cds, SizeOf(Cds), 0);
GetMem(Cds.lpData, Length(Astring) + 1);
try
StrCopy(Cds.lpData, PChar(AString));
Res := SendMessage(HDest, WM_COPYDATA, HSource, Cardinal(#Cds));
ShowMessage(IntToStr(Res));
finally
FreeMem(Cds.lpData);
end;
end;
procedure TThreadCreatorForm.FormShow(Sender: TObject);
begin
ThreadID := GetWindowThreadProcessId(Self.Handle, Nil);
Assert(ThreadID = MainThreadID);
end;
procedure TWndThread.HandleAction1;
begin
//
end;
constructor TWndThread.Create(ACreator: TForm; const Title:String);
begin
inherited Create(True);
FTitle := Title;
FCreator := ACreator;
FillChar(FWndClass, SizeOf(FWndClass), 0);
FWndClass.lpfnWndProc := #DefWindowProc;
FWndClass.hInstance := HInstance;
FWndClass.lpszClassName := scThreadClassName;
end;
procedure TWndThread.Execute;
var
Msg: TMsg;
Done : Boolean;
S : String;
begin
if Windows.RegisterClass(FWndClass) = 0 then Exit;
FWnd := CreateWindow(FWndClass.lpszClassName, PChar(FTitle), WS_DLGFRAME, 0, 0, 0, 0, 0, 0, HInstance, nil);
if FWnd = 0 then Exit;
Done := False;
while GetMessage(Msg, 0, 0, 0) and not done do begin
case Msg.message of
WM_Action1 : begin
HandleAction1;
end;
WM_COPYDATA : begin
Assert(True);
end;
WM_Quit : Done := True;
else begin
TranslateMessage(msg);
DispatchMessage(msg)
end;
end; { case }
end;
if FWnd <> 0 then
DestroyWindow(FWnd);
Windows.UnregisterClass(FWndClass.lpszClassName, FWndClass.hInstance);
end;
Once I've created the thread, I find its window handle using FindWindow and that works fine.
If I PostMessage it my user-defined WM_Action1 message, it's received by the GetMessage(), and caught by the case statement in the thread's Execute, and that works fine.
If I send myself (i.e. my host form) a WM_CopyData message using the SendStringViaWMCopyData() routine that works fine.
However: If I send my thread the WM_CopyData message, the GetMessage and case statement in Execute never see it and the SendMessage in SendStringViaWMCopyData returns 0.
So, my question is, why does the WM_CopyData message not get received by the GetMessage in .Execute? I have an uncomfortable feeling I'm missing something ...
WM_COPYDATA is not a posted message, it is a sent message, so it does not go through the message queue and thus a message loop will never see it. You need to assign a window procedure to your window class and process WM_COPYDATA in that procedure instead. Don't use DefWindowProc() as your window procedure.
Also, when sending WM_COPYDATA, the lpData field is expressed in bytes not in characters, so you need to take that in to account. And you are not filling in the COPYDATASTRUCT correctly. You need to provide values for the dwData and cbData fields. And you don't need to allocate memory for the lpData field, you can point it to your String's existing memory instead.
Try this:
const
WM_Action1 = WM_User + 1;
scThreadClassName = 'MyThreadClass';
type
TThreadCreatorForm = class;
TWndThread = class(TThread)
private
FTitle: String;
FWnd: HWND;
FWndClass: WNDCLASS;
FCreator : TForm;
procedure WndProc(var Message: TMessage);
procedure HandleAction1;
procedure HandleCopyData(const Cds: TCopyDataStruct);
protected
procedure Execute; override;
procedure DoTerminate; override;
public
constructor Create(ACreator: TForm; const Title: String);
end;
TThreadCreatorForm = class(TForm)
btnCreate: TButton;
btnAction1: TButton;
Label1: TLabel;
btnQuit: TButton;
btnSend: TButton;
edSend: TEdit;
procedure FormShow(Sender: TObject);
procedure btnCreateClick(Sender: TObject);
procedure btnAction1Click(Sender: TObject);
procedure btnQuitClick(Sender: TObject);
procedure btnSendClick(Sender: TObject);
procedure WMAction1(var Msg : TMsg); message WM_Action1;
procedure FormCreate(Sender: TObject);
public
{ Public declarations }
WndThread : TWndThread;
ThreadID : Integer;
ThreadHWnd : HWnd;
end;
var
ThreadCreatorForm: TThreadCreatorForm;
implementation
{$R *.DFM}
var
MY_CDS_VALUE: UINT = 0;
procedure SendStringViaWMCopyData(HSource, HDest : HWND; const AString : String);
var
Cds : TCopyDataStruct;
Res : Integer;
begin
ZeroMemory(#Cds, SizeOf(Cds));
Cds.dwData := MY_CDS_VALUE;
Cds.cbData := Length(AString) * SizeOf(Char);
Cds.lpData := PChar(AString);
Res := SendMessage(HDest, WM_COPYDATA, HSource, LPARAM(#Cds));
ShowMessage(IntToStr(Res));
end;
procedure TThreadCreatorForm.FormShow(Sender: TObject);
begin
ThreadID := GetWindowThreadProcessId(Self.Handle, Nil);
Assert(ThreadID = MainThreadID);
end;
function TWndThreadWindowProc(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
pSelf: TWndThread;
Message: TMessage;
begin
pSelf := TWndThread(GetWindowLongPtr(hWnd, GWL_USERDATA));
if pSelf <> nil then
begin
Message.Msg := uMsg;
Message.WParam := wParam;
Message.LParam := lParam;
Message.Result := 0;
pSelf.WndProc(Message);
Result := Message.Result;
end else
Result := DefWindowProc(hWnd, uMsg, wParam, lParam);
end;
constructor TWndThread.Create(ACreator: TForm; const Title:String);
begin
inherited Create(True);
FTitle := Title;
FCreator := ACreator;
FillChar(FWndClass, SizeOf(FWndClass), 0);
FWndClass.lpfnWndProc := #TWndThreadWindowProc;
FWndClass.hInstance := HInstance;
FWndClass.lpszClassName := scThreadClassName;
end;
procedure TWndThread.Execute;
var
Msg: TMsg;
begin
if Windows.RegisterClass(FWndClass) = 0 then Exit;
FWnd := CreateWindow(FWndClass.lpszClassName, PChar(FTitle), WS_DLGFRAME, 0, 0, 0, 0, 0, 0, HInstance, nil);
if FWnd = 0 then Exit;
SetWindowLongPtr(FWnd, GWL_USERDATA, ULONG_PTR(Self));
while GetMessage(Msg, 0, 0, 0) and (not Terminated) do
begin
TranslateMessage(msg);
DispatchMessage(msg);
end;
end;
procedure TWndThread.DoTerminate;
begin
if FWnd <> 0 then
DestroyWindow(FWnd);
Windows.UnregisterClass(FWndClass.lpszClassName, FWndClass.hInstance);
inherited;
end;
procedure TWndThread.WndProc(var Message: TMessage);
begin
case Message.Msg of
WM_Action1 : begin
HandleAction1;
Exit;
end;
WM_COPYDATA : begin
if PCopyDataStruct(lParam).dwData = MY_CDS_VALUE then
begin
HandleCopyData(PCopyDataStruct(lParam)^);
Exit;
end;
end;
end;
Message.Result := DefWindowProc(FWnd, Message.Msg, Message.WParam, Message.LParam);
end;
procedure TWndThread.HandleAction1;
begin
//
end;
procedure TWndThread.HandleCopyData(const Cds: TCopyDataStruct);
var
S: String;
begin
if Cds.cbData > 0 then
begin
SetLength(S, Cds.cbData div SizeOf(Char));
CopyMemory(Pointer(S), Cds.lpData, Length(S) * SizeOf(Char));
end;
// use S as needed...
end;
initialization
MY_CDS_VALUE := RegisterWindowMessage('MY_CDS_VALUE');
end.
The copy data message is sent synchronously. Which means that it won't be returned by GetMessage. So you'll need to supply a window procedure to process the message because sent messages are dispatched directly to the window procedure of their windows, being synchronous rather than asynchronous.
Beyond that the other problem is that you don't specify the length of the data in the copy data struct, cbData. That's needed when sending the message cross-thread so that the system can marshal your data.
You should set dwData so that the recipient can check that they are handling the intended message.
You don't need to use GetMem at all here, you can use the string buffer directly. A window handle is an HWND and not a THandle. A message only window would be most appropriate here.
So, I've always faced MAJOR headaches when threading in delphi xe4-6, whether it be from threads not executing, exception handling causes app crashes, or simply the on terminate method never getting called. All the workarounds I've been instructed to use have become very tedious with issues still haunting me in XE6. My code generally has looked something like this:
procedure TmLoginForm.LoginClick(Sender: TObject);
var
l:TLoginThread;
begin
SyncTimer.Enabled:=true;
l:=TLoginThread.Create(true);
l.username:=UsernameEdit.Text;
l.password:=PasswordEdit.Text;
l.FreeOnTerminate:=true;
l.Start;
end;
procedure TLoginThread.Execute;
var
Success : Boolean;
Error : String;
begin
inherited;
Success := True;
if login(USERNAME,PASSWORD) then
begin
// do another network call maybe to get dif data.
end else
begin
Success := False;
Error := 'Login Failed. Check User/Pass combo.';
end;
Synchronize(
procedure
if success = true then
begin
DifferentForm.Show;
end else
begin
ShowMessage('Error: '+SLineBreak+Error);
end;
SyncTimer.Enabled := False;
end);
end;
And then I came across this unit from the samples in Delphi and from the forums:
unit AnonThread;
interface
uses
System.Classes, System.SysUtils, System.Generics.Collections;
type
EAnonymousThreadException = class(Exception);
TAnonymousThread<T> = class(TThread)
private
class var
CRunningThreads:TList<TThread>;
private
FThreadFunc: TFunc<T>;
FOnErrorProc: TProc<Exception>;
FOnFinishedProc: TProc<T>;
FResult: T;
FStartSuspended: Boolean;
private
procedure ThreadTerminate(Sender: TObject);
protected
procedure Execute; override;
public
constructor Create(AThreadFunc: TFunc<T>; AOnFinishedProc: TProc<T>;
AOnErrorProc: TProc<Exception>; ACreateSuspended: Boolean = False;
AFreeOnTerminate: Boolean = True);
class constructor Create;
class destructor Destroy;
end;
implementation
{$IFDEF MACOS}
uses
{$IFDEF IOS}
iOSapi.Foundation
{$ELSE}
MacApi.Foundation
{$ENDIF IOS}
;
{$ENDIF MACOS}
{ TAnonymousThread }
class constructor TAnonymousThread<T>.Create;
begin
inherited;
CRunningThreads := TList<TThread>.Create;
end;
class destructor TAnonymousThread<T>.Destroy;
begin
CRunningThreads.Free;
inherited;
end;
constructor TAnonymousThread<T>.Create(AThreadFunc: TFunc<T>; AOnFinishedProc: TProc<T>;
AOnErrorProc: TProc<Exception>; ACreateSuspended: Boolean = False; AFreeOnTerminate: Boolean = True);
begin
FOnFinishedProc := AOnFinishedProc;
FOnErrorProc := AOnErrorProc;
FThreadFunc := AThreadFunc;
OnTerminate := ThreadTerminate;
FreeOnTerminate := AFreeOnTerminate;
FStartSuspended := ACreateSuspended;
//Store a reference to this thread instance so it will play nicely in an ARC
//environment. Failure to do so can result in the TThread.Execute method
//not executing. See http://qc.embarcadero.com/wc/qcmain.aspx?d=113580
CRunningThreads.Add(Self);
inherited Create(ACreateSuspended);
end;
procedure TAnonymousThread<T>.Execute;
{$IFDEF MACOS}
var
lPool: NSAutoreleasePool;
{$ENDIF}
begin
{$IFDEF MACOS}
//Need to create an autorelease pool, otherwise any autorelease objects
//may leak.
//See https://developer.apple.com/library/ios/#documentation/Cocoa/Conceptual/MemoryMgmt/Articles/mmAutoreleasePools.html#//apple_ref/doc/uid/20000047-CJBFBEDI
lPool := TNSAutoreleasePool.Create;
try
{$ENDIF}
FResult := FThreadFunc;
{$IFDEF MACOS}
finally
lPool.drain;
end;
{$ENDIF}
end;
procedure TAnonymousThread<T>.ThreadTerminate(Sender: TObject);
var
lException: Exception;
begin
try
if Assigned(FatalException) and Assigned(FOnErrorProc) then
begin
if FatalException is Exception then
lException := Exception(FatalException)
else
lException := EAnonymousThreadException.Create(FatalException.ClassName);
FOnErrorProc(lException)
end
else if Assigned(FOnFinishedProc) then
FOnFinishedProc(FResult);
finally
CRunningThreads.Remove(Self);
end;
end;
end.
Why is that this anon thread unit above works flawlessly 100% of the time and my code crashes sometimes? For example, I can exec the same thread 6 times in a row, but then maybe on the 7th (or the first for that matter) time it causes the app to crash. No exceptions ever come up when debugging so I dont have a clue where to start fixing the issue. Also, why is it that I need a separate timer that calls "CheckSynchronize" for my code in order to GUI updates to happen but it is not needed when I use the anon thread unit?
Maybe someone can point me in the right direction to ask this question elsewhere if here is not the place. Sorry, I'm diving into documentation already, trying my best to understand.
Here is an example of a thread that may work 20 times in a row, but then randomly cause app to crash
inherited;
try
SQL:= 'Some SQL string';
if GetSQL(SQL,XMLData) then
synchronize(
procedure
var
i:Integer;
begin
try
mTasksForm.TasksListView.BeginUpdate;
if mTasksForm.TasksListView.Items.Count>0 then
mTasksForm.TasksListView.Items.Clear;
XMLDocument := TXMLDocument.Create(nil);
XMLDocument.Active:=True;
XMLDocument.Version:='1.0';
XMLDocument.LoadFromXML(XMLData);
XMLNode:=XMLDocument.DocumentElement.ChildNodes['Record'];
i:=0;
if XMLNode.ChildNodes['ID'].Text <>'' then
while XMLNode <> nil do
begin
LItem := mTasksForm.TasksListView.Items.AddItem;
with LItem do
begin
Text := XMLNode.ChildNodes['LOCATION'].Text;
Detail := XMLNode.ChildNodes['DESC'].Text +
SLineBreak+
'Assigned To: '+XMLNode.ChildNodes['NAME'].Text
tag := StrToInt(XMLNode.ChildNodes['ID'].Text);
color := TRectangle.Create(nil);
with color do
begin
if XMLNode.ChildNodes['STATUS'].Text = STATUS_DONE then
fill.Color := TAlphaColors.Lime
else if XMLNode.ChildNodes['STATUS'].Text = STATUS_OK then
fill.Color := TAlphaColors.Yellow
else
fill.Color := TAlphaColors.Crimson;
stroke.Color := fill.Color;
ButtonText := XMLNode.ChildNodes['STATUS'].Text;
end;
Bitmap := Color.MakeScreenshot;
end;
XMLNode:=XMLNode.NextSibling;
end;
finally
mTasksForm.TasksListView.EndUpdate;
for i := 0 to mTasksForm.TasksListView.Controls.Count-1 do
begin
if mTasksForm.TasksListView.Controls[I].ClassType = TSearchBox then
begin
SearchBox := TSearchBox(mTasksForm.TasksListView.Controls[I]);
Break;
end;
end;
SearchBox.Text:=' ';
SearchBox.text := ''; //have in here because if the searchbox has text, when attempting to add items then app crashes
end;
end)
else
error := 'Please check internet connection.';
finally
synchronize(
procedure
begin
if error <> '' then
ShowMessage('Erorr: '+error);
mTasksForm.Spinner.Visible:=false;
mTasksForm.SyncTimer.Enabled:=false;
end);
end;
end;
here is the GETSQL method
function GetSQL(SQL:String;var XMLData:String):Boolean;
var
PostResult,
ReturnCode : String;
PostData : TStringList;
IdHTTP : TIdHTTP;
XMLDocument : IXMLDocument;
XMLNode : IXMLNode;
Test : String;
begin
Result:=False;
XMLData:='';
XMLDocument:=TXMLDocument.Create(nil);
IdHTTP:=TIdHTTP.Create(nil);
PostData:=TStringList.Create;
PostData.Add('session='+SessionID);
PostData.Add('database='+Encode(DATABASE,''));
PostData.Add('sql='+Encode(SQL,''));
IdHTTP.Request.ContentEncoding:='UTF-8';
IdHTTP.Request.ContentType:='application/x-www-form-urlencoded';
IdHTTP.ConnectTimeout:=100000;
IdHTTP.ReadTimeout:=1000000;
try
PostResult:=IdHTTP.Post(SERVER_URL+GET_METHOD,PostData);
XMLDocument.Active:=True;
XMLDocument.Version:='1.0';
test := Decode(PostResult,'');
XMLDocument.LoadFromXML(Decode(PostResult,''));
XMLNode:=XMLDocument.DocumentElement;
try
ReturnCode:=XMLNode.ChildNodes['status'].Text;
except
ReturnCode:='200';
end;
if ReturnCode='' then begin
ReturnCode:='200';
end;
if ReturnCode='200' then begin
Result:=True;
XMLData:=Decode(PostResult,'');
end;
except
on E: Exception do begin
result:=false;
end;
end;
PostData.Free;
IdHTTP.Free;
end;
Download the source code with compiled executable (221 KB (226,925 bytes)): http://www.eyeclaxton.com/download/delphi/skeleton.zip
Why doesn't the Destroy destructor get called if I close the application (click the X button) before the thread has terminated? FastMM4 reports a memory leak with FPauseEvent event.
How should i destroy thread? If someone closes the application before the thread finishes.
unit SkeletonThread;
interface
uses
Windows, Classes, SysUtils, SyncObjs;
type
TOnInitialize = procedure(Sender: TObject; const AMaxValue: Integer) of object;
TOnBegin = procedure(Sender: TObject) of object;
TOnProgress = procedure(Sender: TObject; const APosition: Integer) of object;
TOnPause = procedure(Sender: TObject; const APaused: Boolean) of object;
TOnFinish = procedure(Sender: TObject) of object;
TOnFinalize = procedure(Sender: TObject) of object;
TMasterThread = class(TThread)
private
{ Private declarations }
FPaused: Boolean;
FPosition: Integer;
FMaxValue: Integer;
FOnBegin: TOnBegin;
FOnProgress: TOnProgress;
FOnFinish: TOnFinish;
FOnInitialize: TOnInitialize;
FOnFinalize: TOnFinalize;
FPauseEvent: TEvent;
FOnPause: TOnPause;
procedure BeginEvent();
procedure ProgressEvent();
procedure FinishEvent();
procedure InitializeEvent();
procedure FinalizeEvent();
procedure PauseEvent();
procedure CheckForPause();
protected
{ Protected declarations }
procedure DoInitializeEvent(const AMaxValue: Integer); virtual;
procedure DoBeginEvent(); virtual;
procedure DoProgress(const APosition: Integer); virtual;
procedure DoPauseEvent(const APaused: Boolean); virtual;
procedure DoFinishEvent(); virtual;
procedure DoFinalizeEvent(); virtual;
public
{ Public declarations }
constructor Create(const CreateSuspended: Boolean; const theValue: Integer);
destructor Destroy(); override;
procedure Pause();
procedure Unpause();
published
{ Published declarations }
property IsPaused: Boolean read FPaused write FPaused default False;
property OnInitialize: TOnInitialize read FOnInitialize write FOnInitialize default nil;
property OnBegin: TOnBegin read FOnBegin write FOnBegin default nil;
property OnProgress: TOnProgress read FOnProgress write FOnProgress default nil;
property OnPause: TOnPause read FOnPause write FOnPause default nil;
property OnFinish: TOnFinish read FOnFinish write FOnFinish default nil;
property OnFinalize: TOnFinalize read FOnFinalize write FOnFinalize default nil;
end;
TSkeletonThread = class(TMasterThread)
private
{ Private declarations }
procedure DoExecute(const theValue: Integer);
protected
{ Protected declarations }
procedure Execute(); override;
public
{ Public declarations }
published
{ Published declarations }
end;
implementation
{ TMasterThread }
constructor TMasterThread.Create(const CreateSuspended: Boolean; const theValue: Integer);
begin
inherited Create(CreateSuspended);
Self.FreeOnTerminate := True;
Self.FPosition := 0;
Self.FMaxValue := theValue;
Self.FPaused := False;
Self.FPauseEvent := TEvent.Create(nil, True, True, '');
end;
destructor TMasterThread.Destroy();
begin
FreeAndNil(FPauseEvent);
if (Pointer(FPauseEvent) <> nil) then Pointer(FPauseEvent) := nil;
inherited Destroy();
end;
procedure TMasterThread.DoBeginEvent();
begin
if Assigned(Self.FOnBegin) then Self.FOnBegin(Self);
end;
procedure TMasterThread.BeginEvent();
begin
Self.DoBeginEvent();
end;
procedure TMasterThread.DoProgress(const APosition: Integer);
begin
if Assigned(Self.FOnProgress) then Self.FOnProgress(Self, APosition);
end;
procedure TMasterThread.ProgressEvent();
begin
Self.DoProgress(Self.FPosition);
end;
procedure TMasterThread.DoFinishEvent();
begin
if Assigned(Self.FOnFinish) then Self.FOnFinish(Self);
end;
procedure TMasterThread.FinishEvent();
begin
Self.DoFinishEvent();
end;
procedure TMasterThread.DoInitializeEvent(const AMaxValue: Integer);
begin
if Assigned(Self.FOnInitialize) then Self.FOnInitialize(Self, AMaxValue);
end;
procedure TMasterThread.InitializeEvent();
begin
Self.DoInitializeEvent(Self.FMaxValue);
end;
procedure TMasterThread.DoFinalizeEvent();
begin
if Assigned(Self.FOnFinalize) then Self.FOnFinalize(Self);
end;
procedure TMasterThread.FinalizeEvent;
begin
Self.DoFinalizeEvent();
end;
procedure TMasterThread.DoPauseEvent(const APaused: Boolean);
begin
if Assigned(Self.FOnPause) then Self.FOnPause(Self, APaused);
end;
procedure TMasterThread.PauseEvent();
begin
Self.DoPauseEvent(Self.FPaused);
end;
procedure TMasterThread.Pause();
begin
Self.FPauseEvent.ResetEvent();
Self.FPaused := True;
Self.Synchronize(Self.PauseEvent);
end;
procedure TMasterThread.Unpause();
begin
Self.FPaused := False;
Self.Synchronize(Self.PauseEvent);
Self.FPauseEvent.SetEvent();
end;
procedure TMasterThread.CheckForPause();
begin
if (not (Self.Terminated)) then Windows.Sleep(1);
Self.FPauseEvent.WaitFor(INFINITE);
end;
{ TSkeletonThread }
procedure TSkeletonThread.DoExecute(const theValue: Integer);
var
X: Integer;
begin
Self.Synchronize(InitializeEvent);
try
Self.Synchronize(BeginEvent);
try
for X := 0 to (theValue - 1) do
begin
Self.CheckForPause();
if (not Self.FPaused) and (not Self.Terminated) then
begin
Self.FPosition := Self.FPosition + 1;
Self.Synchronize(ProgressEvent);
end
else begin
Break;
end;
end;
for X := Self.FPosition downto 1 do
begin
Self.CheckForPause();
if (not Self.FPaused) and (not Self.Terminated) then
begin
Self.FPosition := X;
Self.Synchronize(ProgressEvent);
end
else begin
Break;
end;
end;
finally
Self.Synchronize(FinishEvent);
end;
finally
Self.Synchronize(FinalizeEvent);
end;
end;
procedure TSkeletonThread.Execute();
begin
Self.DoExecute(Self.FMaxValue);
end;
end.
You have to terminate the thread yourself (tell it to stop). One way is to use the Terminate procedure of the thread, but you have to check for this in the thread Execute method. Something like this:
procedure Execute;
begin
inherited;
while not Terminated do
begin
// do your job
end;
end;
procedure TForm1.StopThread;
begin
MyThread.Terminate;
// wait and block until the scheduling thread is finished
AResult := WaitForSingleObject(MyThread.Handle, cShutdownTimeout);
// check if we timed out
if AResult = WAIT_TIMEOUT then
TerminateThread(MyThread.Handle, 0);
end;
Or you can use signalization build into windows so you do not have to loop.
procedure Execute;
begin
inherited;
while not Terminated do
begin
WaitStatus := WaitForSingleObject(FTermEvent, Max(0, SleepInterval));
// check what was the cause for signalization
if WaitStatus <> WAIT_TIMEOUT then
Terminate;
end;
end;
procedure TForm1.StopThread;
begin
// Terminate the thread
SetEvent(FTermEvent);
// close the handle
CloseHandle(FTermEvent);
// wait and block until the scheduling thread is finished
AResult := WaitForSingleObject(MyThread.Handle, cShutdownTimeout);
// check if we timed out
if AResult = WAIT_TIMEOUT then
TerminateThread(MyThread.Handle, 0);
end;
Signalization can be very neat way of signaling for termination because you can use WaitForMultipleObjects and release the wait in different conditions. I used WaitForSingleObject to not complicate things to much.
Also be sure to set "FreeOnTerminate := True" in thread constructor. Oh and the hard termination at the end is optional of course. It can be dangerous. You know best yourself if you will use it or not. You can also wait for a longer period or infinite if you are sure the thread will stop eventually.