When program starts, automatically downloads given EXE file, but if I want to abort the current process and restart to download again or/and if EXE is downloaded successfully one time and would like to download again, program stops with error message: "raised exception class EIdHTTPProtocolException"
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs,idhttp, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,
ComCtrls, StdCtrls;
type
TForm1 = class(TForm)
ProgressBar1: TProgressBar;
IdHTTP1: TIdHTTP;
Button1: TButton;
Button2: TButton;
procedure FormCreate(Sender: TObject);
procedure IdHTTP1WorkBegin(ASender: TObject; AWorkMode: TWorkMode;
AWorkCountMax: Integer);
procedure IdHTTP1Work(ASender: TObject; AWorkMode: TWorkMode;
AWorkCount: Integer);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure DownloadFile;
end;
type
xy = class(TThread)
private
{ Private declarations }
protected
procedure Execute; override;
procedure friss;
end;
var
Form1: TForm1;
szal:xy;
Stream: TMemoryStream;
implementation
{$R *.dfm}
procedure xy.friss;
begin
ShowMessage('kész');
szal.terminate;
end;
procedure TForm1.Button1Click(Sender: TObject); //abort
begin
szal.Suspend;
szal.Terminate;
end;
procedure TForm1.Button2Click(Sender: TObject); //restart
begin
szal:=xy.Create(true);
szal.Resume;
end;
procedure tform1.DownloadFile;
var
Url, FileName: String;
begin
idhttp1:=idhttp1.Create(self);
Url := 'http://livecd.com/downloads/ActiveDataStudioSetup.exe';
Filename := 'c:\setup.zip';
Stream := TMemoryStream.Create;
try
IdHTTP1.Get(Url, Stream);
Stream.SaveToFile(FileName);
finally
Stream.Free;
IdHTTP1.free;
end;
end;
procedure xy.execute;
begin
form1.DownloadFile;
Synchronize(friss);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
szal:=xy.Create(true);
szal.Resume;
end;
procedure TForm1.IdHTTP1Work(ASender: TObject; AWorkMode: TWorkMode;
AWorkCount: Integer);
begin
form1.ProgressBar1.Position:=AWorkCount;
end;
procedure TForm1.IdHTTP1WorkBegin(ASender: TObject; AWorkMode: TWorkMode;
AWorkCountMax: Integer);
begin
form1.ProgressBar1.Max:=AWorkCountMax;
form1.ProgressBar1.Position:=0;
end;
end.
Source code: http://pastebin.com/9DvSyTD7
Project: http://osztott.com/ubXN/cucc.zip
EIdHTTPProtocolException means the HTTP server sent back an error, such as if the requested resource is not found or cannot be accessed. That has nothing to do with your threading logic.
However, there are a lot of problems with your code in general - misuse of TThread and dynamic components, not syncing the worker thread with the main UI thread, etc.
Try something more like this instead:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ComCtrls, StdCtrls;
type
TForm1 = class(TForm)
ProgressBar1: TProgressBar;
Button1: TButton;
Button2: TButton;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
procedure StartDownload;
procedure StopDownload;
procedure DownloadFinished(Sender: TObject);
public
end;
var
Form1: TForm1;
implementation
uses
IdHTTP, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, IdSync;
{$R *.dfm}
type
TDownloadThread = class(TThread)
private
{ Private declarations }
procedure HTTPWorkBegin(ASender: TObject; AWorkMode: TWorkMode; AWorkCountMax: Integer);
procedure HTTPWork(ASender: TObject; AWorkMode: TWorkMode; AWorkCount: Integer);
protected
procedure Execute; override;
public
property ReturnValue;
property Terminated;
end;
TDownloadStatusNotify = class(TIdNotify)
protected
Value: Integer;
DownloadBegin: Boolean;
procedure DoNotify; override;
public
constructor Create(AValue: Integer: ADownloadBegin: Boolean); reintroduce;
end;
TFreeDownloadThreadNotify = class(TIdNotify)
protected
Thread: TDownloadThread;
procedure DoNotify; override;
public
constructor Create(AThread: TDownloadThread); reintroduce;
end;
procedure TDownloadThread.Execute;
var
Url, Filename: string;
HTTP: TIdHTTP;
Stream: TMemoryStream;
begin
Url := 'http://livecd.com/downloads/ActiveDataStudioSetup.exe';
Filename := 'c:\setup.zip';
HTTP := TIdHTTP.Create(nil);
try
HTTP.OnWorkBegin := HTTPWorkBegin;
HTTP.OnWork := HTTPWork;
Stream := TMemoryStream.Create;
try
HTTP.Get(Url, Stream);
Stream.SaveToFile(Filename);
finally
Stream.Free;
end;
finally
HTTP.Free;
end;
ReturnValue := 1;
end;
procedure TDownloadThread.HTTPWorkBegin(ASender: TObject; AWorkMode: TWorkMode; AWorkCountMax: Integer);
begin
if Terminated then SysUtils.Abort;
if AWorkMode = wmRead then
TDownloadStatusNotify.Create(AWorkCountMax, True).Notify;
end;
procedure TDownloadThread.HTTPWork(ASender: TObject; AWorkMode: TWorkMode; AWorkCount: Integer);
begin
if Terminated then SysUtils.Abort;
if AWorkMode = wmRead then
TDownloadStatusNotify.Create(AWorkCount, False).Notify;
end;
constructor TDownloadStatusNotify.Create(AValue: Integer; ADownloadBegin: Boolean);
begin
inherited Create;
Value := AValue;
DownloadBegin := ADownloadBegin;
end;
procedure TDownloadStatusNotify.DoNotify;
begin
if DownloadBegin then
begin
Form1.ProgressBar1.Position := 0;
Form1.ProgressBar1.Max := Value;
end else
begin
if Form1.ProgressBar1.Max > 0 then
begin
Form1.ProgressBar1.Position := Value;
end else
begin
// the download size is unknown (most likely chunked) so
// display the current Value somewhere else...
end;
end;
end;
constructor TFreeDownloadThreadNotify.Create(AThread: TDownloadThread);
begin
inherited Create;
MainThreadUsesNotify := True;
Thread := AThread;
end;
procedure TFreeDownloadThreadNotify.DoNotify;
begin
Thread.Free;
end;
var
szal: TDownloadThread = nil;
procedure TForm1.FormCreate(Sender: TObject);
begin
StartDownload;
end;
procedure TForm1.Button1Click(Sender: TObject); //abort
begin
StopDownload;
end;
procedure TForm1.Button2Click(Sender: TObject); //restart
begin
StopDownload;
StartDownload;
end;
procedure TForm1.StartDownload;
begin
szal := TDownloadThread.Create(True);
sza1.OnTerminate := DownloadFinished;
szal.Resume;
end;
procedure TForm1.StopDownload;
begin
if sza1 <> nil then
begin
szal.Terminate;
sza1.WaitFor;
FreeAndNil(sza1);
end;
end;
procedure TForm1.DownloadFinished(Sender: TObject);
begin
if sza1.ReturnValue = 1 then
ShowMessage('kész')
else if sza1.Terminated then
ShowMessage('félbeszakadt')
else
ShowMessage('hiba');
if not sza1.Terminated then
begin
TFreeDownloadThreadNotify.Create(sza1).Notify;
sza1 := nil;
end;
end;
end.
Related
i have this TThread that i use inside my dll to update some visual control its working fine but i face issue when i try to close my dll and reopen it again its raised this exception
checksynchronize called from thread which is not the main thread
what iam doing wrong ? i need to call checksynchronize within timer because i will update some vcl with Threading while app running .
Here is my Thread unit
unit Thread;
interface
uses Messages, Windows, SysUtils, dialogs, Classes, Menus, forms, ComOBJ,
ShlObj;
{ Thread client }
type
TThreadCallbackProc = procedure(Sender: TObject; Updatestring : string) of object;
TAPPTHREAD = class(TThread)
private
Fstatus : String;
FOnCallbackProc: TThreadCallbackProc;
procedure dosomework;
procedure DoCallbackProc;
//
protected
procedure Execute; override;
Public
constructor Create(CreateSuspended: Boolean; aThreadCallbackProc: TThreadCallbackProc);
destructor Destroy; override;
end;
var
APPTHREAD : TAPPTHREAD;
implementation
constructor TAPPTHREAD.Create(CreateSuspended: Boolean;
aThreadCallbackProc: TThreadCallbackProc);
begin
inherited Create(CreateSuspended);
FreeOnTerminate := True;
FOnCallbackProc := aThreadCallbackProc;
end;
destructor TAPPTHREAD.Destroy;
begin
//
end;
procedure TAPPTHREAD.DoCallbackProc;
begin
if Assigned(FOnCallbackProc) then
FOnCallbackProc(self, Fstatus);
end;
procedure TAPPTHREAD.Execute;
begin
while not Terminated do
begin
Fstatus := 'Synched';
if Fstatus <> '' then
dosomework;
end;
end;
procedure TAPPTHREAD.dosomework;
begin
if Assigned(FOnCallbackProc) then
begin
Synchronize(DoCallbackProc);
end;
end;
end.
Main Form
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls;
type
TForm1 = class(TForm)
Label1: TLabel;
Timer1: TTimer;
Timer2: TTimer;
procedure FormShow(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Timer2Timer(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
procedure callbackproc(Sender: TObject; Updatestring : String);
end;
var
Form1: TForm1;
implementation
uses Thread;
{$R *.dfm}
procedure TForm1.callbackproc(Sender: TObject; Updatestring: String);
begin
label1.Caption := updatestring;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := Cafree;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
try
if Assigned(APPTHREAD) then
AppThread.Terminate;
except end;
try
Timer2.Enabled := False;
except end;
end;
procedure TForm1.FormShow(Sender: TObject);
begin
Timer1.Enabled := True;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Timer1.Enabled := False;
APPTHREAD := TAPPTHREAD.Create(false, CallbackProc);
Timer2.Enabled := True;
end;
procedure TForm1.Timer2Timer(Sender: TObject);
begin
Checksynchronize;
end;
end.
DFM
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 242
ClientWidth = 472
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
OnClose = FormClose
OnDestroy = FormDestroy
OnShow = FormShow
PixelsPerInch = 96
TextHeight = 13
object Label1: TLabel
Left = 0
Top = 0
Width = 472
Height = 13
Align = alTop
Caption = 'Label1'
ExplicitLeft = 232
ExplicitTop = 136
ExplicitWidth = 31
end
object Timer1: TTimer
Enabled = False
OnTimer = Timer1Timer
Left = 232
Top = 128
end
object Timer2: TTimer
Enabled = False
Interval = 1
OnTimer = Timer2Timer
Left = 320
Top = 168
end
end
dll code
library dllapp;
uses
System.SysUtils,
Themes,
Windows,
Forms,
dialogs,
Graphics,
Vcl.ExtCtrls,
Unit1 in 'Unit1.pas' {Unit1},
DThreadsend in 'Thread.pas';
var
mHandle: THandle;
DLLHandle: Longint = 0;
function createApp(Width: Integer; Height: Integer; hw: HWnd;
app: TApplication): boolean; stdcall;
begin
mHandle := CreateMutex(nil, True, 'APPNAMETLOAD');
if GetLastError = ERROR_ALREADY_EXISTS then
begin
Halt;
end;
try
form1 := Tform1.CreateParented(hw); // **
form1.Width := Width;
form1.Height := Height;
Result := True
except
on e: exception do
begin
Result := False;
end;
end;
end;
procedure closeApp; stdcall;
begin
ApplicationClosed := True;
try
if mHandle <> 0 then
CloseHandle(mHandle);
except
end;
if Assigned(form1) then
try
FreeAndNil(form1);
except
end;
try
OptimizeRamUsage;
except
end;
end;
procedure showapp; stdcall;
begin
try
form1.Visible := True;
except
end;
form1.Show;
end;
procedure DLLEntryProc(EntryCode: Integer);
begin
case EntryCode of
DLL_PROCESS_DETACH:
begin
StyleServices.Free;
end;
DLL_PROCESS_ATTACH:
begin
end;
DLL_THREAD_ATTACH:
begin
end;
DLL_THREAD_DETACH:
begin
end;
end;
end;
exports
closeApp,
createApp,
showapp;
begin
DllProc := #DLLEntryProc;
end.
Host Application and how i create Dll
loadapp Unit
unit loadapp;
interface
uses windows, forms, System.SysUtils , dialogs;
procedure loadmainapp;
type
TcreaFunc = function (Width: Integer; Height: Integer; hw:HWnd; app: TApplication): boolean; stdcall;
TshowFunc = procedure stdcall;
TCloseAppFunc = procedure stdcall;
var
dllHandle : THandle = 0;
creaFunc : TcreaFunc;
showFunc : TshowFunc;
CloseAppFunc: TCloseAppFunc;
implementation
uses Mainapp;
procedure loadmainapp;
var
S: widestring;
PW: PWideChar;
begin
S := 'dllapp.dll';
pw:=pwidechar(widestring(s));
dllHandle := LoadLibrary(pw);
if dllHandle <> 0 then
begin
#creaFunc := GetProcAddress(dllHandle, 'createApp');
#showFunc := GetProcAddress(dllHandle, 'showapp');
if Assigned (creaFunc) then
begin
creaFunc(mainfrm.panel1.Width, mainfrm.panel1.Height, mainfrm.panel1.Handle, Application);
DisFunc;
end
else
ShowMessage('ERROR');
end
else
begin
ShowMessage('ERROR');
end;
end;
end.
Active Form
unit activeform;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ActiveX, AxCtrls, Frmldr_TLB, StdVcl, Vcl.ExtCtrls, ShlObj, Vcl.StdCtrls, SHDocVw, MSHTML;
type
TActiveFrmldr = class(TActiveForm, IActiveFrmldr)
mpanl: TPanel;
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
protected
{ Protected declarations }
public
{ Public declarations }
end;
implementation
uses ComObj, ComServ, Mainapp, libacload;
{$R *.DFM}
{ TActiveFrmldr }
procedure TActiveFrmldr.FormDestroy(Sender: TObject);
begin
if dllHandle <> 0 then
begin
#CloseAppFunc := GetProcAddress(dllHandle, 'closeApp');
CloseAppFunc;
FreeLibrary(dllHandle); //release dll
end;
if Assigned(mainfrm) then
try
FreeAndNil(mainfrm);
except
end;
end;
procedure TActiveFrmldr.Timer1Timer(Sender: TObject);
begin
Timer1.Enabled := False;
mainfrm.Parent := mpanl;
mainfrm.Left := 0;
mainfrm.Top := 0;
mainfrm.Width := self.Width;
mainfrm.Height := self.Height;
mainfrm.Align := alClient;
mainfrm.Show;
end;
procedure TActiveFrmldr.FormCreate(Sender: TObject);
begin
Application.CreateForm(Tmainfrm, mainfrm);
Timer1.Enabled := True;
end;
initialization
TActiveFormFactory.Create(
ComServer,
TActiveFormControl,
TActiveFrmldr,
Class_ActiveFrmldr,
0,
'',
OLEMISC_SIMPLEFRAME or OLEMISC_ACTSLIKELABEL,
tmApartment);
finalization
end.
Main app Form that call load library function
unit Mainapp;
interface
uses
Windows, Messages, System.SysUtils, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, System.Classes, libacload,
Vcl.Controls, Vcl.StdCtrls;
type
Tmainfrm = class(TForm)
Panel1: TPanel;
Timer1: TTimer;
Timer2: TTimer;
procedure FormShow(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure Timer2Timer(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
mainfrm: Tmainfrm;
implementation
Uses loadapp;
{$R *.dfm}
procedure Tmainfrm.FormShow(Sender: TObject);
begin
Timer1.Enabled := True;
end;
procedure Tmainfrm.Timer1Timer(Sender: TObject);
begin
Timer1.Enabled := False;
loadmainapp;
end;
procedure Tmainfrm.Timer2Timer(Sender: TObject);
begin
checksynchronize; // i do this to check some thread in activex it self
end;
end.
The error means that CheckSynchronize() is being called in a thread whose ThreadID does not match the RTL's global System.MainThreadID variable.
A DLL does not have a main thread of its own. MainThreadID gets initialized to whatever thread is initializing the DLL. So, if your DLL is creating its GUI in a different thread than the one that is initializing your DLL, CheckSynchronize() (and TThread.Synchronize(), and TThread.Queue()) will not work unless you manually update the MainThreadID variable to the ThreadID that is running your GUI. Do that before creating your worker thread, eg:
if IsLibrary then
MainThreadID := GetCurrentThreadID;
Form1 := TForm1.Create(nil);
Or:
procedure TForm1.FormCreate(Sender: TObject);
begin
if IsLibrary then
MainThreadID := GetCurrentThreadID;
end;
Or:
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Timer1.Enabled := False;
if IsLibrary then
MainThreadID := GetCurrentThreadID;
APPTHREAD := TAPPTHREAD.Create(false, CallbackProc);
Timer2.Enabled := True;
end;
My initial question was misleading, I'll try to improve it:
I was able to write a small delphi programme, which is able to do a threaded download by using indy's idHTTP. It consists of 2 files:
the form:
interface
type
TForm1 = class(TForm)
Button1: TButton;
Label1: TLabel;
Button2: TButton;
IdSSLIOHandlerSocketOpenSSL1: TIdSSLIOHandlerSocketOpenSSL;
IdAntiFreeze1: TIdAntiFreeze;
IdHTTP: TIdHTTP;
ProgressBar1: TProgressBar;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
procedure UpdateLabel(BytesDone: Integer);
procedure UpdateProgressBar(AWorkCount: Int64);
procedure InitProgressBar(AWorkCountMax: Int64);
procedure ResetProgressBar;
end;
var
Form1: TForm1;
uStopDownloading: Boolean;
implementation
{$R *.dfm}
uses Unit2;
procedure TForm1.Button1Click(Sender: TObject);
var
HTTPThread: TIdHTTPThread;
begin
HTTPThread := TIdHTTPThread.Create(True);
HTTPThread.Url := 'https://www.bot-factory.de/tmp/lorem7.txt';
HTTPThread.EncodedStr := '';
HTTPThread.Filename := 'C:\test.txt';
HTTPThread.FreeOnTerminate := True;
HTTPThread.Resume;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
idhttp.Disconnect;
end;
procedure TForm1.UpdateLabel(BytesDone: Integer);
begin
Label1.caption := format('%.0n',[extended(BytesDone+0.0)]) +' bytes loaded.';
end;
procedure TForm1.UpdateProgressBar(AWorkCount: Int64);
begin
ProgressBar1.Position := AWorkCount;
end;
procedure TForm1.InitProgressBar(AWorkCountMax: Int64);
begin
Screen.Cursor := crHourGlass;
ProgressBar1.Max := AWorkCountMax;
ProgressBar1.Position := 0;
end;
procedure TForm1.ResetProgressBar;
begin
Screen.Cursor := crDefault;
showmessage('Job is done');
end;
END.
And the Thread-Unit:
interface
uses
Classes, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, IdHTTP, sysutils;
type
TIdHTTPThread = class(TThread)
private
FURL: AnsiString;
FencodedStr: string;
FFilename: AnsiString;
FBytesDone,FProgress,FWorkCountMax: Int64;
IdHTTP: TIdHTTP;
procedure OnWork(ASender: TObject; AWorkMode: TWorkMode; AWorkCount: Int64);
procedure OnWorkBegin(ASender: TObject; AWorkMode: TWorkMode; AWorkCountMax: Int64);
procedure OnWorkEnd(ASender: TObject; AWorkMode: TWorkMode);
procedure Updatelabel;
procedure UpdateProgressBar;
procedure InitProgressBar;
procedure ResetProgressBar;
procedure Disconnect;
public
Constructor Create(CreateSuspended: Boolean);
Destructor Destroy; override;
property Url: AnsiString read FURL write FUrl;
property encodedstr: String read FencodedStr write FencodedStr;
property Filename: AnsiString read FFilename write FFilename;
protected
procedure Execute; override;
end;
implementation
uses
Unit1; // Formular Unit
constructor TIdHTTPThread.Create(CreateSuspended: Boolean);
begin
inherited Create(Suspended);
IdHTTP := TIdHTTP.Create;
IdHTTP.OnWork := OnWork;
IdHTTP.OnWorkBegin := OnWorkBegin;
IdHTTP.OnWorkEnd := OnWorkEnd;
//IdHTTP.Disconnect := Disconnect;
end;
destructor TIdHTTPThread.Destroy;
begin
IdHTTP.Free;
inherited;
end;
procedure TIdHTTPThread.Execute;
var
DestStream: TFileStream;
begin
DestStream := TFileStream.Create(Filename, fmCreate);
try
IdHTTP.Get(Url, DestStream);
finally
DestStream.Free;
end;
end;
procedure TIdHTTPThread.OnWork(ASender: TObject; AWorkMode: TWorkMode; AWorkCount: Int64);
begin
FBytesDone := AWorkCount;
FProgress := AWorkCount;
Synchronize(Updatelabel);
Synchronize(UpdateProgressBar);
end;
procedure TIdHTTPThread.OnWorkBegin(ASender: TObject; AWorkMode: TWorkMode; AWorkCountMax: Int64);
begin
FWorkCountMax := AWorkCountMax;
Synchronize(InitProgressBar);
end;
procedure TIdHTTPThread.Disconnect;
begin
idhttp.Disconnect;
end;
procedure TIdHTTPThread.OnWorkEnd(ASender: TObject; AWorkMode: TWorkMode);
begin
Synchronize(ResetProgressBar);
end;
procedure TIdHTTPThread.Updatelabel;
begin
Form1.UpdateLabel(FBytesDone);
end;
procedure TIdHTTPThread.UpdateProgressBar;
begin
Form1.UpdateProgressBar(FProgress);
end;
procedure TIdHTTPThread.InitProgressBar;
begin
Form1.initProgressBar(FWorkCountMax);
end;
procedure TIdHTTPThread.resetProgressBar;
begin
Form1.resetProgressBar;
end;
END.
I have in fact 2 questions:
How can I interrupt the download of a (large) file ? I know that
idhttp.disconnect should do the trick, but I do not know how to use it properly in my thread.
And furthermore: how can I use POST instead of GET?
I need to run this POST in a thread:
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
//submit_post
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
Procedure submit_post(url_string,EncodedStr,filename:string);
var
aStream: TMemoryStream;
Params: TStringStream;
begin
astream := TMemoryStream.create;
Params := TStringStream.create('');
Form1.IdHTTP.Request.Clear;
Form1.IdHTTP.HandleRedirects := TRUE;
try
with Form1.IdHTTP do
begin
Params.WriteString(EncodedStr);
Request.ContentType := 'application/x-www-form-urlencoded';
Request.Charset := 'utf-8';
try
Response.KeepAlive := False;
Post(url_string, params, astream);
except
on E: Exception do
begin
exit;
end;
end;
end;
astream.WriteBuffer(#0' ', 1);
astream.Position := 0;
astream.SaveToFile(filename);
finally
astream.Free;
Params.Free;
end;
end;
What is the best way to update a status bar in mainform from one tthread class object.
For Example, I have one TThread object that make a very big quanty of stuff and i want that the verbose message acording to what soft do you do appear on status bar.
Create the thread with a reference to a callback method, which can be called synchonized if assigned.
Example;
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TInfoMessageCall=Procedure (const info:String) of object;
TMyThread=Class(TThread)
Constructor Create(Susp:Boolean;CallBack:TInfoMessageCall);overload;
Procedure Execute;override;
private
FMessage:String;
FInfoProc:TInfoMessageCall;
Procedure CallCallBack;
End;
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
procedure ACallBack(const s: String);
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{ TMyThread }
Procedure TForm1.ACallBack(Const s:String);
begin
Caption := s;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
With TMyThread.Create(false,ACallBack) do
FreeOnTerminate := true;
end;
procedure TMyThread.CallCallBack;
begin
if Assigned(FInfoProc) then FInfoProc(FMessage);
end;
constructor TMyThread.Create(Susp: Boolean; CallBack: TInfoMessageCall);
begin
Inherited Create(Susp);
FInfoProc := CallBack;
end;
procedure TMyThread.Execute;
var
i:Integer;
begin
inherited;
for I := 1 to 10 do
begin
FMessage := Format('Info %d',[i]);
Synchronize(CallCallBack);
Sleep(200);
end;
end;
end.
I am using Delphi 2007 & Indy 10; I am a bit of a Delphi noob so apologies if I have missed something obvious...
Background: I have a simple server app which simply sends the word "PING" when you connect to its port. It will also respond if it receives the word "PONG". This is working fine, I have manually tested this using netcat/wireshark.
I am trying to code my client to connect to the port and automatically respond to the word PING whenever it receives it. I have created a simple form with a button to manually connect.
The client connects, but it does not respond to the word PING.
I think the problem lies with:
TLog.AddMsg(FConn.IOHandler.ReadLn);
My debug log reports only as far as "DEBUG: TReadingThread.Execute - FConn.Connected".
My client code:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, IdCustomTransparentProxy, IdSocks, IdBaseComponent,
IdComponent, IdIOHandler, IdIOHandlerSocket, IdIOHandlerStack,
IdTCPConnection, IdTCPClient, IdSync;
type
TReadingThread = class(TThread)
protected
FConn: TIdTCPConnection;
procedure Execute; override;
public
constructor Create(AConn: TIdTCPConnection); reintroduce;
end;
TLog = class(TIdSync)
protected
FMsg: String;
procedure DoSynchronize; override;
public
constructor Create(const AMsg: String);
class procedure AddMsg(const AMsg: String);
end;
TForm1 = class(TForm)
Memo1: TMemo;
Button1: TButton;
IdIOHandlerStack1: TIdIOHandlerStack;
client: TIdTCPClient;
IdSocksInfo1: TIdSocksInfo;
procedure Button1Click(Sender: TObject);
procedure clientConnected(Sender: TObject);
procedure clientDisconnected(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
rt: TReadingThread = nil;
implementation
{$R *.dfm}
constructor TReadingThread.Create(AConn: TIdTCPConnection);
begin
Form1.Memo1.Lines.Add('DEBUG: TReadingThread.Create'); // Debug
FConn := AConn;
inherited Create(False);
end;
procedure TReadingThread.Execute;
begin
Form1.Memo1.Lines.Add('DEBUG: TReadingThread.Execute'); // Debug
while not Terminated and FConn.Connected do
begin
Form1.Memo1.Lines.Add('DEBUG: TReadingThread.Execute - FConn.Connected'); // Debug
TLog.AddMsg(FConn.IOHandler.ReadLn);
end;
end;
constructor TLog.Create(const AMsg: String);
begin
Form1.Memo1.Lines.Add('DEBUG: TLog.Create'); // Debug
FMsg := AMsg;
inherited Create;
end;
procedure TLog.DoSynchronize;
var
cmd : string;
begin
Form1.Memo1.Lines.Add('DEBUG: TLog.DoSynchronize'); // Debug
cmd := copy(FMsg, 1, 1);
if cmd='PING' then begin
Form1.client.Socket.WriteLn('PONG');
end
end;
class procedure TLog.AddMsg(const AMsg: String);
begin
Form1.Memo1.Lines.Add('DEBUG: TLog.AddMsg'); // Debug
with Create(AMsg) do try
Synchronize;
finally
Free;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Memo1.Clear;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Host : String;
Port : Integer;
begin
Host := '127.0.0.1';
Port := StrToInt('1234');
client.Host := Host;
client.Port := Port;
with client do
begin
try
Connect;
except
on E: Exception do
Memo1.Lines.Add('Error: ' + E.Message);
end;
end;
end;
procedure TForm1.clientConnected(Sender: TObject);
begin
Form1.Memo1.Lines.Add('DEBUG: TForm1.clientConnected'); // Debug
rt := TReadingThread.Create(client);
end;
procedure TForm1.clientDisconnected(Sender: TObject);
begin
Form1.Memo1.Lines.Add('DEBUG: TForm1.clientDisconnected'); // Debug
if rt <> nil then
begin
rt.Terminate;
rt.WaitFor;
FreeAndNil(rt);
end;
end;
end.
Any help/advice would be appreciated.
Thanks
The reading thread is directly accessing Form1.Memo1, which is not thread safe and can cause deadlocks, crashes, corrupted memory, etc. So it is possible that the reading thread is not even reaching the ReadLn() call at all. You MUST synchronize ALL access to UI controls to the main thread, no matter how trivial the access actually is. Just don't risk it.
Also, you are doing your thread's ping/pong logic inside of TLog itself, where it does not belong. Not to mention that you are truncating the cmd to only its first character before checking its value, so it will NEVER detect a PING command. You need to move the logic back into the thread, where it really belongs, and remove the truncation.
Try this:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, IdCustomTransparentProxy, IdSocks, IdBaseComponent,
IdComponent, IdIOHandler, IdIOHandlerSocket, IdIOHandlerStack,
IdTCPConnection, IdTCPClient, IdSync;
type
TReadingThread = class(TThread)
protected
FConn: TIdTCPConnection;
procedure Execute; override;
procedure DoTerminate; override;
public
constructor Create(AConn: TIdTCPConnection); reintroduce;
end;
TLog = class(TIdSync)
protected
FMsg: String;
procedure DoSynchronize; override;
public
constructor Create(const AMsg: String);
class procedure AddMsg(const AMsg: String);
end;
TForm1 = class(TForm)
Memo1: TMemo;
Button1: TButton;
IdIOHandlerStack1: TIdIOHandlerStack;
client: TIdTCPClient;
IdSocksInfo1: TIdSocksInfo;
procedure Button1Click(Sender: TObject);
procedure clientConnected(Sender: TObject);
procedure clientDisconnected(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
rt: TReadingThread = nil;
implementation
{$R *.dfm}
constructor TReadingThread.Create(AConn: TIdTCPConnection);
begin
TLog.AddMsg('DEBUG: TReadingThread.Create');
FConn := AConn;
inherited Create(False);
end;
procedure TReadingThread.Execute;
var
cmd: string;
begin
TLog.AddMsg('DEBUG: TReadingThread.Execute');
while not Terminated do
begin
cmd := FConn.IOHandler.ReadLn;
TLog.AddMsg('DEBUG: TReadingThread.Execute. Cmd: ' + cmd);
if cmd = 'PING' then begin
FConn.IOHandler.WriteLn('PONG');
end
end;
end;
procedure TReadingThread.DoTerminate;
begin
TLog.AddMsg('DEBUG: TReadingThread.DoTerminate');
inherited;
end;
constructor TLog.Create(const AMsg: String);
begin
inherited Create;
FMsg := AMsg;
end;
procedure TLog.DoSynchronize;
begin
Form1.Memo1.Lines.Add(FMsg);
end;
class procedure TLog.AddMsg(const AMsg: String);
begin
with Create(AMsg) do
try
Synchronize;
finally
Free;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Memo1.Clear;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Host : String;
Port : Integer;
begin
Host := '127.0.0.1';
Port := StrToInt('1234');
client.Host := Host;
client.Port := Port;
try
client.Connect;
except
on E: Exception do
TLog.AddMsg('Error: ' + E.Message);
end;
end;
end;
procedure TForm1.clientConnected(Sender: TObject);
begin
TLog.AddMsg('DEBUG: TForm1.clientConnected');
rt := TReadingThread.Create(client);
end;
procedure TForm1.clientDisconnected(Sender: TObject);
begin
TLog.AddMsg('DEBUG: TForm1.clientDisconnected');
if rt <> nil then
begin
rt.Terminate;
rt.WaitFor;
FreeAndNil(rt);
end;
end;
end.
If that still does not work, then make sure the server is actually delimiting the PING string with a CRLF sequence, or at least a LF character (which is the minimum that ReadLn() looks for by default).
'MyThread' does not run. I do not know whether the problem happens on 'DataTransferServiceStart' procedure. I guess the 'DataTransferServiceStart' procedure does not execute. IDE is Delphi XE. Please help me, thank you very much.
Thread's Unit:
unit Unit_MyThread;
interface
uses
Classes, SysUtils;
type
TMyThread = class(TThread)
private
{ Private declarations }
protected
procedure Execute; override;
end;
implementation
procedure TMyThread.Execute;
var
log: TextFile;
logPath: String;
i: Integer;
begin
logPath := 'd:\test.log';
AssignFile(log, logPath);
Append(log);
i := 0;
while not self.Terminated do
begin
Sleep(1);
Writeln(log, IntToStr(i));
if i=10 then
Terminate;
i := i + 1;
end;
CloseFile(log);
end;
end.
Main Service Unit:
unit Unit_main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, SvcMgr, Dialogs,
ExtCtrls, DB, ADODB, Unit_MyThread;
type
TDataTransferService = class(TService)
DBSrc: TADOConnection;
procedure DataTransferServiceStart(Sender: TService; var Started: Boolean);
procedure DataTransferServiceContinue(Sender: TService; var Continued: Boolean);
procedure DataTransferServicePause(Sender: TService; var Paused: Boolean);
procedure DataTransferServiceStop(Sender: TService; var Stopped: Boolean);
public
function GetServiceController: TServiceController; override;
end;
var
DataTransferService: TDataTransferService;
MyThread: TMyThread;
implementation
{$R *.DFM}
procedure ServiceController(CtrlCode: DWord); stdcall;
begin
DataTransferService.Controller(CtrlCode);
end;
function TDataTransferService.GetServiceController: TServiceController;
begin
Result := ServiceController;
end;
procedure TDataTransferService.DataTransferServiceStart(Sender: TService;
var Started: Boolean);
begin
MyThread := TMyThread.Create(False);
Started := True;
end;
procedure TDataTransferService.DataTransferServiceContinue(Sender: TService;
var Continued: Boolean);
begin
MyThread.Start;
Continued := True;
end;
procedure TDataTransferService.DataTransferServicePause(Sender: TService;
var Paused: Boolean);
begin
MyThread.Suspended := true;
Paused := True;
end;
procedure TDataTransferService.DataTransferServiceStop(Sender: TService;
var Stopped: Boolean);
begin
MyThread.Terminate;
Stopped := True;
end;
end.
Your service is most likely failing to start because you have a TADOConnection component dropped into your service. You cannot do this in services. Since ADO is COM, you must initialize each thread with CoInitialize(nil) and CoUninitialize, and only create/use your database components within this.
uses
ActiveX;
procedure TDataTransferService.DataTransferServiceStart(Sender: TService;
var Started: Boolean);
begin
CoInitialize(nil);
DBSrc:= TADOConnection.Create(nil);
//Initialize and Connect DBSrc
MyThread := TMyThread.Create(False);
Started := True;
end;
procedure TDataTransferService.DataTransferServiceStop(Sender: TService;
var Stopped: Boolean);
begin
MyThread.Terminate;
//Disconnect DBSrc
DBSrc.Free;
CoUninitialize;
Stopped := True;
end;
Read here: Ok to use TADOConnection in threads