How to avoid freezing the idHTTP when the internet become slower or no connectivity. My application get freeze and I could not even close the form.
This is how I setup my code
procedure TDownloader.IdHTTPWork(ASender: TObject; AWorkMode: TWorkMode;
AWorkCount: Int64);
var
lwElapsedMS: LongWord;
iBytesTransferred: Int64;
iBytesPerSec: Int64;
iRemaining: Integer;
begin
if AWorkMode <> wmRead then Exit;
lwElapsedMS := GetTickDiff(FLastTicks, Ticks);
if lwElapsedMS = 0 then lwElapsedMS := 1; // avoid EDivByZero error
if FTotalBytes > 0 then
FPercentDone := Round(AWorkCount / FTotalBytes * 100.0)
else
FPercentDone := 0;
iBytesTransferred := AWorkCount - FLastWorkCount;
iBytesPerSec := Round(iBytesTransferred * 1000 / lwElapsedMS);
if Assigned(OnDownloadProgress) then
begin
if FContinueDownload <> 0 then //previous file downloaded
begin
iRemaining := 100 - FContinueDownload;
iRemaining := Round(FPercentDone * iRemaining / 100);
OnDownloadProgress(Self, FContinueDownload + iRemaining, AWorkCount, FTotalBytes, iBytesPerSec);
end else
OnDownloadProgress(Self, FPercentDone, AWorkCount, FTotalBytes, iBytesPerSec);
end;
FLastWorkCount := AWorkCount;
FLastTicks := Ticks;
if FCancel then
begin
Abort;
TidHttp(ASender).Disconnect;
end;
end;
procedure TDownloader.IdHTTPWorkBegin(ASender: TObject; AWorkMode: TWorkMode;
AWorkCountMax: Int64);
begin
if AWorkMode <> wmRead then Exit;
FPercentDone := 0;
FTotalBytes := AWorkCountMax;
FLastWorkCount := 0;
FLastTicks := Ticks;
end;
procedure TDownloader.IdHTTPWorkEnd(ASender: TObject; AWorkMode: TWorkMode);
begin
if AWorkMode <> wmRead then Exit;
if Assigned(OnDownloadComplete) and (FPercentDone >= 100) then
OnDownloadComplete(Self)
else if Assigned(OnDownloadCancel) then
OnDownloadCancel(Self);
end;
function TDownloader.EXDownload(AURL, ADestFile: String;
AAutoDisconnect: Boolean): Boolean;
var
fsBuffer: TFileStream;
idHttp: TIdHttp;
begin
if FileExists(ADestFile) then
fsBuffer := TFileStream.Create(ADestFile, fmOpenReadWrite)
else
fsBuffer := TFileStream.Create(ADestFile, fmCreate);
fsBuffer.Seek(0, soFromEnd);
try
idHttp := TIdHttp.Create(nil);
idHttp.OnWorkBegin := idHttpWorkBegin;
idHttp.OnWork := idHttpWork;
idHttp.OnWorkEnd := idHttpWorkEnd;
idHttp.Request.CacheControl := 'no-store';
try
...
idHttp.Get(AURL, fsBuffer);
...
finally
idHttp.Free;
end;
finally
fsBuffer.Free;
end;
end;
......
procedure TDownloader.Execute;
begin
Inherited;
while not Terminated do
begin
if FUrl <> '' then
begin
EXDownload(FUrl, FFilename, True);
end;
end;
end;
...
on the main form progress
procedure TfrmDownloadList.DownloadProgress(Sender: TObject; aPercent:Integer;
aProgress, aProgressMax, aBytesPerSec: Int64);
var
yts: PYoutubeSearchInfo;
begin
if Assigned(FCurrentDownload) then
begin
yts := vstList.GetNodeData(FCurrentDownload);
yts.Tag := aPercent;
ProgressBar.Position := aPercent;
vstList.InvalidateNode(FCurrentDownload);
StatusBar.Panels.Items[1].Text := 'Download: ' + FormatByteSize(aProgress) + '/' +
FormatByteSize(aProgressMax);
StatusBar.Panels.Items[2].Text := 'Speed: ' + FormatByteSize(aBytesPerSec) + 'ps';
Application.ProcessMessages;
end;
end;
I don't have problem when the internet is good only when it drops due to poor signal.
this is my app lookslike
If we assume that TDownloader.OnDownloadProgress is assigned to the TfrmDownloadList.DownloadProgress method, then your problem is that you are calling VCL code (your update of the progress bar) from a secondary thread (ie. not from the Main thread). This is not supported.
You'll need to wrap the call with a Synchronize statement from within your thread. Synchronize calls a parameterless method on the main thread. So you need to store the variables that are needed and then call Synchronize on a method in your TDownloader class that then calls on to TfrmDownloadList.DownloadProgress
You cannot call TfrmDownloadList.DownloadProgress directly or indirectly from within code that runs on another thread than the main thread, as it updates VCL objects, and the VCL is not thread-safe.
The same goes for your DownloadComplete event, if it updates any VCL objects...
How about you using TIdAntiFreeze ?
TIdAntiFreeze implements a GUI-integration class that ensures
processor time is allocated for the Application main thread.
Indy works on the blocking sockets model. Calls made to methods in the
Indy components do not return until they are complete. If calls are
made in the main thread, this will cause the Application User
Interface to "freeze" during Indy calls. TIdAntiFreeze counteracts
this effect.
TIdAntiFreeze allows Indy to process Application messages so that
Windows messages continue to be executed while Indy blocking socket
calls are in effect.
Only one TIdAntiFreeze can be active in an application.
Related
i used a multi port tcp server to receive some connections
like this
procedure TForm2.IdTCPServer1Execute(AContext: TIdContext);
var
aByte: Byte;
i,j , tmBodyFrameLength:integer;
myThread : tthread;
begin
if not Assigned( allOfflineStringList ) then
begin
allOfflineStringList := TStringlist.Create;
end;
allOfflineStringList.Clear;
case AContext.Binding.Port of
55000: begin {offline and image}
AContext.Connection.IOHandler.ReadBytes(data, 1099, False);
rowFrame :='';
for I := 0 to length(data)-1 do
begin
rowFrame := rowFrame + (data[i].ToHexString);
end;
newFrame := copy( rowFrame , 9 , maxInt );
allOfflineStringList.Append( newFrame );
TThread.Synchronize (TThread.CurrentThread,
procedure ()
begin
Label985.caption := 'Offline : ' + allOfflineStringList.Count.ToString ;
//Memo14.Lines.Add( datetimetostr(now) +':'+ newFrame );
form2.AbLED601.Tag := DateTimeToUnix(now);
form2.AbLED601.Checked := true;
end);
end;
55001: begin {tm online}
repeat
aByte := AContext.Connection.IOHandler.ReadByte;
if aByte=$C0 then
begin
SDRtmOnlineRowFrame2 := SDRtmOnlineRowFrame;
SDRtmOnlineRowFrame := '';
TThread.Synchronize (TThread.CurrentThread,
procedure ()
begin
form2.Memo14.Lines.Add('tm:'+ SDRtmOnlineRowFrame2 );
end);
end
else
begin
SDRtmOnlineRowFrame := SDRtmOnlineRowFrame + aByte.ToHexString;
end;
until true;
end;
55003: begin {beacon online}
repeat
aByte := AContext.Connection.IOHandler.ReadByte;
if aByte=$C0 then
begin
SDRtmOnlineBeaconRowFrame2 := SDRtmOnlineBeaconRowFrame;
SDRtmOnlineBeaconRowFrame := '';
TThread.Synchronize (TThread.CurrentThread,
procedure ()
begin
form2.Memo14.Lines.Add('beacon:'+ SDRtmOnlineBeaconRowFrame2 );
end);
end
else
begin
SDRtmOnlineBeaconRowFrame := SDRtmOnlineBeaconRowFrame + aByte.ToHexString;
end;
until true;
end;
end;
end;
every thing working good
but when data is receiving if i close the connection
app will hange and dont responding any more!
enable and disable is like this:
procedure TForm2.CheckBox6Click(Sender: TObject);
var
ic:integer;
allIpList : TStringList;
begin
AbLED412.Checked := CheckBox6.Checked;
if CheckBox6.Checked=true then
begin
IdTCPServer1.Active := False;
IdTCPServer1.Bindings.Clear;
with IdTCPServer1.Bindings.Add do
begin
//IP := '192.168.1.5';
Port := 55000;
end;
with IdTCPServer1.Bindings.Add do
begin
//IP := '192.168.1.5';
Port := 55001;
end;
with IdTCPServer1.Bindings.Add do
begin
//IP := '192.168.1.5';
Port := 55003;
end;
IdTCPServer1.Active := True;
IdTCPServer1.StartListening;
TIdStack.IncUsage;
try
allIpList := TStringList.Create;
GStack.AddLocalAddressesToList( allIpList );
memo14.lines.clear;
for ic := 0 to allIpList.Count-1 do
begin
memo14.lines.Add('Create tcp connection on ip : '+allIpList[ic]+' and port : 55000');
memo14.lines.Add('Create tcp connection on ip : '+allIpList[ic]+' and port : 55001');
memo14.lines.Add('Create tcp connection on ip : '+allIpList[ic]+' and port : 55003');
end;
finally
TIdStack.DecUsage;
end;
end
else
begin
IdTCPServer1.StopListening;
IdTCPServer1.Active := False;
IdTCPServer1.Bindings.Clear;
memo14.lines.clear;
end;
end;
also when data is receiving if i close the app it hanged again
but when sender disconnected closing the app dont make any problem
how can i fix this?
Your TIdTCPServer.OnExecute handler is using multiple variables in a thread-unsafe manner. You are not protecting them from multiple threads accessing them at the same time, thus causing race conditions on their data.
But, more importantly, your use of TThread.Synchronize() is a common cause of deadlock for TIdTCPServer because it is a multi-threaded component. Its OnConnect, OnDisconnect, OnExecute, and OnError events are called in the context of client worker threads, not in the main UI thread. TThread.Synchronize() blocks the calling thread until the main UI thread processes the request. Deactivating TIdTCPServer terminates all running client threads and waits for them to fully terminate. So, if you call TThread.Synchronize() in a client thread while the main UI thread is blocked deactivating the server, then the client thread is waiting on the main UI thread while the main UI thread is waiting on the client thread - deadlock!
You have a few options to solve this:
avoid calling TThread.Synchronize() while deactivating the server. Easier said than done though, as you might already be in a pending TThread.Synchronize() by the time you decide to deactivate TIdTCPServer. And it is a race condition when making the decision whether to call TThread.Synchronize() or not.
deactivate TIdTCPServer in a separate worker thread, leave the main UI thread free to process TThread.Synchronize() and TThread.Queue() requests. If you use a TThread for the deactivation, calling the TThread.WaitFor() method in the main UI thread will process Synchronize()/Queue() requests while it is waiting for the thread to terminate.
Use TThread.Queue() instead of TThread.Synchronize(), especially when performing actions that your client threads don't actually need to wait on, such as UI updates.
On a side note, in your CheckBox6Click():
you should not be calling TIdTCPServer.StartListening() or TIdTCPServer.StopListening() at all. The TIdTCPServer.Active property setter calls them internally for you.
you don't need to call TIdStack.IncUsage() or TIdStack.DecUsage() either, as TIdTCPServer's constructor and destructor call them for you.
you are leaking allIpList as you don't Free() it. And TIdStack.AddLocalAddressesToList() is deprecated anyway, you should be using TIdStack.GetLocalAddressList() instead.
Try this:
procedure TForm2.CheckBox6Click(Sender: TObject);
var
ic: integer;
allIpList : TIdStackLocalAddressList;
begin
AbLED412.Checked := CheckBox6.Checked;
if CheckBox6.Checked then
begin
IdTCPServer1.Active := False;
IdTCPServer1.Bindings.Clear;
with IdTCPServer1.Bindings.Add do
begin
//IP := '192.168.1.5';
Port := 55000;
end;
with IdTCPServer1.Bindings.Add do
begin
//IP := '192.168.1.5';
Port := 55001;
end;
with IdTCPServer1.Bindings.Add do
begin
//IP := '192.168.1.5';
Port := 55003;
end;
IdTCPServer1.Active := True;
allIpList := TIdStackLocalAddressList.Create;
try
GStack.GetLocalAddressesList( allIpList );
Memo14.Lines.Clear;
{
for ic := 0 to IdTCPServer1.Bindings.Count-1 do
begin
Memo14.Lines.Add('Create tcp connection on ip : ' + IdTCPServer1.Bindings[ic].IP + ' and port : ' + IntToStr(IdTCPServer1.Bindings[ic].Port));
end;
}
for ic := 0 to allIpList.Count-1 do
begin
if allIpList[ic].IPVersion = ID_DEFAULT_IP_VERSION then
begin
Memo14.Lines.Add('Create tcp connection on ip : ' + allIpList[ic].IPAddress + ' and port : 55000');
Memo14.Lines.Add('Create tcp connection on ip : ' + allIpList[ic].IPAddress + ' and port : 55001');
Memo14.Lines.Add('Create tcp connection on ip : ' + allIpList[ic].IPAddress + ' and port : 55003');
end;
end;
finally
allIpList.Free;
end;
end
else
begin
IdTCPServer1.Active := False;
IdTCPServer1.Bindings.Clear;
Memo14.Lines.Clear;
end;
end;
Application works as I'd like but there are quite big memory leakage.
Every event that throttles one thread gives me 4 TBitmaps and 2 TStrokeBrush that are lost.
The procedure DrawSine(); is triggered in Execute in Synchronize statement:
procedure SineThread.DrawSine();
var
sin_T : Extended;
Point2 : TPoint;
I : Integer;
begin
TempBitmap.SetSize(Twidth, Theight);
TempBitmap.Canvas.BeginScene();
TempBitmap.Canvas.Stroke.Kind := TBrushKind.bkSolid;
TempBitmap.Canvas.Stroke.Color := claLime;
TempBitmap.Canvas.Clear(TAlphaColorRec.Black);
for I := 0 to Twidth do
begin
sin_T := Sin(((I - Tphas)/100.0) * Tfreq);
Point2.X := Round(I);
Point2.Y := Round(sin_T * Tampl) + Round(Theight/2.0);
if I = 0 then
begin
Point1.X := Round(I);
Point1.Y := Round(sin_T * Tampl) + Round(Theight/2.0);
TempBitmap.Canvas.DrawLine(Point1, Point2, 1.0, TempBrush);
end
else
begin
if I = Twidth then
begin
TempBitmap.Canvas.DrawLine(Point1, Point2, 1.0, TempBrush);
Point1.X := Round(I);
Point1.Y := Round(Theight/2.0);
end
else
begin
TempBitmap.Canvas.DrawLine(Point1, Point2, 1.0, TempBrush);
Point1.X := Point2.X;
Point1.Y := Point2.Y;
end;
end;
end;
TempBitmap.Canvas.EndScene();
end;
SineThread Constructor and Destructor:
constructor SineThread.Create(CreateSuspended: Boolean);
begin
inherited Create(CreateSuspended);
try
TempBitmap := TBitmap.Create();
TempBrush := TStrokeBrush.Create(TBrushKind.bkSolid, TAlphaColorRec.White);
finally
Twidth := 0;
Theight := 0;
Tampl := 0;
Tphas := 0;
Tfreq := 0;
Point1 := Point(0,0);
end;
end;
destructor SineThread.Destroy();
begin
inherited Destroy();
TempBitmap.Free();
TempBrush.Free();
end;
OnTerminate when finishing thread looks like:
procedure TForm1.OnTerminateProc1(Sender: TObject);
var
TempStream : TMemoryStream;
begin
try
TempStream := TMemoryStream.Create();
finally
(Sender as SineThread).GetBitmap.SaveToStream(TempStream);
Image1.Bitmap.LoadFromStream(TempStream);
TempStream.Free();
end;
end;
The Trigger() procedure is started every the the value on TrackBars change:
procedure TForm1.Trigger(Sender: TObject);
var
sine1_thread : SineThread;
sine2_thread : SineThread;
sineSum_thread : SineSumThread;
begin
try
begin
sine1_thread := SineThread.Create(True);
sine2_thread := SineThread.Create(True);
sineSum_thread := SineSumThread.Create(True);
end;
finally
begin
sine1_thread.SetSineParams(TrackBar1.Value, TrackBar2.Value, TrackBar3.Value);
sine1_thread.SetImageParams(Trunc(Image1.Width), Trunc(Image1.Height));
sine1_thread.FreeOnTerminate := True;
sine1_thread.OnTerminate := OnTerminateProc1;
sine1_thread.Start();
sine2_thread.SetSineParams(TrackBar4.Value, TrackBar5.Value, TrackBar6.Value);
sine2_thread.SetImageParams(Trunc(Image2.Width), Trunc(Image2.Height));
sine2_thread.FreeOnTerminate := True;
sine2_thread.OnTerminate := OnTerminateProc2;
sine2_thread.Start();
sineSum_thread.SetSineParams(TrackBar1.Value, TrackBar2.Value, TrackBar3.Value, TrackBar4.Value, TrackBar5.Value, TrackBar6.Value);
sineSum_thread.SetImageParams(Trunc(Image3.Width), Trunc(Image3.Height));
sineSum_thread.FreeOnTerminate := True;
sineSum_thread.OnTerminate := OnTerminateProc3;
sineSum_thread.Start();
end;
end;
end;
It seems that the threads are not being destroyed. Since they are freed on terminate that seems odd. You set FreeOnTerminate, so if the threads terminate they will be destroyed.
Let us assume that the threads to terminate. In which case the explanation is that your destructor is missing override directive. It should be declared like this:
destructor Destroy; override;
My psychic debugging skills (not infallible) tell me that you missed the override. So when Destroy is called, the base class method runs and not yours.
The most effective way to track down leaks is to use the full version of FastMM. When configured correctly that will give stack traces for the allocation associated with a leak. And lots of other useful stuff to help find defects earlier.
Don't use finally in a constructor's implementation. If an exception is raised then, the instance will be destroyed and so your finally block is pointless.
Use the correct resource acquisition pattern:
obj := TMyClass.Create;
try
obj.Foo; // do stuff with obj
finally
obj.Free;
end;
As you write it, an exception raise in the constructor will lead to you calling Free on an uninitialized instance variable.
Deallocate resource in reverse order to their acquisition. That means that your destructor should be written:
destructor SineThread.Destroy;
begin
TempBrush.Free;
TempBitmap.Free;
inherited;
end;
The finally in TForm1.Trigger is also wrong. A finally block runs no matter what. If for some reason you fail to create an object, you must not carry on as if that failure did not happen. You use finally to protect a resource. You acquire a resource, and use the finally block to make sure that you release it no matter what.
There's absolutely no need for threads in your program. As you explained in your previous question, and mentioned again here, you use Synchronize to put all the work onto the main threads. This renders the threads nugatory. I don't know why you chose to use threads. Perhaps you thought that by doing so, your program would perform better. That is not always the case, and certainly not when you implement threading the way you have done.
Programming is hard enough at the best of times, without needless complexity. Especially when you have not yet mastered the language. My advice is to do that first before moving on to advanced topics like threading.
Finally, you must learn to present complete, but cut-down examples for questions like this. You omitted quite a bit of code, and if I am right, the most important bit of code, that which causes the leak, was omitted.
One general rule to remember is this one:
When an object's constructor raises an exception, it's destructor is
called automatically.
So the try..finally sequence in SineThread.Create is not needed.
In an object's destructor, call inherited as last item.
constructor SineThread.Create(CreateSuspended: Boolean);
begin
inherited Create(CreateSuspended);
TempBitmap := TBitmap.Create();
TempBrush := TStrokeBrush.Create(TBrushKind.bkSolid, TAlphaColorRec.White);
Twidth := 0;
Theight := 0;
Tampl := 0;
Tphas := 0;
Tfreq := 0;
Point1 := Point(0,0);
end;
destructor SineThread.Destroy();
begin
TempBitmap.Free();
TempBrush.Free();
inherited;
end;
same goes for OnTerminateProc1 :
procedure TForm1.OnTerminateProc1(Sender: TObject);
var
TempStream : TMemoryStream;
begin
TempStream := TMemoryStream.Create();
try
(Sender as SineThread).GetBitmap.SaveToStream(TempStream);
Image1.Bitmap.LoadFromStream(TempStream);
finally
TempStream.Free();
end;
end;
no need for try..finally inTrigger() :
procedure TForm1.Trigger(Sender: TObject);
var
sine1_thread : SineThread;
sine2_thread : SineThread;
sineSum_thread : SineSumThread;
begin
sine1_thread := SineThread.Create(True);
sine2_thread := SineThread.Create(True);
sineSum_thread := SineSumThread.Create(True);
sine1_thread.SetSineParams(TrackBar1.Value, TrackBar2.Value, TrackBar3.Value);
sine1_thread.SetImageParams(Trunc(Image1.Width), Trunc(Image1.Height));
sine1_thread.FreeOnTerminate := True;
sine1_thread.OnTerminate := OnTerminateProc1;
sine1_thread.Start();
sine2_thread.SetSineParams(TrackBar4.Value, TrackBar5.Value, TrackBar6.Value);
sine2_thread.SetImageParams(Trunc(Image2.Width), Trunc(Image2.Height));
sine2_thread.FreeOnTerminate := True;
sine2_thread.OnTerminate := OnTerminateProc2;
sine2_thread.Start();
sineSum_thread.SetSineParams(TrackBar1.Value, TrackBar2.Value, TrackBar3.Value, TrackBar4.Value, TrackBar5.Value, TrackBar6.Value);
sineSum_thread.SetImageParams(Trunc(Image3.Width), Trunc(Image3.Height));
sineSum_thread.FreeOnTerminate := True;
sineSum_thread.OnTerminate := OnTerminateProc3;
sineSum_thread.Start();
end;
I want to implement a simple http downloader using TIdHttp (Indy10). I found two kind of code examples from the internet. Unfortunately none of them satisfy me 100%. Here is the code and I want some advise.
Variant 1
var
Buffer: TFileStream;
HttpClient: TIdHttp;
begin
Buffer := TFileStream.Create('somefile.exe', fmCreate or fmShareDenyWrite);
try
HttpClient := TIdHttp.Create(nil);
try
HttpClient.Get('http://somewhere.com/somefile.exe', Buffer); // wait until it is done
finally
HttpClient.Free;
end;
finally
Buffer.Free;
end;
end;
The code is compact and very easy to understand. The problem is that it allocates disk space when downloading begins. Another problem is that we cannot show the download progress in GUI directly, unless the code is executed in a background thread (alternatively we can bind HttpClient.OnWork event).
Variant 2:
const
RECV_BUFFER_SIZE = 32768;
var
HttpClient: TIdHttp;
FileSize: Int64;
Buffer: TMemoryStream;
begin
HttpClient := TIdHttp.Create(nil);
try
HttpClient.Head('http://somewhere.com/somefile.exe');
FileSize := HttpClient.Response.ContentLength;
Buffer := TMemoryStream.Create;
try
while Buffer.Size < FileSize do
begin
HttpClient.Request.ContentRangeStart := Buffer.Size;
if Buffer.Size + RECV_BUFFER_SIZE < FileSize then
HttpClient.Request.ContentRangeEnd := Buffer.Size + RECV_BUFFER_SIZE - 1
else
HttpClient.Request.ContentRangeEnd := FileSize;
HttpClient.Get(HttpClient.URL.URI, Buffer); // wait until it is done
Buffer.SaveToFile('somefile.exe');
end;
finally
Buffer.Free;
end;
finally
HttpClient.Free;
end;
end;
First we query the file size from the server and then we download file contents in pieces. Retrieved file contents will be save to disk when they are received completely. The potential problem is we have to send multiple GET requests to the server. I am not sure if some servers (such as megaupload) might limit the number of requests within particular time period.
My expectations
The downloader should send only one GET-request to the server.
The disk space must not be allocated when the download begins.
Any hints are appreciated.
Variant #1 is the simpliest, and is how Indy is meant to be used.
Regarding the disk allocation issue, you can derive a new class from TFileStream and override its SetSize() method to do nothing. TIdHTTP will still attempt to pre-allocate the file when appropriate, but it will not actually allocate any disk space. Writing to TFileStream will grow the file as needed.
Regarding status reporting, TIdHTTP has OnWork... events for that purpose. The AWorkCountMax parameter of the OnWorkBegin will be the actual file size if known (the response is not chunked), or 0 if not known. The AWorkCount parameter of the OnWork event will be the cumulative number of bytes that have been transferred so far. If the file size is known, you can display the total percentage by simply dividing the AWorkCount by the AWorkCountMax and multiplying by 100, otherwise just display the AWorkCount value by itself. If you want to display the speed of the transfer, you can calculate that from the difference of AWorkCount values and the time intervals between multiple OnWork events.
Try this:
type
TNoPresizeFileStream = class(TFileStream)
procedure
procedure SetSize(const NewSize: Int64); override;
end;
procedure TNoPresizeFileStream.SetSize(const NewSize: Int64);
begin
end;
.
type
TSomeClass = class(TSomething)
...
TotalBytes: In64;
LastWorkCount: Int64;
LastTicks: LongWord;
procedure Download;
procedure HttpWorkBegin(ASender: TObject; AWorkMode: TWorkMode; AWorkCountMax: Int64);
procedure HttpWork(ASender: TObject; AWorkMode: TWorkMode; AWorkCount: Int64);
procedure HttpWorkEnd(ASender: TObject; AWorkMode: TWorkMode);
...
end;
procedure TSomeClass.Download;
var
Buffer: TNoPresizeFileStream;
HttpClient: TIdHttp;
begin
Buffer := TNoPresizeFileStream.Create('somefile.exe', fmCreate or fmShareDenyWrite);
try
HttpClient := TIdHttp.Create(nil);
try
HttpClient.OnWorkBegin := HttpWorkBegin;
HttpClient.OnWork := HttpWork;
HttpClient.OnWorkEnd := HttpWorkEnd;
HttpClient.Get('http://somewhere.com/somefile.exe', Buffer); // wait until it is done
finally
HttpClient.Free;
end;
finally
Buffer.Free;
end;
end;
procedure TSomeClass.HttpWorkBegin(ASender: TObject; AWorkMode: TWorkMode; AWorkCountMax: Int64);
begin
if AWorkMode <> wmRead then Exit;
// initialize the status UI as needed...
//
// If TIdHTTP is running in the main thread, update your UI
// components directly as needed and then call the Form's
// Update() method to perform a repaint, or Application.ProcessMessages()
// to process other UI operations, like button presses (for
// cancelling the download, for instance).
//
// If TIdHTTP is running in a worker thread, use the TIdNotify
// or TIdSync class to update the UI components as needed, and
// let the OS dispatch repaints and other messages normally...
TotalBytes := AWorkCountMax;
LastWorkCount := 0;
LastTicks := Ticks;
end;
procedure TSomeClass.HttpWork(ASender: TObject; AWorkMode: TWorkMode; AWorkCount: Int64);
var
PercentDone: Integer;
ElapsedMS: LongWord;
BytesTransferred: Int64;
BytesPerSec: Int64;
begin
if AWorkMode <> wmRead then Exit;
ElapsedMS := GetTickDiff(LastTicks, Ticks);
if ElapsedMS = 0 then ElapsedMS := 1; // avoid EDivByZero error
if TotalBytes > 0 then
PercentDone := (Double(AWorkCount) / TotalBytes) * 100.0;
else
PercentDone := 0.0;
BytesTransferred := AWorkCount - LastWorkCount;
// using just BytesTransferred and ElapsedMS, you can calculate
// all kinds of speed stats - b/kb/mb/gm per sec/min/hr/day ...
BytesPerSec := (Double(BytesTransferred) * 1000) / ElapsedMS;
// update the status UI as needed...
LastWorkCount := AWorkCount;
LastTicks := Ticks;
end;
procedure TSomeClass.HttpWorkEnd(ASender: TObject; AWorkMode: TWorkMode);
begin
if AWorkMode <> wmRead then Exit;
// finalize the status UI as needed...
end;
Here is an example that shows how to use the components OnWork to show a progress bar:
Download a File from internet programatically with an Progress event using Delphi and Indy
You should not worry about the disk allocation. Disk space that is allocated is not actually written to, so it won't damage your disks. Be happy that it is allocated so that it is not possible that another process claims the disk space and let you run out of space!
Do not forget to add this for the Variant 2
: Else HttpClient.Request.ContentRangeEnd := FileSize;
Replace
if Buffer.Size + RECV_BUFFER_SIZE < FileSize then
HttpClient.Request.ContentRangeEnd := Buffer.Size + RECV_BUFFER_SIZE - 1;
By
if Buffer.Size + RECV_BUFFER_SIZE < FileSize then
HttpClient.Request.ContentRangeEnd := Buffer.Size + RECV_BUFFER_SIZE - 1;
Else HttpClient.Request.ContentRangeEnd := FileSize;
I hope this post is not a duplicate one. Let me explain:
I have considered the similar post How to pause / resume any external process under Windows? but with C++/Python preference and yet without an accepted answer as of the time of posting.
My Question:
I'm interested in a possible implementation in Delphi of the functionality provided by PsSuspend by Mark Russinovich of Windows Sysinternals.
Quotes:
PsSuspend lets you suspend processes on the local or a remote system,
which is desirable in cases where a process is consuming a resource
(e.g. network, CPU or disk) that you want to allow different processes
to use. Rather than kill the process that's consuming the resource,
suspending permits you to let it continue operation at some later
point in time.
Thank you.
Edit:
A partial implementation will do. Remote capability can be dropped.
You can try to use the following code. It uses the undocumented functions NtSuspendProcess and NtResumeProcess. I've tried it on Windows 7 64-bit from the 32-bit application built in Delphi 2009 and it works for me. Note that these functions are undocumented thus can be removed from future versions of Windows.
Update
The SuspendProcess and ResumeProcess wrappers from the following code are now functions and returns True if succeed, False otherwise.
type
NTSTATUS = LongInt;
TProcFunction = function(ProcHandle: THandle): NTSTATUS; stdcall;
const
STATUS_SUCCESS = $00000000;
PROCESS_SUSPEND_RESUME = $0800;
function SuspendProcess(const PID: DWORD): Boolean;
var
LibHandle: THandle;
ProcHandle: THandle;
NtSuspendProcess: TProcFunction;
begin
Result := False;
LibHandle := SafeLoadLibrary('ntdll.dll');
if LibHandle <> 0 then
try
#NtSuspendProcess := GetProcAddress(LibHandle, 'NtSuspendProcess');
if #NtSuspendProcess <> nil then
begin
ProcHandle := OpenProcess(PROCESS_SUSPEND_RESUME, False, PID);
if ProcHandle <> 0 then
try
Result := NtSuspendProcess(ProcHandle) = STATUS_SUCCESS;
finally
CloseHandle(ProcHandle);
end;
end;
finally
FreeLibrary(LibHandle);
end;
end;
function ResumeProcess(const PID: DWORD): Boolean;
var
LibHandle: THandle;
ProcHandle: THandle;
NtResumeProcess: TProcFunction;
begin
Result := False;
LibHandle := SafeLoadLibrary('ntdll.dll');
if LibHandle <> 0 then
try
#NtResumeProcess := GetProcAddress(LibHandle, 'NtResumeProcess');
if #NtResumeProcess <> nil then
begin
ProcHandle := OpenProcess(PROCESS_SUSPEND_RESUME, False, PID);
if ProcHandle <> 0 then
try
Result := NtResumeProcess(ProcHandle) = STATUS_SUCCESS;
finally
CloseHandle(ProcHandle);
end;
end;
finally
FreeLibrary(LibHandle);
end;
end;
There is no SuspendProcess API call in Windows. So what you need to do is:
Enumerate all the threads in the process. See RRUZ's answer for sample code.
Call SuspendThread for each of these threads.
In order to implement the resume part of the program, call ResumeThread for each thread.
There is a race condition for the "suspend all threads" implementation - what happens if the program you are trying to suspend creates one or more threads between the time that you create the snapshot and the time that you complete suspending?
You could loop, getting another snapshot and suspending any unsuspending threads, exiting only when you found none.
The undocumented function avoids this issue.
I just found the following snippets here (Author: steve10120).
I think they are valuables and I can't help posting them also as an alternative answer to my own question.
Resume Process:
function ResumeProcess(ProcessID: DWORD): Boolean;
var
Snapshot,cThr: DWORD;
ThrHandle: THandle;
Thread:TThreadEntry32;
begin
Result := False;
cThr := GetCurrentThreadId;
Snapshot := CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0);
if Snapshot <> INVALID_HANDLE_VALUE then
begin
Thread.dwSize := SizeOf(TThreadEntry32);
if Thread32First(Snapshot, Thread) then
repeat
if (Thread.th32ThreadID <> cThr) and (Thread.th32OwnerProcessID = ProcessID) then
begin
ThrHandle := OpenThread(THREAD_ALL_ACCESS, false, Thread.th32ThreadID);
if ThrHandle = 0 then Exit;
ResumeThread(ThrHandle);
CloseHandle(ThrHandle);
end;
until not Thread32Next(Snapshot, Thread);
Result := CloseHandle(Snapshot);
end;
end;
Suspend Process:
function SuspendProcess(PID:DWORD):Boolean;
var
hSnap: THandle;
THR32: THREADENTRY32;
hOpen: THandle;
begin
Result := FALSE;
hSnap := CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0);
if hSnap <> INVALID_HANDLE_VALUE then
begin
THR32.dwSize := SizeOf(THR32);
Thread32First(hSnap, THR32);
repeat
if THR32.th32OwnerProcessID = PID then
begin
hOpen := OpenThread($0002, FALSE, THR32.th32ThreadID);
if hOpen <> INVALID_HANDLE_VALUE then
begin
Result := TRUE;
SuspendThread(hOpen);
CloseHandle(hOpen);
end;
end;
until Thread32Next(hSnap, THR32) = FALSE;
CloseHandle(hSnap);
end;
end;
Disclaimer:
I didn't test them at all. Please enjoy and don't forget to feedback.
Is there support in the Delphi XE VCL for ensuring only a single instance of an application is running?
In the past, I've used library code to control a Mutex which has always seemed complicated. As I'm starting a new project in Delphi XE, I wonder if I need to dig up that old code, or if there is support built into XE already? Or is there another easy to apply code that is nice and modern?
You create a named Mutex when you start the application. Check GetLastError to see if an other instance is already running.
Put this code right after "begin" in your DPR file. Replace the GUID with one of your own. When I need a text constant that's unlikely to be used for anything else, I usually just hit Ctrl+G to get a GUID!
if CreateMutex(nil, True, '6EACD0BF-F3E0-44D9-91E7-47467B5A2B6A') = 0 then
RaiseLastOSError;
if GetLastError = ERROR_ALREADY_EXISTS then
Exit;
It might look like the code is leaking an handle because it's not saving the return of CreateMutex. It's not. Windows will automatically release the handle when our application is terminated, and that's absolutely fine with us.
I use JCL to do this:
program MyProgram;
uses
JclAppInst;
begin
JclAppInstances.CheckSingleInstance; // Added instance checking
Application.Initialize;
Application.CreateForm(TMainForm, MainForm);
Application.Run;
end.
Documentation for this, and the notification scheme, is at the JCL Wiki.
I use this, works in XE2 through to Alexandria, has the benefit of being able to bring the currently running instance to the front.
Those that say it shouldn't do that, well, given the last thing the user did was to try launch the app, bringing a currently running instance to the front makes sense
unit CheckPrevious;
interface
uses
Windows, SysUtils, WinSock;
function RestoreIfRunning(const AppHandle : THandle; MaxInstances : integer = 1) : boolean;
implementation
type
PInstanceInfo = ^TInstanceInfo;
TInstanceInfo = packed record
PreviousHandle : THandle;
RunCounter : integer;
end;
var
MappingHandle: THandle;
InstanceInfo: PInstanceInfo;
MappingName : string;
RemoveMe : boolean = True;
function RestoreIfRunning(const AppHandle : THandle; MaxInstances : integer = 1) : boolean;
begin
Result := True;
MappingName := StringReplace(ParamStr(0),'\','',[rfReplaceAll, rfIgnoreCase]);
MappingHandle := CreateFileMapping($FFFFFFFF,nil,PAGE_READWRITE,0,SizeOf(TInstanceInfo),PChar(MappingName));
if MappingHandle = 0 then
RaiseLastOSError
else
begin
if GetLastError <> ERROR_ALREADY_EXISTS then
begin
InstanceInfo := MapViewOfFile(MappingHandle,FILE_MAP_ALL_ACCESS,0,0,SizeOf(TInstanceInfo));
InstanceInfo^.PreviousHandle := AppHandle;
InstanceInfo^.RunCounter := 1;
Result := False;
end
else //already runing
begin
MappingHandle := OpenFileMapping(FILE_MAP_ALL_ACCESS, False, PChar(MappingName));
if MappingHandle <> 0 then
begin
InstanceInfo := MapViewOfFile(MappingHandle,FILE_MAP_ALL_ACCESS,0,0,SizeOf(TInstanceInfo));
if InstanceInfo^.RunCounter >= MaxInstances then
begin
RemoveMe := False;
if IsIconic(InstanceInfo^.PreviousHandle) then
ShowWindow(InstanceInfo^.PreviousHandle, SW_RESTORE);
SetForegroundWindow(InstanceInfo^.PreviousHandle);
end
else
begin
InstanceInfo^.PreviousHandle := AppHandle;
InstanceInfo^.RunCounter := 1 + InstanceInfo^.RunCounter;
Result := False;
end
end;
end;
end;
end;
initialization
finalization
//remove one instance
if RemoveMe then
begin
MappingHandle := OpenFileMapping(FILE_MAP_ALL_ACCESS, False, PChar(MappingName));
if MappingHandle <> 0 then
begin
InstanceInfo := MapViewOfFile(MappingHandle, FILE_MAP_ALL_ACCESS, 0, 0, SizeOf(TInstanceInfo));
InstanceInfo^.RunCounter := -1 + InstanceInfo^.RunCounter;
end
else
RaiseLastOSError;
end;
if Assigned(InstanceInfo) then
UnmapViewOfFile(InstanceInfo);
if MappingHandle <> 0 then
CloseHandle(MappingHandle);
end.
In your project DPR, add the CheckPrevious unit to the uses, then just after begin put the following
if RestoreIfRunning(Application.Handle, 1) then
Exit;
I have no idea of where this code originated, otherwise I would gladly credit the author. (A search of RestoreIfRunning may suggest it was from Zarko Gajic)
This is how i do it.
closeProc(extractfilename(paramstr(0)));
function TForm1.closeProc(pname : string): integer;
const
PROCESS_TERMINATE = $0001;
var
ContinueLoop: BOOL;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
i : integer;
pname2 : string;
begin
try
Result := 0;
i := 0;
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
while Integer(ContinueLoop) <> 0 do
begin
pname2 := trim(UpperCase(ExtractFileName(FProcessEntry32.szExeFile)));
if ( pname2 = uppercase(pname)) then
if FProcessEntry32.th32ProcessID <> GetCurrentProcessId then
begin
Result := Integer(TerminateProcess(OpenProcess(PROCESS_TERMINATE, BOOL(0), FProcessEntry32.th32ProcessID), 0));
inc(i);
end;
ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
if i > 50 then
break;
end;
CloseHandle(FSnapshotHandle);
except
end;
end;