Error to receive file on socket inside a thread - multithreading

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.

Related

Download and process files with IOmniPipeline

My goal is a VCL app where I need to concurrently download some files (URLs stored in TDataSet), then each of downloaded file must be processed (one-by-one). During app working GUI must not be hanged, user user should be able to cancel (interrupt) process in any stage.
I totally rewrite my first example, now there is no third-party classes (Omni Thread Library 3.07.6 and VCL only). Of course, it's still demo and some checks was removed from code, but however, this sample still not short unfortunately.
Downloading part based on this answer (thanks!).
So, when any file downloading I need to show progress to this files in GUI. Downloader class generate "event" OnProgressChange (because in real app I'll use TALWinInetHTTPClient class instance from Alcinoe library and it has real event OnProgressChange). I think it's enough just write progress value in DB, then DBGrid show progress values correctly.
Of course I saw this answers (and some other related with OTL):
How to Stop all Pipeline tasks correctly
How to use Pipeline pattern in Delphi (it's similar to my tasks, but differences in details).
Also I saw OTL docs and examples but I can't find some real example for doing similar task.
I created some classes to solve this task, and it's works, but have some critical troubles:
At first stage downloading not starts separately (not parallels, but one-by-one).
Cancellation not works properly.
Below some code to illustrate my problem. It's contain two units, one is main form (GUI, preparing data, interaction with user), second is Pipeline wrapper and downloader.
DFM for main form is:
object fmMain: TfmMain
Left = 628
Top = 172
Caption = 'WorkSpace preparer'
ClientHeight = 262
ClientWidth = 700
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -13
Font.Name = 'Segoe UI'
Font.Style = []
OldCreateOrder = False
Position = poScreenCenter
OnCloseQuery = FormCloseQuery
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 17
object DBGridApps: TDBGrid
AlignWithMargins = True
Left = 3
Top = 3
Width = 694
Height = 207
Align = alClient
DataSource = dsApps
ReadOnly = True
TabOrder = 0
TitleFont.Charset = DEFAULT_CHARSET
TitleFont.Color = clWindowText
TitleFont.Height = -13
TitleFont.Name = 'Segoe UI'
TitleFont.Style = []
end
object Panel1: TPanel
AlignWithMargins = True
Left = 3
Top = 216
Width = 694
Height = 43
Align = alBottom
TabOrder = 1
object bbExit: TBitBtn
AlignWithMargins = True
Left = 549
Top = 4
Width = 141
Height = 35
Align = alRight
Caption = 'Exit'
TabOrder = 0
OnClick = bbExitClick
end
object bbCancel: TBitBtn
AlignWithMargins = True
Left = 151
Top = 4
Width = 141
Height = 35
Align = alLeft
Caption = 'Cancel'
TabOrder = 1
OnClick = bbCancelClick
ExplicitTop = 0
end
object bbStart: TBitBtn
AlignWithMargins = True
Left = 4
Top = 4
Width = 141
Height = 35
Align = alLeft
Caption = 'Start'
TabOrder = 2
OnClick = bbStartClick
end
end
object dsApps: TDataSource
DataSet = cdsApps
Left = 32
Top = 88
end
object cdsApps: TClientDataSet
Aggregates = <>
Params = <>
Left = 16
Top = 72
end
end
Main form code:
unit MainForm;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, DB, DBClient, Grids, DBGrids, StdCtrls, Buttons, ExtCtrls,
PipelineHolder;
type
TfmMain = class(TForm)
DBGridApps: TDBGrid;
dsApps: TDataSource;
Panel1: TPanel;
bbExit: TBitBtn;
bbCancel: TBitBtn;
bbStart: TBitBtn;
cdsApps: TClientDataSet;
procedure bbExitClick(Sender: TObject);
procedure bbCancelClick(Sender: TObject);
procedure bbStartClick(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
PH : TPipelineHolder;
procedure SwitchControlState;
public
{ Public declarations }
end;
var
fmMain: TfmMain;
implementation
{$R *.dfm}
procedure TfmMain.bbExitClick(Sender: TObject);
begin
Close;
end;
procedure TfmMain.bbCancelClick(Sender: TObject);
begin
if Assigned(PH) then
begin
SwitchControlState;
PH.Stop;
end;
end;
procedure TfmMain.bbStartClick(Sender: TObject);
begin
if not Assigned(PH) then
PH := TPipelineHolder.Create;
SwitchControlState;
PH.Make(cdsApps);
end;
procedure TfmMain.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
CanClose := MessageBox(0, 'Exit now?', 'Exit', MB_YESNO + MB_ICONQUESTION + MB_DEFBUTTON2 + MB_TOPMOST) = IDYES;
if CanClose then bbCancel.Click;
end;
procedure TfmMain.FormCreate(Sender: TObject);
begin
//Prepare dataset
cdsApps.Close;
With cdsApps do
begin
FieldDefs.Add('progress', ftFloat);
FieldDefs.Add('status', ftString, 30);
FieldDefs.Add('id', ftString, 30);
FieldDefs.Add('uid', ftString, 30);
FieldDefs.Add('title', ftString, 30);
FieldDefs.Add('url', ftString, 255);
FieldDefs.Add('silent_parameters', ftString, 255);
FieldDefs.Add('target_file', ftString, 255);
CreateDataSet;
LogChanges := False;
Open;
// Below you can change URL as you wish.
// For example I'll use VirtualBox distrib from this page: https://www.virtualbox.org/wiki/Downloads
// To correct progress values web-server must response with correct content-lenght values and must
// support HEAD command.
// Record 1
Append;
Fields[0].AsFloat := 0.0;
Fields[1].AsString := 'Ready';
Fields[2].AsString := '5be2e746ce46a1000cdc8b90';
Fields[3].AsString := 'SomeApp1';
Fields[4].AsString := 'VirtualBox 6.0.10';
Fields[5].AsString := 'https://download.virtualbox.org/virtualbox/6.0.10/VirtualBox-6.0.10-132072-Win.exe';
Fields[6].AsString := '/S';
Fields[7].AsString := '001_installer.exe';
Post;
// Record 2
Append;
Fields[0].AsFloat := 0.0;
Fields[1].AsString := 'Ready';
Fields[2].AsString := '5be31c63ce46a1000b268bb2';
Fields[3].AsString := 'SomeApp2';
Fields[4].AsString := 'VirtualBox 6.0.10';
Fields[5].AsString := 'https://download.virtualbox.org/virtualbox/6.0.10/VirtualBox-6.0.10-132072-Win.exe';
Fields[6].AsString := '';
Fields[7].AsString := '002_installer.exe';
Post;
// Record 3
Append;
Fields[0].AsFloat := 0.0;
Fields[1].AsString := 'Ready';
Fields[2].AsString := '5be3428ace46a1000b268bc0';
Fields[3].AsString := 'SomeApp3';
Fields[4].AsString := 'VirtualBox 6.0.10';
Fields[5].AsString := 'https://download.virtualbox.org/virtualbox/6.0.10/VirtualBox-6.0.10-132072-Win.exe';
Fields[6].AsString := '/VERY_SILENT';
Fields[7].AsString := '003_installer.exe';
Post;
// Record 4
Append;
Fields[0].AsFloat := 0.0;
Fields[1].AsString := 'Ready';
Fields[2].AsString := '5be3428ace46a1000b268bc1';
Fields[3].AsString := 'SomeApp4';
Fields[4].AsString := 'VirtualBox 6.0.10';
Fields[5].AsString := 'https://download.virtualbox.org/virtualbox/6.0.10/VirtualBox-6.0.10-132072-Win.exe';
Fields[6].AsString := '';
Fields[7].AsString := '004_installer.exe';
Post;
// Record 5 - it's not exe, just simple testing file, in this demo at
// Install method with this file will set status to error.
Append;
Fields[0].AsFloat := 0.0;
Fields[1].AsString := 'Ready';
Fields[2].AsString := '5be512bb4a9bbb000b6de944';
Fields[3].AsString := 'SomeFile';
Fields[4].AsString := 'Demo File (not executable)';
Fields[5].AsString := 'https://speed.hetzner.de/100MB.bin';
Fields[6].AsString := '';
Fields[7].AsString := '005_sample_100MB.bin';
Post;
First;
end;
end;
procedure TfmMain.SwitchControlState;
begin
bbStart.Enabled := not bbStart.Enabled;
end;
end.
Second unit for pipeline working implementation:
unit PipelineHolder;
interface
uses
Windows, SysUtils, Classes, OtlCommon, OtlCollections, OtlParallel, Forms,
DB, Generics.Defaults, StrUtils, Generics.Collections, Messages, OtlComm,
OtlTask, OtlTaskControl, ShellAPI, Dialogs, OtlSync, Math, WinInet;
// Messages
const
WM_PROGRESSCHANGED = WM_APP + 105;
// Process states
type
TAppState = (asReady = 0, asCancelled = 1, asError = 2, asDownloading = 3, asDownloaded = 4, asInstalling = 5, asCompleted = 6);
TAppStateNames = array[asReady..asCompleted] of string;
const
AppState: TAppStateNames = ('Ready', 'Canceled', 'Error', 'Downloading', 'Downloaded', 'Installing', 'Installed');
type
// Data structs for progress message
PProgressInfo = ^TProgressInfo;
TProgressInfo = record
Read : Int64;
Total : Int64;
ID : string;
URL : string;
end;
//Structure for record info
TRecordInfo = record
Filename: string;
URL: string;
ID: string;
Cmd : string;
end;
// Class for downloading
TDBAppItem = class
private
FHandle : HWND;
FDS : TDataSet;
FFilename: string;
FURL: string;
FId: string;
FCmd : string;
FFileSize : Int64;
FDownloaded : Int64;
function GetWinInetError(ErrorCode: Cardinal): string;
procedure ParseURL(const lpszUrl: string; var Host, Resource: string);
function GetRemoteFileSize(const Url : string): Integer;
function DownloadFile(const url: string; const TargetFileName: string): boolean;
procedure InternalDownloadProgress(Sender: TObject; Read: Integer; Total: Integer);
public
constructor Create(const OwnerHandle: HWND; var DS: TDataSet; const URL, ID: string; const Cmd: string; const TargetFilename: string);
destructor Destroy; override;
function Download : Boolean; overload;
end;
// Main class, pipeline holder
TPipelineHolder = class
private
FDS : TDataSet;
FHandle : HWND;
FPipeline : IOmniPipeline;
FInProcess: Boolean;
procedure Retrieve(const input: TOmniValue; var output: TOmniValue);
procedure RetrieveAll(const input, output: IOmniBlockingCollection);
procedure Install(const input, output: IOmniBlockingCollection);
procedure JobDone;
procedure WndProc(var Message: TMessage);
procedure WMProgressChanged(var msg: TMessage); message WM_PROGRESSCHANGED;
public
constructor Create;
destructor Destroy; override;
procedure Make(SourceDS : TDataSet);
function Stop: Boolean;
property InProcess: Boolean read FInProcess write FInProcess;
end;
implementation
{ Tools }
function RunAsAdmin(const Handle: HWnd; const Filename, Params: string): Boolean;
var
sei: TShellExecuteInfo;
begin
FillChar(sei, SizeOf(sei), 0);
sei.cbSize := SizeOf(sei);
sei.Wnd := Handle;
sei.fMask := SEE_MASK_FLAG_DDEWAIT or SEE_MASK_FLAG_NO_UI;
sei.lpVerb := 'runas';
sei.lpFile := PChar(Filename);
sei.lpParameters := PChar(Params);
sei.nShow := SW_SHOWNORMAL;
Result := ShellExecuteEx(#sei);
end;
{TPipelineHolder}
constructor TPipelineHolder.Create;
begin
inherited Create;
FHandle := AllocateHWnd(WndProc);
FInProcess := False;
end;
destructor TPipelineHolder.Destroy;
begin
if FInProcess then
if Assigned(FPipeline) then
begin
FPipeline.Cancel;
FPipeline := nil;
FInProcess := False;
end;
if FHandle <> 0 then DeallocateHWnd(FHandle);
inherited;
end;
procedure TPipelineHolder.Install(const input, output: IOmniBlockingCollection);
var
app : TOmniValue;
appFile : string;
appParams: string;
ID : string;
State : string;
AppInfo : TRecordInfo;
begin
// In real app here is downloaded file must be started as separate process and
// we must wait when it will be completed.
for app in input do
begin
if not app.IsEmpty then
begin
AppInfo := app.ToRecord<TRecordInfo>;
appFile := AppInfo.Filename;
appParams := AppInfo.Cmd;
ID := AppInfo.ID;
if (appFile <> EmptyStr) and (FileExists(appFile)) then
begin
// Change file state
FDS.DisableControls;
try
if FDS.Locate('id', ID, [loCaseInsensitive]) then
begin
FDS.Edit;
FDS.FieldByName('Status').AsString := AppState[asInstalling];
FDS.Post;
end;
finally
FDS.EnableControls;
end;
// Try to execute intsaller
if RunAsAdmin(Application.Handle, appFile, appParams) then
begin
State := AppState[asCompleted]
end
else
begin
State := AppState[asError];
end;
// Change state again
FDS.DisableControls;
try
if FDS.Locate('id', ID, [loCaseInsensitive]) then
begin
FDS.Edit;
FDS.FieldByName('Status').AsString := State;
FDS.Post;
end;
finally
FDS.EnableControls;
end;
end;
end;
end;
end;
procedure TPipelineHolder.Retrieve(const input: TOmniValue; var output: TOmniValue);
var
App: TDBAppItem;
Info : TRecordInfo;
begin
// Checking cancellation flag
if not FInProcess then Exit;
// Preparing
Info := input.ToRecord<TRecordInfo>;
App := TDBAppItem.Create(FHandle, FDS, Info.URL, Info.ID, Info.Cmd, Info.Filename);
// Downloading
try
if App.Download then
output := TOmniValue.FromRecord<TRecordInfo>(Info)
else
output.Clear;
finally
FreeAndNil(App);
end;
end;
procedure TPipelineHolder.RetrieveAll(const input,
output: IOmniBlockingCollection);
var
App: TDBAppItem;
Info : TRecordInfo;
value : TOmniValue;
begin
// Preparing
for value in input do
begin
if not FInProcess then Exit;
Info := value.ToRecord<TRecordInfo>;
App := TDBAppItem.Create(FHandle, FDS, Info.URL, Info.ID, Info.Cmd, Info.Filename);
// Downloading
try
if App.Download then
output.Add(TOmniValue.FromRecord<TRecordInfo>(Info));
finally
FreeAndNil(App);
end;
end;
end;
function TPipelineHolder.Stop: Boolean;
begin
if FInProcess then
begin
if Assigned(FPipeline) then
begin
FPipeline.Cancel;
FPipeline := nil;
FInProcess := False;
end;
end;
Result := not FInProcess;
end;
procedure TPipelineHolder.WMProgressChanged(var msg: TMessage);
var
MsgRec : TProgressInfo;
Percent, Current : Double;
Read, Total : Int64;
ID : string;
begin
MsgRec := PProgressInfo(Msg.LParam )^;
Read := MsgRec.Read;
Total := MsgRec.Total;
Percent := 100 * Read / Total;
ID := MsgRec.ID;
// Write data to db
if FDS.Locate('id', ID, [loCaseInsensitive]) then
begin
FDS.DisableControls;
try
Current := FDS.FieldByName('Progress').AsFloat;
if Current <> Trunc(Percent) then
begin
FDS.Edit;
FDS.FieldByName('Progress').AsFloat := Round(Percent);
if Percent >= 99 then
begin
FDS.FieldByName('Status').AsString := AppState[asDownloaded];
end;
FDS.Post;
end;
finally
FDS.EnableControls;
end;
end;
end;
procedure TPipelineHolder.WndProc(var Message: TMessage);
begin
Dispatch(Message);
inherited;
end;
procedure TPipelineHolder.JobDone;
begin
FPipeline := nil;
FInProcess := False;
end;
procedure TPipelineHolder.Make(SourceDS: TDataSet);
var
BM : TBookmark;
RecInfo : TRecordInfo;
begin
if SourceDS = nil then Exit;
if not SourceDS.Active then Exit;
if SourceDS.IsEmpty then Exit;
FDS := SourceDS;
FInProcess := True;
// Here at first stage calling Retrive or RetrieveAll gives same effect, no
// matter what we uses value or queue.
FPipeline := Parallel.Pipeline
.Stage(RetrieveAll, //Retrieve
Parallel.TaskConfig.OnMessage(Self)).NumTasks(Environment.Process.Affinity.Count * 2)
.Stage(Install)
.OnStop(JobDone)
.Run;
// Get URLs to be downloaded
BM := FDS.GetBookmark;
FDS.DisableControls;
try
FDS.First;
while not FDS.Eof do
begin
// Get data from database
RecInfo.URL := Trim(FDS.FieldByName('url').AsString);
RecInfo.Id := Trim(FDS.FieldByName('id').AsString);
RecInfo.Cmd := Trim(FDS.FieldByName('silent_parameters').AsString);
RecInfo.Filename := ExtractFilePath(ParamStr(0)) + 'Downloads\' + Trim(FDS.FieldByName('target_file').AsString);
if RecInfo.URL = EmptyStr then
begin
// Skips empty URLs
FDS.Next;
Continue;
end;
FDS.Edit;
FDS.FieldByName('Status').AsString := AppState[asDownloading];
FDS.Post;
FPipeline.Input.Add(TOmniValue.FromRecord<TRecordInfo>(RecInfo));
FDS.Next;
end;
finally
if FDS.BookmarkValid(BM) then SourceDS.GotoBookmark(BM);
FDS.FreeBookmark(BM);
FDS.EnableControls;
end;
FPipeline.Input.CompleteAdding;
// Wait for pipeline to complete - I'm not use it to avoid GUI freezing
// FPipeline.WaitFor(INFINITE);
end;
constructor TDBAppItem.Create(const OwnerHandle: HWND; var DS: TDataSet; const URL, ID, Cmd, TargetFilename: string);
begin
inherited Create;
FDS := DS;
FURL := URL;
FId := ID;
FCmd := Cmd;
FFilename := TargetFilename;
FHandle := OwnerHandle;
FFileSize := -1;
FDownloaded := 0;
end;
destructor TDBAppItem.Destroy;
begin
FDS := nil;
inherited;
end;
function TDBAppItem.Download: Boolean;
var
path : string;
begin
path := ExtractFilePath(FFilename);
if not DirectoryExists(path) then
if not ForceDirectories(path) then
raise Exception.Create('Cannot create directory: "'+path+'".');
if FileExists(FFilename) then
try
if not DeleteFile(FFilename) then
raise Exception.Create('Cannot delete file: "'+FFilename+'".');
except on E: Exception do
raise Exception.Create('Cannot delete file: "'+FFilename+'".'+sLineBreak + E.Message);
end;
Result := DownloadFile(FURL, FFilename);
if Result then Result := FileExists(FFilename);
end;
function TDBAppItem.DownloadFile(const url, TargetFileName: string): boolean;
var
hInet: HINTERNET;
hFile: HINTERNET;
localFile: file;
buffer: array[1..65535] of Byte;
bytesRead: DWORD;
b: boolean;
begin
b := False;
if FFileSize < 0 then FFileSize := GetRemoteFileSize(url);
FDownloaded := 0;
hInet := WinInet.InternetOpen('MyFileAgent', INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0);
if Assigned(hInet) then
begin
hFile := InternetOpenURL(hInet, PChar(url), nil, 0, INTERNET_FLAG_PRAGMA_NOCACHE, 0);
if Assigned(hFile) then
begin
AssignFile(localFile, TargetFileName);
Rewrite(localFile, 1);
bytesRead := 0;
repeat
InternetReadFile(hFile, #buffer, SizeOf(buffer), bytesRead);
BlockWrite(localFile, buffer, bytesRead);
Inc(FDownloaded, bytesRead);
//In real app this event occurs in TALWinHttpClient from Alcinoe library.
InternalDownloadProgress(Self, FDownloaded, FFileSize);
until bytesRead = 0;
CloseFile(localFile);
InternetCloseHandle(hFile);
end;
InternetCloseHandle(hInet);
b := true;
end;
DownloadFile := b;
FFileSize := -1;
FDownloaded := 0;
end;
function TDBAppItem.GetRemoteFileSize(const Url: string): Integer;
const
sUserAgent = 'Mozilla/5.0 (Windows NT 6.1; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/75.0.3770.100 Safari/537.36';
var
hInet : HINTERNET;
hConnect : HINTERNET;
hRequest : HINTERNET;
lpdwBufferLength: DWORD;
lpdwReserved : DWORD;
ServerName, Resource: string;
// Prot, Host, User, Pass, Path, Extra: string;
ErrorCode : Cardinal;
begin
Result := -1;
ParseURL(Url, ServerName, Resource);
hInet := InternetOpen(PChar(sUserAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
if hInet=nil then
begin
ErrorCode:=GetLastError;
raise Exception.Create(Format('InternetOpen Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
end;
try
hConnect := InternetConnect(hInet, PChar(ServerName), INTERNET_DEFAULT_HTTP_PORT, nil, nil, INTERNET_SERVICE_HTTP, 0, 0);
if hConnect=nil then
begin
ErrorCode:=GetLastError;
raise Exception.Create(Format('InternetConnect Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
end;
try
hRequest := HttpOpenRequest(hConnect, PChar('HEAD'), PChar(Resource), nil, nil, nil, 0, 0);
if hRequest<>nil then
begin
try
lpdwBufferLength := SizeOf(Result);
lpdwReserved := 0;
if not HttpSendRequest(hRequest, nil, 0, nil, 0) then
begin
ErrorCode := GetLastError;
raise Exception.Create(Format('HttpOpenRequest Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
end;
if not HttpQueryInfo(hRequest, HTTP_QUERY_CONTENT_LENGTH or HTTP_QUERY_FLAG_NUMBER, #Result, lpdwBufferLength, lpdwReserved) then
begin
Result := 0;
ErrorCode := GetLastError;
raise Exception.Create(Format('HttpQueryInfo Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
end;
finally
InternetCloseHandle(hRequest);
end;
end
else
begin
ErrorCode:=GetLastError;
raise Exception.Create(Format('HttpOpenRequest Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
end;
finally
InternetCloseHandle(hConnect);
end;
finally
InternetCloseHandle(hInet);
end;
end;
function TDBAppItem.GetWinInetError(ErrorCode: Cardinal): string;
const
winetdll = 'wininet.dll';
var
Len: Integer;
Buffer: PChar;
begin
Len := FormatMessage(
FORMAT_MESSAGE_FROM_HMODULE or FORMAT_MESSAGE_FROM_SYSTEM or
FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_IGNORE_INSERTS or FORMAT_MESSAGE_ARGUMENT_ARRAY,
Pointer(GetModuleHandle(winetdll)), ErrorCode, 0, #Buffer, SizeOf(Buffer), nil);
try
while (Len > 0) and (CharInSet(Buffer[Len - 1], [#0..#32, '.'])) do Dec(Len);
SetString(Result, Buffer, Len);
finally
LocalFree(HLOCAL(Buffer));
end;
end;
procedure TDBAppItem.ParseURL(const lpszUrl: string; var Host,
Resource: string);
var
lpszScheme : array[0..INTERNET_MAX_SCHEME_LENGTH - 1] of Char;
lpszHostName : array[0..INTERNET_MAX_HOST_NAME_LENGTH - 1] of Char;
lpszUserName : array[0..INTERNET_MAX_USER_NAME_LENGTH - 1] of Char;
lpszPassword : array[0..INTERNET_MAX_PASSWORD_LENGTH - 1] of Char;
lpszUrlPath : array[0..INTERNET_MAX_PATH_LENGTH - 1] of Char;
lpszExtraInfo : array[0..1024 - 1] of Char;
lpUrlComponents : TURLComponents;
begin
ZeroMemory(#lpszScheme, SizeOf(lpszScheme));
ZeroMemory(#lpszHostName, SizeOf(lpszHostName));
ZeroMemory(#lpszUserName, SizeOf(lpszUserName));
ZeroMemory(#lpszPassword, SizeOf(lpszPassword));
ZeroMemory(#lpszUrlPath, SizeOf(lpszUrlPath));
ZeroMemory(#lpszExtraInfo, SizeOf(lpszExtraInfo));
ZeroMemory(#lpUrlComponents, SizeOf(TURLComponents));
lpUrlComponents.dwStructSize := SizeOf(TURLComponents);
lpUrlComponents.lpszScheme := lpszScheme;
lpUrlComponents.dwSchemeLength := SizeOf(lpszScheme);
lpUrlComponents.lpszHostName := lpszHostName;
lpUrlComponents.dwHostNameLength := SizeOf(lpszHostName);
lpUrlComponents.lpszUserName := lpszUserName;
lpUrlComponents.dwUserNameLength := SizeOf(lpszUserName);
lpUrlComponents.lpszPassword := lpszPassword;
lpUrlComponents.dwPasswordLength := SizeOf(lpszPassword);
lpUrlComponents.lpszUrlPath := lpszUrlPath;
lpUrlComponents.dwUrlPathLength := SizeOf(lpszUrlPath);
lpUrlComponents.lpszExtraInfo := lpszExtraInfo;
lpUrlComponents.dwExtraInfoLength := SizeOf(lpszExtraInfo);
InternetCrackUrl(PChar(lpszUrl), Length(lpszUrl), ICU_DECODE or ICU_ESCAPE, lpUrlComponents);
Host := lpszHostName;
Resource := lpszUrlPath;
end;
procedure TDBAppItem.InternalDownloadProgress(Sender: TObject; Read,
Total: Integer);
var
MsgRec : PProgressInfo;
begin
// Create progress changed message
New(MsgRec);
MsgRec^.ID := Fid;
MsgRec^.Read := Read;
MsgRec^.Total := Total;
MsgRec^.URL := FURL;
SendMessage(FHandle, WM_PROGRESSCHANGED, 0, LongInt(MsgRec));
end;
end.
My basic idea is creating pipeline with 2 stages:
Retrieve: downloading all files at the same time (threads count is constrained by NumTasks from OTL).
Install: As soon as any file be downloaded, it must be processed by this stage. Action in this stage must be one by one, i.e. only one action in same time (in real app I won't start many installers together).
I try to understand how OTL works here, but I have not many experience with this library yet.
So, dear community, how I must rewrite my code to:
Have parallel downloadings at Stage 1 (now it works one-by-one).
Have possibility to correctly stop Pipeline with GUI (now I call FPipeline.Cancel by TButton pressing and it cannot stop tasks immediately).
Sources also placed here.
Thanks in advance. I'll be glad meet any advice here.
1) Download works in parallel just fine - as far as OTL is concerned. On my machine the test app starts three parallel downloads each time I press F9. The other two downloads get stuck in the
hFile := InternetOpenURL(hInet, PChar(url), nil, 0, INTERNET_FLAG_PRAGMA_NOCACHE, 0);
call. IOW, all five downloader threads enter InternetOpenURL, but only three exit immediately and start downloading. I have no idea why (and it is related to WinINET, not OTL).
2) Cancellation doesn't work because noone tells the DownloadFile method to stop. IOmniPipeline.Cancel just calls CompleteAdding on each pipeline and tells each stage to stop processing input. It cannot stop the code which is already working on an input element (i.e. your DownloadFile method). You must do that yourself.
One way to do that is to create a global Cancel flag and change DownloadFile so that it checks whether this flag is set in the following loop:
repeat
InternetReadFile(hFile, #buffer, SizeOf(buffer), bytesRead);
BlockWrite(localFile, buffer, bytesRead);
Inc(FDownloaded, bytesRead);
//In real app this event occurs in TALWinHttpClient from Alcinoe library.
InternalDownloadProgress(Self, FDownloaded, FFileSize);
if FCancelled then break; // <-----------
until bytesRead = 0;
You could also change InternalDownloadProgress and add a var cancelled: boolean parameter which could be set in the event handler when the pipeline needs to shut down.

How to receive WM_POWERBROADCAST inside of a thread?

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.

How to run code in already running thread to safely send/recv data [TidTCPServer]

UPDATE Problem Still Exists.
Is it possible to run code in already running thread? for example:
thread1 is running some code & i want to run code from thread2 in thread1.
I want to run code in idTCPServer thread to send some data to client
Edit:
After research seems that my problem is that when Client data is received or is receiving same time another thread is trying to write to that socket.
Edit:
procedure TMainFrm.UserSRVExecute(AContext: TIdContext);
var
Command : String;
msSize : Int64;
ms : TMemoryStream;
decompressedMS : TMemoryStream;
H : TIdNotify;
begin
// Application.ProcessMessages;
Command := AContext.Connection.Socket.ReadLn;
// messagebox(0,'snd','',$40);
if logb then mainfrm.mconnections.Lines.Add(command + ' - BEGIN');
if Command <> '' then // keepalive
begin
//Application.ProcessMessages;
msSize := AContext.Connection.Socket.ReadInt64;
ms := TMemoryStream.Create;
decompressedMS := TMemoryStream.Create;
try
AContext.Connection.Socket.ReadStream(ms, msSize);
ms.Position := 0;
DecompressStream(MS,decompressedMS);
decompressedMS.Position := 0;
Client_ProcessData(AContext,Command,decompressedMS);
finally
ms.Free;
decompressedMS.Free;
if logb then mainfrm.mconnections.Lines.Add(command + ' - END');
end;
end;
end;
procedure Client_ProcessData(AContext: TIdContext; cmd : String; data : TMemoryStream);
var
Hnd : THandle;
clData : TStringArray;
TmpStr1 : String;
Tmp : String;
TN : TIdNotify;
Sync : TMySync;
I,I2 : Integer;
begin
Hnd := AContext.Connection.Socket.Binding.Handle;
if cmd = 'scr' then // RECEIVE COMMAND TO SEND TO CLIENT TO RECEIVE DATA FROM CLIENT
begin
Tmp := StreamToString(data);
{Sync := TMySync2.Create(True);
try
Sync.cmd := cmd;
Sync.hnd := Hnd;
Sync.tmp := TmpStr1;
Sync.Resume;
finally
//Sync.Free;
end; }
log('>>> CLFROMAS: '+IntToStr(HND)+':::'+cmd+':::');
// SendCMDToSocket(MainFrm.UserSRV,StrToInt(Trim(Tmp)),'scr'+IntToStr(Hnd));
I2 := StrToInt(Trim(Tmp));
for I := 0 to 100 do
if USRVData[i].hnd = I2 then
begin
// cs.Acquire;
USRVData[i].CTX.Connection.Socket.WriteLn('scr'+IntToStr(Hnd)); // PLACED ALL CONTEXTs IN GLOBAL VARIABLE + ALL SOCKET HANDLES. <--- HERE IS THE PROBLEM
// cs.Release;
Break;
end;
// log('>>> CLFROMAS: '+IntToStr(HND)+':::'+cmd+':::'+streamtostring(data));
Exit;
end;
if Copy(cmd,1,Length('scr4u')) = 'scr4u' then // RECEIVE DATA FROM CLIENT TO SEND IT TO ADMIN CLIENT REQUEST ABOVE
begin
if Length(cmd) > Length('scr4u') then
begin
Delete(cmd,1,Length('scr4u'));
Data.Position := 0;
{ Sync := TMySync.Create;
try
Sync.cmd := cmd;
Sync.hnd := Hnd;
Sync.data := TMemoryStream.Create;
Sync.data.CopyFrom(data,data.Size);
Sync.data.Position := 0;
Sync.DoNotify;
finally
Sync.data.Free;
Sync.Free;
end; }
SendStreamToSocket(MainFrm.UserSRV,strtoint(cmd),'scr4u',Data);
log('>>>>> ADMIN: '+IntToStr(HND)+':::'+cmd+':::'{+streamtostring(data)});
end else TmpStr1 := '';
Exit;
end;
...
UPDATE
procedure TMainFrm.UserSRVExecute(AContext: TIdContext);
var
Command : String;
msSize : Int64;
ms : TMemoryStream;
decompressedMS : TMemoryStream;
H : TIdNotify;
I : Integer;
List, Messages : TStringList;
begin
Messages := nil;
try
List := TMyContext(AContext).OutgoingMessages.Lock;
try
if List.Count > 0 then
begin
Messages := TStringList.Create;
Messages.Assign(List);
List.Clear;
end;
finally
TMyContext(AContext).OutgoingMessages.Unlock;
end;
if Messages <> nil then
begin
for I := 0 to Messages.Count-1 do
begin
AContext.Connection.IOHandler.WriteLn(Messages.Strings[I]);
end;
end;
finally
Messages.Free;
end;
if AContext.Connection.IOHandler.InputBufferIsEmpty then
begin
AContext.Connection.IOHandler.CheckForDataOnSource(100);
AContext.Connection.IOHandler.CheckForDisconnect;
if AContext.Connection.IOHandler.InputBufferIsEmpty then
Exit;
end;
Command := AContext.Connection.Socket.ReadLn;
if logb then mainfrm.mconnections.Lines.Add(command + ' - BEGIN');
if Command <> '' then
begin
msSize := AContext.Connection.Socket.ReadInt64;
ms := TMemoryStream.Create;
decompressedMS := TMemoryStream.Create;
try
AContext.Connection.Socket.ReadStream(ms, msSize);
ms.Position := 0;
DecompressStream(MS,decompressedMS);
decompressedMS.Position := 0;
Client_ProcessData(AContext,Command,decompressedMS);
finally
ms.Free;
decompressedMS.Free;
if logb then mainfrm.mconnections.Lines.Add(command + ' - END');
end;
end;
end;
Is it possible to run code in already running thread? for example: thread1 is running some code & i want to run code from thread2 in thread1.
No. Thread1 needs to be explicitly coded to stop what it is currently doing, do something else, and then go back to what it was previous doing. All Thread2 can do is signal Thread1 to perform that stop+continue at its earliest convenience.
I want to run code in idTCPServer thread to send some data to client
Your TIdTCPServer.OnExecute event handler needs to check for that data periodically and send it when it is available.
You can use the TIdContext.Data property, or derive a custom class from TIdServerContext and assign it to the TIdTCPServer.ContextClass property, to provide a per-client thread-safe buffer for your outbound data. Your OnExecute handler can then access that buffer when needed.
For example:
type
TMyContext = class(TIdServerContext)
public
constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil); override;
destructor Destroy; override;
OutgoingMessages: TIdThreadSafeStringList;
end;
constructor TMyContext.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil);
begin
inherited;
OutgoingMessages := TIdThreadSafeStringList.Create;
end;
destructor TMyContext.Destroy;
begin
OutgoingMessages.Free;
inherited;
end;
procedure TMyForm.FormCreate(Sender: TObject);
begin
// this must be set before activating the server...
IdTCPServer1.ContextClass := TMyContext;
end;
procedure TMyForm.IdTCPServer1Execute(AContext: TIdContext);
var
List, Messages: TStringList;
begin
// check for outgoing data...
Messages := nil;
try
List := TMyContext(AContext).OutgoingMessages.LockList;
try
if List.Count > 0 then
begin
Messages := TStringList.Create;
Messages.Assign(List);
List.Clear;
end;
finally
TMyContext(AContext).OutgoingMessages.UnlockList;
end;
if Messages <> nil then
begin
// send Messages using AContext.Connection.IOHandler as needed...
end;
finally
Messages.Free;
end;
// check for incoming data...
if AContext.Connection.IOHandler.InputBufferIsEmpty then
begin
AContext.Connection.IOHandler.CheckForDataOnSource(100);
AContext.Connection.IOHandler.CheckForDisconnect;
if AContext.Connection.IOHandler.InputBufferIsEmpty then
Exit;
end;
// process incoming data as needed...
end;
procedure TForm1.SomeProcedure;
var
List: TIdContextList;
Context: TMyContext;
begin
List := IdTCPServer1.Contexts.LockList;
try
Context := TMyContext(List[SomeIndex]);
Context.OutgoingMessages.Add('something');
finally
IdTCPServer1.Contexts.UnlockList;
end;
end;

Delphi TWSocket with Thread

When i used this code with button, it is ok... All sockets connected success. All events working. no problem (OnSessionClosed, OnSessionConnected, ...)
procedure TfrmMain.btnConnectClick(Sender: TObject);
var
I: Integer;
begin
for I := 0 to query.RecordCount - 1 do
begin
pUser[I] := TUser.Create();
pUser[I].Connect(frmMain.editEbenezerIP.Text);
pUser[I].run := False;
pUser[I].username := Trim(query.FieldByName('strAccountID').Text);
pUser[I].password := Trim(query.FieldByName('strPasswd').Text);
pUser[I].md5 := editMD5.Text;
pUser[I].Resume;
query.Next;
end;
end;
i created a thread to connect with sleep. (my thread TConnector).
All thread connected but OnSessionConnected event not working when i created with TConnector.
No problem with button to use create sockets.
procedure TUser.OnSessionConnected(Sender: TObject; ErrCode: Word);
begin
ShowMessage('Connection success!');
end;
procedure TUser.Connect(eip : string);
begin
Initialize;
socket := TWSocket.Create(nil);
socket.OnDataAvailable := OnDataAvailable;
socket.OnSessionConnected := OnSessionConnected;
socket.OnSessionClosed := OnSessionClosed;
socket.Connect;
end;
procedure TConnector.Execute;
var
I : Integer;
pUser : array [0..1500] of TUser;
begin
for I := 0 to frmMain.query.RecordCount - 1 do
begin
pUser[I] := TUser.Create();
pUser[I].run := False;
pUser[I].username := Trim(frmMain.query.FieldByName('strAccountID').Text);
pUser[I].password := Trim(frmMain.query.FieldByName('strPasswd').Text);
pUser[I].Connect(frmMain.editEbenezerIP.Text);
pUser[I].Resume;
frmMain.query.Next;
**Sleep(100);**
end;
end;
I fixed this problem with Synchronize(CreateUser);. Thanks for your answers
TConnector = class(TThread)
private
protected
procedure Execute; override;
public
strAccountID, strPasswd, MD5, eIP : string;
X : Integer;
constructor Create;
procedure CreateUser;
end;
procedure TConnector.CreateUser;
begin
Output(Format('Thread for %s',[strAccountID]));
frmMain.pUser[X] := TUser.Create();
frmMain.pUser[X].run := False;
frmMain.pUser[X].username := strAccountID;
frmMain.pUser[X].password := strPasswd;
frmMain.pUser[X].md5 := MD5;
frmMain.pUser[X].Connect(eIP, frmMain);
frmMain.pUser[X].Resume;
end;
procedure TConnector.Execute;
var
I : Integer;
begin
MD5 := frmMain.editMD5.Text;
eIP := frmMain.editEbenezerIP.Text;
for I := 0 to frmMain.query.RecordCount - 1 do
begin
X := I;
strAccountID := Trim(frmMain.query.FieldByName('strAccountID').Text);
strPasswd := Trim(frmMain.query.FieldByName('strPasswd').Text);
**Synchronize(CreateUser);**
Sleep(1000);
frmMain.query.Next;
end;
while(not Terminated)do
begin
Sleep(1000);
OutPut('test');
end;
end;
TWSocket uses a non-blocking socket and a hidden window for handling socket state updates asynchronously. As such, you need to give your thread a message loop. It works in a TButton.OnClick event because it is utilizing the main thread's existing message loop.
Edit: The simplest message loop involves calling Peek/GetMessage(), TranslateMessage(), and DispatchMessage() in a loop for the lifetime of the thread, so you need to add those function calls to your worker thread, eg:
procedure TConnector.Execute;
var
I : Integer;
pUser : array [0..1500] of TUser;
Msg: TMsg
begin
for I := 0 to frmMain.query.RecordCount - 1 do
begin
if Terminated then Break;
pUser[I] := TUser.Create();
pUser[I].run := False;
pUser[I].username := Trim(frmMain.query.FieldByName('strAccountID').Text);
pUser[I].password := Trim(frmMain.query.FieldByName('strPasswd').Text);
pUser[I].Connect(frmMain.editEbenezerIP.Text);
pUser[I].Resume;
frmMain.query.Next;
end;
while (GetMessage(Msg, 0, 0, 0) > 0) and (not Terminated) then
begin
TranslateMessage(msg);
DispatchMessage(msg);
end;
// perform cleanup here as needed...
end;
procedure TConnector.Stop;
begin
Terminate;
PostThreadMessage(ThreadID, WM_QUIT, 0, 0);
end;

Delphi: Multithreading, Thread safe not working

When data is sending to "tunnel" socket, it's sometimes merged, implemented the Critical Section but it's not working..
What I'm doing wrong ?
type
my_ff_thread = class;
my_ss_thread = class;
Tmy_tunnel_from_MappedPortTCP = class;
Tmy_thread_list = class
ff_id : string;
ff_connection : TIdTCPConnection;
constructor Create(local_ff_id: string; local_ss_c: TIdTCPConnection);
end;
Tmy_tunnel_from_MappedPortTCP = class(TIdBaseComponent)
protected
procedure InitComponent; override;
public
function my_connect:boolean;
end;
my_ff_thread = class(TThread)
protected
procedure Execute; override;
public
constructor Create;
end;
my_ss_thread = class(TThread)
protected
Fff_id : string;
Fff_cmd : string;
Fff_data : TIdBytes;
procedure Execute; override;
public
constructor Create(ff_id:string; ff_cmd:string; ff_data:TIdBytes);
function prepare_cmd(cmd:string; id:string; data:string):string;
function set_nulls_at_begin(s:string):string;
end;
var my_list : TThreadList;
CS: TRTLCriticalSection;
tunnel: TIdTCPConnection;
Implementation
constructor my_ff_thread.Create;
begin
inherited Create(True);
end;
constructor my_ss_thread.Create(ff_id:string; ff_cmd:string; ff_data:TIdBytes);
begin
inherited Create(True);
Fff_id := ff_id;
Fff_cmd := ff_cmd;
Fff_data := ff_data;
end;
constructor Tmy_thread_list.Create(local_ff_id: string; local_ss_c: TIdTCPConnection);
begin
ff_id := local_ff_id;
ff_connection := local_ss_c;
end;
function my_ss_thread.set_nulls_at_begin(s:string):string;
var len, i : integer;
res : string;
begin
if s='' then
begin
Result := '';
Exit;
end;
res := '';
len := Length(s);
if len < 10 then
for i:=1 to (10 - len) do
begin
res := res + '0';
end;
Result := res + s;
end;
function my_ss_thread.prepare_cmd(cmd:string; id:string; data:string):string;
var
packet : string;
begin
packet := set_nulls_at_begin(IntToStr(Length(cmd))) + cmd;
packet := packet + set_nulls_at_begin(IntToStr(Length(id))) + id;
packet := packet + set_nulls_at_begin(IntToStr(Length(data))) + data;
Result := packet;
end;
function del_ff_from_list(firefox_id:string):boolean;
var i : integer;
begin
Result := True;
try
with my_list.LockList do
begin
for i:=0 to Count-1 do
begin
if Tmy_thread_list(Items[i]).ff_id = firefox_id then
begin
Delete(i);
break;
end;
end;
end;
finally
my_list.UnlockList;
end;
end;
procedure my_ss_thread.Execute;
var ss : TIdTCPClient;
unix_time : integer;
data : TIdBytes;
packet : string;
packet_stream: TStringStream;
begin
ss := TIdTCPClient.Create(nil);
try
with TIdTcpClient(ss) do
begin
Host := '127.0.0.1';
Port := 6666;
ReadTimeout := 1000 * 5;
Connect;
end;
except
on E:Exception do
begin
ss.Disconnect;
exit;
end;
end;
try
my_list.LockList.Add(Tmy_thread_list.Create(Fff_id, ss));
finally
my_list.UnlockList;
end;
try
ss.Socket.Write(Fff_data);
except
on E:Exception do begin {Fmy_memo.Lines.Add('First data not sent!');} end;
end;
unix_time := DateTimeToUnix(NOW);
while True do
begin
ss.Socket.CheckForDataOnSource(5);
if not ss.Socket.InputBufferIsEmpty then
begin
SetLength(data, 0);
ss.Socket.InputBuffer.ExtractToBytes(data);
packet := prepare_cmd('data_from_ss', Fff_id, TIdEncoderMIME.EncodeBytes(data));
packet_stream := TStringStream.Create(packet);
packet_stream.Position := 0;
ss.Socket.InputBuffer.Clear;
unix_time := DateTimeToUnix(NOW);
try
EnterCriticalSection(CS);
tunnel.Socket.Write(packet_stream, -1, True);
LeaveCriticalSection(CS);
except
on E:Exception do
begin
end;
end;
end;
if (DateTimeToUnix(NOW) - unix_time) > 120 then
begin
ss.Disconnect;
break;
end;
if not ss.Connected then
begin
break;
end;
if not tunnel.Connected then
begin
ss.Disconnect;
break;
end;
end;
try
if tunnel.Connected then
begin
EnterCriticalSection(CS);
packet := prepare_cmd('disconnect', Fff_id, 'x');
packet_stream := TStringStream.Create(packet);
packet_stream.Position := 0;
tunnel.Socket.Write(packet_stream, -1, True);
LeaveCriticalSection(CS);
end;
except
on E:Exception do begin end;
end;
Terminate;
end;
procedure my_ff_thread.Execute;
var
t : my_ss_thread;
cmd, id : string;
i : integer;
found_ss : TIdTCPConnection;
list : TList;
packet : string;
cmd_len, id_len, data_len : integer;
data : TIdBytes;
orig_data : string;
packet_stream: TStringStream;
cmd_len_str, id_len_str, data_len_str : string;
begin
packet_stream := TStringStream.Create;
while not Terminated do
begin
packet_stream.Position := 0;
try
tunnel.Socket.ReadStream(packet_stream);
except
on E:Exception do begin end;
end;
packet := packet_stream.DataString;
if packet = '0000' then
continue;
try
cmd_len_str := Copy(packet, 1, 10);
cmd_len := StrToInt(cmd_len_str);
except
on E:Exception do begin end;
end;
Delete(packet, 1, 10);
cmd := Copy(packet, 1, cmd_len);
Delete(packet, 1, cmd_len);
try
id_len_str := Copy(packet, 1, 10);
id_len := StrToInt(id_len_str);
except
on E:Exception do begin end;
end;
Delete(packet, 1, 10);
id := Copy(packet, 1, id_len);
Delete(packet, 1, id_len);
SetLength(data, 0);
try
data_len_str := Copy(packet, 1, 10);
data_len := StrToInt(data_len_str);
except
on E:Exception do begin end;
end;
Delete(packet, 1, 10);
data := TIdDecoderMIME.DecodeBytes(Copy(packet, 1, data_len));
orig_data := Copy(packet, 1, data_len);
Delete(packet, 1, data_len);
found_ss := nil;
try
list := my_list.LockList;
for i:=0 to list.Count-1 do
begin
if Tmy_thread_list(list[i]).ff_id = id then
begin
found_ss := Tmy_thread_list(list[i]).ff_connection;
break;
end;
end;
finally
my_list.UnlockList;
end;
if cmd = 'disconnect' then
begin
if found_ss <> nil then
if found_ss.Connected then
begin
found_ss.Disconnect;
del_ff_from_list(id);
continue;
end;
end;
if found_ss = nil then
begin
t := my_ss_thread.Create(id, cmd, data);
t.Start;
end
else
begin
if found_ss <> nil then
try
if found_ss.Connected then
begin
found_ss.Socket.Write(data);
end;
except
on E:Exception do begin end;
end;
end;
if not tunnel.Connected then
begin
Terminate;
break;
end;
end;
end;
function Tmy_tunnel_from_MappedPortTCP.my_connect:boolean;
var t : my_ff_thread;
begin
Result := True;
try
with TIdTcpClient(tunnel) do
begin
Host := '192.168.0.157';
Port := 8099;
Connect;
end;
except
on E:Exception do
begin
tunnel.Disconnect;
exit;
end;
end;
t := my_ff_thread.Create;
t.Start;
end;
initialization
InitializeCriticalSection(CS);
my_list := TThreadList.Create;
tunnel := TIdTCPClient.Create(nil);
finalization
DeleteCriticalSection(CS);
end.
Try something like this:
type
my_ff_thread = class;
my_ss_thread = class;
Tmy_tunnel_from_MappedPortTCP = class;
Tmy_thread_list = class
public
ff_id : string;
ff_connection : TIdTCPConnection;
constructor Create(const local_ff_id: string; local_ss_c: TIdTCPConnection);
end;
Tmy_tunnel_from_MappedPortTCP = class(TIdBaseComponent)
protected
procedure InitComponent; override;
public
function my_connect: boolean;
function my_disconnect: boolean;
end;
my_ff_thread = class(TThread)
protected
procedure Execute; override;
public
constructor Create;
end;
my_ss_thread = class(TThread)
protected
Fff_id : string;
Fff_cmd : string;
Fff_data : TIdBytes;
procedure Execute; override;
public
constructor Create(const ff_id, ff_cmd: string; const ff_data: TIdBytes);
end;
var
my_list : TThreadList = nil;
CS: TCriticalSection = nil;
tunnel: TIdTCPClient = nil;
tunnel_thread: my_ff_thread = nil;
implementation
constructor Tmy_thread_list.Create(const local_ff_id: string; local_ss_c: TIdTCPConnection);
begin
ff_id := local_ff_id;
ff_connection := local_ss_c;
end;
constructor my_ss_thread.Create(const ff_id, ff_cmd: string; const ff_data: TIdBytes);
begin
inherited Create(False);
Fff_id := ff_id;
Fff_cmd := ff_cmd;
Fff_data := Copy(ff_data, 0, Length(ff_data));
end;
procedure my_ss_thread.Execute;
var
ss : TIdTCPClient;
data : TIdBytes;
packet : string;
procedure WriteStrToStream(strm: TStream; const s: String);
var
buf: TIdBytes;
len: Integer;
begin
buf := ToBytes(s, IndyUTF8Encoding);
len := Length(buf);
strm.WriteBuffer(len, SizeOf(Integer));
if bytes <> nil then
strm.WriteBuffer(buf[0], len);
end;
procedure WritePacketToTunnel(const cmd: string; const bytes: TIdBytes = nil);
var
strm: TMemoryStream;
begin
strm := TMemoryStream.Create;
try
WriteStrToStream(strm, cmd);
WriteStrToStream(strm, Fff_id);
WriteStrToStream(strm, TIdEncoderMIME.EncodeBytes(bytes));
CS.Enter;
try
tunnel.IOHandler.Write(strm, 0, True);
finally
CS.Leave;
end;
finally
strm.Free;
end;
end;
begin
ss := TIdTCPClient.Create(nil);
try
ss.Host := '127.0.0.1';
ss.Port := 6666;
ss.ReadTimeout := 1000 * 120;
ss.Connect;
try
my_list.Add(Tmy_thread_list.Create(Fff_id, ss));
try
ss.IOHandler.Write(Fff_data);
except
{Fmy_memo.Lines.Add('First data not sent!');}
raise;
end;
while not Terminated do
begin
SetLength(data, 0);
ss.IOHandler.ReadBytes(data, -1);
if Length(data) = 0 then
break;
WritePacketToTunnel('data_from_ss', data);
end;
WritePacketToTunnel('disconnect');
finally
ss.Disconnect;
end;
finally
ss.Free;
end;
end;
constructor my_ff_thread.Create;
begin
inherited Create(False);
end;
procedure my_ff_thread.Execute;
var
cmd, id : string;
data : TIdBytes;
i : integer;
found_ss : TIdTCPConnection;
list : TList;
function ReadStrFromStream(strm: TStream): string;
var
len: Integer;
begin
strm.ReadBuffer(len, SizeOf(Integer));
if len > 0 then
Result := IdGlobal.ReadStringFromStream(strm, len, IndyUTF8Encoding)
else
Result := '';
end;
procedure ReadPacketFromTunnel(var v_cmd, v_id: string; var v_data: TIdBytes);
var
strm: TMemoryStream;
begin
strm := TMemoryStream.Create;
try
tunnel.IOHandler.ReadStream(strm, -1, False);
strm.Position := 0;
v_cmd := ReadStrFromStream(strm);
v_id := ReadStrFromStream(strm);
v_data := TIdDecoderMIME.DecodeBytes(ReadStrFromStream(strm));
finally
strm.Free;
end;
end;
begin
while not Terminated do
begin
ReadPacketFromTunnel(cmd, id, data);
found_ss := nil;
list := my_list.LockList;
try
for i := 0 to list.Count-1 do
begin
if Tmy_thread_list(list[i]).ff_id = id then
begin
found_ss := Tmy_thread_list(list[i]).ff_connection;
break;
end;
end;
finally
my_list.UnlockList;
end;
if cmd = 'disconnect' then
begin
if found_ss <> nil then
found_ss.Disconnect;
del_ff_from_list(id);
continue;
end;
if found_ss <> nil then
begin
try
found_ss.IOHandler.Write(data);
except
end;
Continue;
end;
my_ss_thread.Create(id, cmd, data);
end;
end;
function Tmy_tunnel_from_MappedPortTCP.my_connect: boolean;
begin
Result := True;
try
tunnel.Host := '192.168.0.157';
tunnel.Port := 8099;
tunnel.Connect;
tunnel_thread := my_ff_thread.Create(tunnel);
except
tunnel.Disconnect;
Result := False;
end;
end;
function Tmy_tunnel_from_MappedPortTCP.my_disconnect: boolean;
begin
Result := True;
try
if tunnel_thread <> nil then tunnel_thread.Terminate;
try
tunnel.Disconnect;
finally
if tunnel_thread <> nil then
begin
tunnel_thread.WaitFor;
FreeAnNil(tunnel_thread);
end;
end;
except
Result := False;
end;
end;
initialization
CS := TCriticalSection.Create;
my_list := TThreadList.Create;
tunnel := TIdTCPClient.Create(nil);
finalization
tunnel.Free;
my_list.Free;
CS.Free;
end.

Resources