Delphi XE4 - get your local IP in statusbar - delphi-xe4

Seen most of the examples posted here but none seem to work on XE4. I am trying to display my IP in the status bar.
AdvOfficeStatusBar1.Panels[0].Text := GetIP;
Functions I have seen here mostly fail on xe4 as they were written in older delphi versions.I would like to get just the local IP,not the one behind the router. Well, for the sake of learning, it would be usefull to know that one too...:)
I tried this :
function getIP: string;
type
TaPInAddr = array [0..10] of PInAddr;
PaPInAddr = ^TaPInAddr;
var
phe: PHostEnt;
pptr: PaPInAddr;
Buffer: array [0..63] of char;
i: Integer;
GInitData: TWSADATA;
begin
WSAStartup($101, GInitData);
Result := '';
GetHostName(Buffer, SizeOf(Buffer));
phe :=GetHostByName(buffer);
if phe = nil then Exit;
pptr := PaPInAddr(Phe^.h_addr_list);
i := 0;
while pptr^[i] <> nil do
begin
result:=StrPas(inet_ntoa(pptr^[i]^));
Inc(i);
end;
WSACleanup;
end;
but it would not work .... many others too ... Seems i am missing something,but what?
Tried this too :
function getIPs: Tstrings;
type
TaPInAddr = array[0..10] of PInAddr;
PaPInAddr = ^TaPInAddr;
var
phe: PHostEnt;
pptr: PaPInAddr;
Buffer: array[0..63] of Char;
I: Integer;
GInitData: TWSAData;
begin
WSAStartup($101, GInitData);
Result := TstringList.Create;
Result.Clear;
GetHostName(Buffer, SizeOf(Buffer));
phe := GetHostByName(buffer);
if phe = nil then Exit;
pPtr := PaPInAddr(phe^.h_addr_list);
I := 0;
while pPtr^[I] <> nil do
begin
Result.Add(inet_ntoa(pptr^[I]^));
Inc(I);
end;
WSACleanup;
end;
wont work stops on : (GetHostName(Buffer, SizeOf(Buffer));
This however WORKS ! :
Function GetIPAddress: String;
type pu_long = ^u_long;
var varTWSAData : TWSAData;
varPHostEnt : PHostEnt;
varTInAddr : TInAddr;
namebuf : Array[0..255] of ansichar;
begin
try
try
If WSAStartup($101,varTWSAData) <> 0 Then
Result := ''
Else Begin
gethostname(namebuf,sizeof(namebuf));
varPHostEnt := gethostbyname(namebuf);
varTInAddr.S_addr := u_long(pu_long(varPHostEnt^.h_addr_list^)^);
Result := inet_ntoa(varTInAddr);
End;
except
Result := '';
end;
finally
WSACleanup;
end;
end;

Function GetIPAddress: String;
type pu_long = ^u_long;
var varTWSAData : TWSAData;
varPHostEnt : PHostEnt;
varTInAddr : TInAddr;
namebuf : Array[0..255] of ansichar;
begin
try
try
If WSAStartup($101,varTWSAData) <> 0 Then
Result := ''
Else Begin
gethostname(namebuf,sizeof(namebuf));
varPHostEnt := gethostbyname(namebuf);
varTInAddr.S_addr := u_long(pu_long(varPHostEnt^.h_addr_list^)^);
Result := inet_ntoa(varTInAddr);
End;
except
Result := '';
end;
finally
WSACleanup;
end;
end;

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.

Error to receive file on socket inside a thread

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.

How to send records containing strings between applications

So, I have a class that uses WM_COPYDATA to allow applications to communicate.
type
TMyRec = record
Name: string[255]; // I want just string
Age: integer;
Birthday: TDateTime;
end;
function TAppCommunication.SendRecord(const ARecordType: ShortString; const ARecordToSend: Pointer; ARecordSize: Integer): Boolean;
var
_Stream: TMemoryStream;
begin
_Stream := TMemoryStream.Create;
try
_Stream.WriteBuffer(ARecordType, 1 + Length(ARecordType));
_Stream.WriteBuffer(ARecordToSend^, ARecordSize);
_Stream.Position := 0;
Result := SendStreamData(_Stream, TCopyDataType.cdtRecord);
finally
FreeAndNil(_Stream);
end;
end;
function TAppCommunication.SendStreamData(const AStream: TMemoryStream;
const ADataType: TCopyDataType): Boolean;
var
_CopyDataStruct: TCopyDataStruct;
begin
Result := False;
if AStream.Size = 0 then
Exit;
_CopyDataStruct.dwData := integer(ADataType);
_CopyDataStruct.cbData := AStream.Size;
_CopyDataStruct.lpData := AStream.Memory;
Result := SendData(_CopyDataStruct);
end;
function TAppCommunication.SendData(const ADataToSend: TCopyDataStruct)
: Boolean;
var
_SendResponse: integer;
_ReceiverHandle: THandle;
begin
Result := False;
_ReceiverHandle := GetRemoteReceiverHandle;
if (_ReceiverHandle = 0) then
Exit;
_SendResponse := SendMessage(_ReceiverHandle, WM_COPYDATA,
WPARAM(FLocalReceiverForm.Handle), LPARAM(#ADataToSend));
Result := _SendResponse <> 0;
end;
Sender application:
procedure TSenderMainForm.BitBtn1Click(Sender: TObject);
var
_AppCommunication: TAppCommunication;
_ms: TMemoryStream;
_Rec: TMyRec;
_Record: TAttrData;
begin
_AppCommunication := TAppCommunication.Create('LocalReceiverName', OnAppMessageReceived);
_ms := TMemoryStream.Create;
try
_AppCommunication.SetRemoteReceiverName('LocalReceiverNameServer');
_AppCommunication.SendString('ąčęėįšųūž123');
_AppCommunication.SendInteger(998);
_AppCommunication.SendDouble(0.95);
_Rec.Name := 'Edijs';
_Rec.Age := 29;
_Rec.Birthday := EncodeDate(1988, 10, 06);
_Record.Len := 1988;
_AppCommunication.SendRecord(TTypeInfo(System.TypeInfo(TMyRec)^).Name, #_Rec, SizeOf(_Rec));
finally
FreeAndNil(_ms);
FreeAndNil(_AppCommunication);
end;
end;
Receiver app:
procedure TReceiverMainForm.OnAppMessageReceived(const ASender
: TPair<HWND, string>; const AReceivedData: TCopyDataStruct;
var AResult: integer);
var
_MyRec: TMyRec;
_RecType: ShortString;
_RecData: Pointer;
begin
...
else
begin
if (AReceivedData.dwData) = Ord(TCopyDataType.cdtRecord) then
begin
_RecType := PShortString(AReceivedData.lpData)^;
_RecData := PByte(AReceivedData.lpData)+1+Length(_RecType);
if (_RecType = TTypeInfo(System.TypeInfo(TMyRec)^).Name) then
begin
_MyRec := TMyRec(_RecData^);
ShowMessage(_MyRec.Name + ', Age: ' + IntToStr(_MyRec.Age) + ', birthday: ' +
DateToStr(_MyRec.Birthday));
end;
end;
AResult := -1;
end;
end;
The problem is that crash occur when I change Name: string[255]; to Name: string; in TMyRec. How do I overcome this? I do not want to edit all my records to change string to something else and I want to have one function to send all kind of records (as far as my idea goes none of them will contain objects).
EDITED:
Used answer provided by Remy and made some tweaks so I would by able to send any kind of record using only one SendRecord function:
function TAppCommunication.SendRecord(const ARecordToSend, ARecordTypInfo: Pointer): Boolean;
var
_Stream: TMemoryStream;
_RType: TRTTIType;
_RFields: TArray<TRttiField>;
i: Integer;
begin
_Stream := TMemoryStream.Create;
try
_RType := TRTTIContext.Create.GetType(ARecordTypInfo);
_Stream.WriteString(_RType.ToString);
_RFields := _RType.GetFields;
for i := 0 to High(_RFields) do
begin
if _RFields[i].FieldType.TypeKind = TTypeKind.tkUString then
_Stream.WriteString(_RFields[i].GetValue(ARecordToSend).ToString)
else if _RFields[i].FieldType.TypeKind = TTypeKind.tkInteger then
_Stream.WriteInteger(_RFields[i].GetValue(ARecordToSend).AsType<integer>)
else if _RFields[i].FieldType.TypeKind = TTypeKind.tkFloat then
_Stream.WriteDouble(_RFields[i].GetValue(ARecordToSend).AsType<Double>)
end;
_Stream.Position := 0;
Result := SendStreamData(_Stream, TCopyDataType.cdtRecord);
finally
FreeAndNil(_Stream);
end;
end;
Sender:
_AppCommunication.SendRecord(#_Rec, System.TypeInfo(TMyRec));
A ShortString has a fixed size of 256 bytes max (1 byte length + up to 255 AnsiChars), so it is easy to embed in records and send as-is.
A String, on the other hand, is a pointer to dynamically allocated memory for an array of Chars. So, it requires a little more work to serialize back and forth.
To do what you are asking, you can't simply replace ShortString with String without also changing everything else in between to account for that difference.
You already have the basic framework to send variable-length strings (send the length before sending the data), so you can expand on that to handle string values, eg:
type
TMyRec = record
Name: string;
Age: integer;
Birthday: TDateTime;
end;
TStreamHelper = class helper for TStream
public
function ReadInteger: Integer;
function ReadDouble: Double;
function ReadString: String;
...
procedure WriteInteger(Value: Integer);
procedure WriteDouble(Strm: Value: Double);
procedure WriteString(const Value: String);
end;
function TStreamHelper.ReadInteger: Integer;
begin
Self.ReadBuffer(Result, SizeOf(Integer));
end;
function TStreamHelper.ReadDouble: Double;
begin
Self.ReadBuffer(Result, SizeOf(Double));
end;
function TStreamHelper.ReadString: String;
var
_Bytes: TBytes;
_Len: Integer;
begin
_Len := ReadInteger;
SetLength(_Bytes, _Len);
Self.ReadBuffer(PByte(_Bytes)^, _Len);
Result := TEncoding.UTF8.GetString(_Bytes);
end;
...
procedure TStreamHelper.WriteInteger(Value: Integer);
begin
Self.WriteBuffer(Value, SizeOf(Value));
end;
procedure TStreamHelper.WriteDouble(Value: Double);
begin
Self.WriteBuffer(Value, SizeOf(Value));
end;
procedure TStreamHelper.WriteString(const Value: String);
var
_Bytes: TBytes;
_Len: Integer;
begin
_Bytes := TEncoding.UTF8.GetBytes(Value);
_Len := Length(_Bytes);
WriteInteger(_Len);
Self.WriteBuffer(PByte(_Bytes)^, _Len);
end;
function TAppCommunication.SendRecord(const ARecord: TMyRec): Boolean;
var
_Stream: TMemoryStream;
begin
_Stream := TMemoryStream.Create;
try
_Stream.WriteString('TMyRec');
_Stream.WriteString(ARecord.Name);
_Stream.WriteInteger(ARecord.Age);
_Stream.WriteDouble(ARecord.Birthday);
_Stream.Position := 0;
Result := SendStreamData(_Stream, TCopyDataType.cdtRecord);
finally
FreeAndNil(_Stream);
end;
end;
// more overloads of SendRecord()
// for other kinds of records as needed...
procedure TSenderMainForm.BitBtn1Click(Sender: TObject);
var
...
_Rec: TMyRec;
begin
...
_Rec.Name := 'Edijs';
_Rec.Age := 29;
_Rec.Birthday := EncodeDate(1988, 10, 06);
_AppCommunication.SendRecord(_Rec);
...
end;
type
TReadOnlyMemoryStream = class(TCustomMemoryStream)
public
constructor Create(APtr: Pointer; ASize: NativeInt);
function Write(const Buffer; Count: Longint): Longint; override;
end;
constructor TReadOnlyMemoryStream.Create(APtr: Pointer; ASize: NativeInt);
begin
inherited Create;
SetPointer(APtr, ASize);
end;
function TReadOnlyMemoryStream.Write(const Buffer; Count: Longint): Longint;
begin
Result := 0;
end;
procedure TReceiverMainForm.OnAppMessageReceived(const ASender : TPair<HWND, string>; const AReceivedData: TCopyDataStruct; var AResult: integer);
var
...
_Stream: TReadOnlyMemoryStream;
_MyRec: TMyRec;
_RecType: String;
begin
...
else
begin
if (AReceivedData.dwData = Ord(TCopyDataType.cdtRecord)) then
begin
_Stream := TReadOnlyMemoryStream(AReceivedData.lpData, AReceivedData.cbData);
try
_RecType := _Stream.ReadString;
if (_RecType = 'TMyRec') then
begin
_MyRec.Name := _Stream.ReadString;
_MyRec.Age := _Stream.ReadInteger;
_MyRec.Birthday := _Stream.ReadDouble;
ShowMessage(_MyRec.Name + ', Age: ' + IntToStr(_MyRec.Age) + ', birthday: ' + DateToStr(_MyRec.Birthday));
end;
finally
_Stream.Free;
end;
end;
AResult := -1;
end;
end;

How to Stop all Pipeline tasks correctly

how to stop Pipleline tasks correctly, I've tried but when i press Abort button i get an AV, i'm not too good at debugging,i have reached to DoOnStop(task); in OtlParallel then i couldn't figure out what to do next, i believe there is something missing ?
type
procedure SetInProcess(const Value: Boolean);
private
FInProcess: Boolean;
property inProcess: Boolean read FInProcess write SetInProcess;
public
FStopAll: Boolean;
procedure FlushData;
procedure Retriever(const input: TOmniValue; var output: TOmniValue);
...
procedure TForm1.SetInProcess(const Value: Boolean);
var
I: Integer;
begin
if Value = InProcess then exit;
memo1.ReadOnly := Value;
FInProcess := Value;
if Value then
Memo1.Lines.Clear;
Timer1.Enabled := Value;
If not Value then
begin
FlushData;
pipeline := nil;
end;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
If not InProcess then exit;
FlushData;
if Pipeline.Output.IsFinalized then
InProcess := False;
end;
procedure TForm1.StartButton(Sender: TObject);
var
i : integer;
urlList : TStrings;
U, S : string;
value : TOmniValue;
begin
urlList := Memo2.Lines;
pipeline := Parallel.Pipeline;
pipeline.Stage(Retriver).NumTasks(StrToInt(Edit12.Text)).Run;
for U in urlList do
pipeline.Input.Add(U);
pipeline.Input.CompleteAdding;
inProcess := True;
end;
procedure TForm1.FlushData;
var v: TOmniValue;
begin
if pipeline = nil then exit;
if pipeline.Output = nil then exit;
Memo1.Lines.BeginUpdate;
try
while pipeline.Output.TryTake(v) do
Memo1.Lines.Add(v.AsString);
if FStopAll then
begin
Pipeline.Cancel;
end;
Memo1.Lines.EndUpdate;
except
on E: Exception do
begin
Memo1.Lines.Add(E.Message);
end;
end;
Memo1.Lines.EndUpdate;
end;
procedure TForm1.Retriver(const input: TOmniValue; var output: TOmniValue);
var
lHTTP : TIdHTTP;
Params : TStrings;
Reply,String1,String2 : string;
begin
X := Input.AsString;
Params := TStringList.Create;
string1 := Extract1(X);
string2 := Extract2(X);;
Params.Add('username=' + string1);
Params.Add('password=' + string2);
lHTTP := TIdHTTP.Create(nil);
try
...
Reply := lHTTP.Post('https://www.instagram.com/accounts/login/ajax/', Params);
if AnsiContainsStr(Reply, 'no')
then
begin
Alive.Add(string1+string2+' Client ok'); ///Alive is Global Var stringlist created earlier
end;
except
on E: EIdHTTPProtocolException do
Exit
end;
lHTTP.Free;
end;
procedure TForm1.AbortButton(Sender: TObject);
begin
try
FStopAll := False;
finally
FStopAll := True;
end;
end;
In your case of over-simplified one-stage pipeline suffice would be moving check into the worker stage itself.
procedure Retriever(const input: TOmniValue; var output: TOmniValue);
var
....
begin
if FStopAll then exit;
X := Input.AsString;
....
PS. I want to repeat that your code leaks memory badly, and that you ignored all my notes I stated before.
PPS. This code not also makes little sense (there is not point in flip-vloppign the variable to one value then to another) but is syntactically incorrect and would not compile. Thus it is not the same code you actually run. It is some different code.
procedure TForm1.AbortButton(Sender: TObject);
begin
try
FStopAll := False;
finally
FStopAll := True;
end;
end;

In Delphi can a string be converted to a set

For instance
Font.Style = StringToSet('[fsBold, fsUnderline]');
of course there would need to be some typeinfo stuff in there, but you get the idea. I'm using Delphi 2007.
check this code, is not exactly the same syntax which you propose , but works setting the value of a set from a string.
uses
TypInfo;
procedure StringToSet(Const Values,AProperty:string;Instance: TObject);
begin
if Assigned(GetPropInfo(Instance.ClassInfo, AProperty)) then
SetSetProp(Instance,AProperty,Values);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
StringToSet('[fsBold, fsUnderline, fsStrikeOut]','Style',Label1.Font);
end;
Also see my old post: SetToString, StringToSet for a solution (Delphi 2007, IIRC) without a need for published property RTTI:
uses
SysUtils, TypInfo;
function GetOrdValue(Info: PTypeInfo; const SetParam): Integer;
begin
Result := 0;
case GetTypeData(Info)^.OrdType of
otSByte, otUByte:
Result := Byte(SetParam);
otSWord, otUWord:
Result := Word(SetParam);
otSLong, otULong:
Result := Integer(SetParam);
end;
end;
procedure SetOrdValue(Info: PTypeInfo; var SetParam; Value: Integer);
begin
case GetTypeData(Info)^.OrdType of
otSByte, otUByte:
Byte(SetParam) := Value;
otSWord, otUWord:
Word(SetParam) := Value;
otSLong, otULong:
Integer(SetParam) := Value;
end;
end;
function SetToString(Info: PTypeInfo; const SetParam; Brackets: Boolean): AnsiString;
var
S: TIntegerSet;
TypeInfo: PTypeInfo;
I: Integer;
begin
Result := '';
Integer(S) := GetOrdValue(Info, SetParam);
TypeInfo := GetTypeData(Info)^.CompType^;
for I := 0 to SizeOf(Integer) * 8 - 1 do
if I in S then
begin
if Result <> '' then
Result := Result + ',';
Result := Result + GetEnumName(TypeInfo, I);
end;
if Brackets then
Result := '[' + Result + ']';
end;
procedure StringToSet(Info: PTypeInfo; var SetParam; const Value: AnsiString);
var
P: PAnsiChar;
EnumInfo: PTypeInfo;
EnumName: AnsiString;
EnumValue, SetValue: Longint;
function NextWord(var P: PAnsiChar): AnsiString;
var
I: Integer;
begin
I := 0;
// scan til whitespace
while not (P[I] in [',', ' ', #0,']']) do
Inc(I);
SetString(Result, P, I);
// skip whitespace
while P[I] in [',', ' ',']'] do
Inc(I);
Inc(P, I);
end;
begin
SetOrdValue(Info, SetParam, 0);
if Value = '' then
Exit;
SetValue := 0;
P := PAnsiChar(Value);
// skip leading bracket and whitespace
while P^ in ['[',' '] do
Inc(P);
EnumInfo := GetTypeData(Info)^.CompType^;
EnumName := NextWord(P);
while EnumName <> '' do
begin
EnumValue := GetEnumValue(EnumInfo, EnumName);
if EnumValue < 0 then
begin
SetOrdValue(Info, SetParam, 0);
Exit;
end;
Include(TIntegerSet(SetValue), EnumValue);
EnumName := NextWord(P);
end;
SetOrdValue(Info, SetParam, SetValue);
end;
Example usage:
var
A: TAlignSet;
S: AnsiString;
begin
// set to string
A := [alClient, alLeft, alTop];
S := SetToString(TypeInfo(TAlignSet), A, True);
ShowMessage(Format('%s ($%x)', [S, Byte(A)]));
// string to set
S := '[alNone, alRight, alCustom]';
StringToSet(TypeInfo(TAlignSet), A, S);
ShowMessage(Format('%s ($%x)', [SetToString(TypeInfo(TAlignSet), A, True), Byte(A)]));
end;
You have right function name already - StringToSet. However, usage is tricky:
procedure TForm1.FormClick(Sender: TObject);
type PFontStyles = ^TFontStyles; // typecast helper declaration
var Styles: Integer; // receives set bitmap after parsing
{$IF SizeOf(TFontStyles) > SizeOf(Integer)}
{$MESSAGE FATAL 'Panic. RTTI functions will work with register-sized sets only'}
{$IFEND}
begin
Styles := StringToSet( // don't forget to use TypInfo (3)
PTypeInfo(TypeInfo(TFontStyles)), // this kludge is required for overload (1)
'[fsBold, fsUnderline]'
);
Font.Style := PFontStyles(#Styles)^; // hack to bypass strict typecast rules (2)
Update(); // let form select amended font into Canvas
Canvas.TextOut(0, 0, 'ME BOLD! ME UNDERLINED!');
end;
(1) because initially borland limited this function family to PropInfo pointers and TypeInfo() intrinsic returns untyped pointer, hence the typecast
(2) typecasting requires types to be of same size, hence the referencing and dereferencing to different type (TFontStyles is a Byte)
Nitpicker special: (3) This snippet works out of the box in D2010+. Earlier versions has required dependency missing - namely StringToSet(TypeInfo: PTypeInfo; ... overload (see docwiki link above). This problem is solvable by copypasting (yeah, but TTypeInfo is lower-level than TPropInfo) original function and doing 2 (two) minor edits. By obvious reasons i'm not going to publish copyrighted code, but here is the relevant diff:
1c1,2
< function StringToSet(PropInfo: PPropInfo; const Value: string): Integer;
---
> {$IF RTLVersion < 21.0}
> function StringToSet(TypeInfo: PTypeInfo; const Value: string): Integer; overload;
37c38
< EnumInfo := GetTypeData(PropInfo^.PropType^)^.CompType^;
---
> EnumInfo := GetTypeData(TypeInfo)^.CompType^;
47a49
> {$IFEND}

Resources