I need to put an instance of TIdHTTPServer into DLL for some reasons. It's done like this:
Interface unit:
unit DLL.Intf;
interface
type
IServer = interface
procedure DoSomethingInterfaced();
end;
implementation
end.
Server's container:
unit Server;
interface
uses
DLL.Intf,
IdHTTPServer,
IdContext,
IdCustomHTTPServer;
type
TServer = class(TInterfacedObject, IServer)
private
FHTTP: TIdHTTPServer;
procedure HTTPCommandGet(AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo;
AResponseInfo: TIdHTTPResponseInfo);
procedure DoSomethingInterfaced();
public
constructor Create();
destructor Destroy(); override;
end;
function GetInstance(): IServer;
implementation
uses
SysUtils;
var
Inst: IServer;
function GetInstance(): IServer;
begin
if not Assigned(Inst) then
Inst := TServer.Create();
Result := Inst;
end;
constructor TServer.Create();
begin
inherited;
FHTTP := TIdHTTPServer.Create(nil);
FHTTP.OnCommandGet := HTTPCommandGet;
FHTTP.Bindings.Add().SetBinding('127.0.0.1', 15340);
FHTTP.Active := True;
end;
destructor TServer.Destroy();
begin
FHTTP.Free();
inherited;
end;
procedure TServer.DoSomethingInterfaced();
begin
end;
procedure TServer.HTTPCommandGet(AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo;
AResponseInfo: TIdHTTPResponseInfo);
begin
AResponseInfo.ContentText := '<html><h1>HELLO! ' + IntToStr(Random(100)) + '</h1></html>';
end;
end.
DLL exports the GetInstance() function:
library DLL;
uses
SysUtils,
Classes,
Server in 'Server.pas',
DLL.Intf in 'DLL.Intf.pas';
{$R *.res}
exports
GetInstance;
begin
end.
Server loads and works fine until I exit the main EXE file. The debugger has shown the main thread hangs on FHTTP.Free();.
I thought I don't need to worry about the thread synchronization because I use "Build with runtime packages" option for both EXE and DLL projects.
How can I fix this hang?
My solution was to set Active property of TIdHTTPServer to false when closing the main form of my application.
I guess the server must stop all its threads and synchronize with the main thread before exiting the message loop.
I'll check another answer as correct if it will explain the mechanics behind.
What you describe should only be happening if your code were synchronizing with the main thread inside of the TIdHTTPServer events, like OnCommandGet. But it is not doing so in the code you showed, so there should be nothing blocking the TIdHTTPServer destructor from exiting normally. Internally, the destructor does set the Active property to False, which does wait for any active threads to fully terminate. Nothing inside of TIdHTTPServer syncs with the main thread. Deactivating TIdHTTPServer from the main thread while synchronizing with the main thread would cause a deadlock (so would calling TThread.Synchronize() inside a DLL in general if Runtime Packages were disabled, which you say they are not). So what you describe makes no sense. You will just have to step through the TIdHTTPServer destructor inside the debugger to find the actual deadlock.
Related
Here is my code in DLL:
procedure TTaskTest;
begin
TTask.Run(
procedure
begin
Sleep(300);
end);
end;
exports TTaskTest;
After calling this method in host app, then call FreeLibrary will freeze host app.
After debug , I found that the program freezes at if TMonitor.Wait(FLock, Timeout) then in TLightweightEvent.WaitFor , but the debugger cannot step into TMonitor.Wait.
How to solve?
This issue was reported (RSP-13742 Problem with ITask, IFuture inside DLL).
It was closed "Works as Expected" with a remark:
To prevent this failure using ITask or IFuture from a DLL, the DLL will need to be using its own instance of TThreadPool in place of the default instance of TThreadPool.
Here is an example from Embarcadero how to handle it:
library TestLib;
uses
System.SysUtils,
System.Classes,
System.Threading;
{$R *.res}
VAR
tpool: TThreadPool;
procedure TestDelay;
begin
tpool := TThreadPool.Create;
try
TTask.Run(
procedure begin
Sleep(300);
end,
tpool
);
finally
FreeAndNil(tpool);
end;
end;
exports
TestDelay;
begin
end.
Another way is to create the threadpool when the library is loaded, and add a release procedure, which you call before calling FreeLibrary.
// In dll
procedure TestDelay;
begin
TTask.Run(
procedure begin
Sleep(300);
end,
tpool
);
end;
procedure ReleaseThreadPool;
begin
FreeAndNil(tpool);
end;
exports
TestDelay,ReleaseThreadPool;
begin
tpool := TThreadPool.Create;
end.
I wanted to realize a repetitive task in an OmniThreadLibrary worker task, that runs in another thread. The task should be executed every 3 seconds, for example.
Therefore I wrote a TOmniWorker descendant with an instance of TTimer as you can see below:
program Project14;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils,
Vcl.ExtCtrls,
Vcl.Forms,
OtlTaskControl;
type
TMyTimerWorker = class(TOmniWorker)
strict private
FTimer: TTimer;
procedure DoOnTimer(Sender: TObject);
protected
function Initialize: Boolean; override;
procedure Cleanup; override;
end;
{ TMyTimerWorker }
procedure TMyTimerWorker.Cleanup;
begin
FTimer.Free;
inherited;
end;
procedure TMyTimerWorker.DoOnTimer(Sender: TObject);
begin
Beep;
end;
function TMyTimerWorker.Initialize: Boolean;
begin
Result := inherited;
if not Result then exit;
FTimer := TTimer.Create(nil);
FTimer.OnTimer := DoOnTimer;
FTimer.Interval := 3000;
FTimer.Enabled := True; // note: this isn't necessary, but is added to avoid hints that 'Enabled' might be 'False'
end;
var
LTimerWorker: IOmniWorker;
begin
try
LTimerWorker := TMyTimerWorker.Create;
CreateTask(LTimerWorker).Unobserved.Run;
while True do
Application.ProcessMessages;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
I set breakpoints in Initialize and DoOnTimer. Former executes well but latter won't be called at all. BTW: Cleanup isn't called neither, so the task is still running.
What am I doing wrong? Is it impossible to use a TTimer in an OTL task? If yes, why?
UPDATE: I found a workaround for TTimer () but why does TTimer approach not work?
You TTimer-based code doesn't work because TTimer uses windows messages to trigger the timer event and windows messages are not processed in an OTL worker by default.
Call .MsgWait before .Run and internal worker loop will use MsgWaitForMultipleObjects instead of WaitForMultipleObjects which will allow for message processing.
Saying that, you really should not use TTimer in background tasks because - as others have said - TTimer is not threadsafe.
I found this source code from a Delphi sample codes, and
I am adding a control or component inside a Delphi dynamic DLL, I can't figure it out,
library DLLEntryLib;
uses
SysUtils,
Windows,
Dialogs,
Classes,
msHTML,
SHDocVw;
type
TMyWeb = class(TWebBrowser)
constructor create(Aowner: TComponent); override;
end;
var
web: TMyWeb;
// Initialize properties here
constructor TMyWeb.Create(AOwner: TComponent);
begin
inherited Create(Self);
end;
procedure getweb;
begin
web := TmyWeb.create(nil);
web.Navigate('http://mywebsite.com');
end;
procedure xDLLEntryPoint(dwReason: DWord);
begin
case dwReason of
DLL_PROCESS_ATTACH:
begin
getweb; //I THINK THE ERROR IS HERE, HOW TO WORK THIS OUT?
ShowMessage('Attaching to process');
end;
DLL_PROCESS_DETACH: ShowMessage('Detaching from process');
DLL_THREAD_ATTACH: MessageBeep(0);
DLL_THREAD_DETACH: MessageBeep(0);
end;
end;
begin
{ First, assign the procedure to the DLLProc variable }
DllProc := #xDLLEntryPoint;
{ Now invoke the procedure to reflect that the DLL is attaching to the
process }
xDLLEntryPoint(DLL_PROCESS_ATTACH);
end.
//IN MY APPLICATION FORM.
procedure TMainForm.btnLoadLibClick(Sender: TObject);
begin
if LibHandle = 0 then
begin
LibHandle := LoadLibrary('DLLENTRYLIB.DLL');
if LibHandle = 0 then
raise Exception.Create('Unable to Load DLL');
end
else
MessageDlg('Library already loaded', mtWarning, [mbok], 0);
end;
How do I get rid of the error?
raise to many consicutive exception
When you write:
inherited Create(Self);
you should write
inherited Create(AOwner);
You are asking the control to own itself. That just cannot work. That quite possibly leads to a non-terminated recursion if the constructor fails.
The other big problem is that you are creating a web browser control inside DllMain. That's a very big no-no. You'll want to stop doing that. Move that code into a separate exported function. Do nothing in DllMain.
Presumably the caller has already initialized COM. If not, you will need to ensure that the caller does so. If the caller is a VCL forms app then COM will be initialized automatically.
to write information on the processing state to the GUI inside a tcpserver.onexecute(..) function , i used the following command sequence
ExecuteDUMMYCommand(Global_Send_Record);
BitMap_PaintImageProcess;
TThread.Synchronize(nil, BitMap_PaintImageProcess);
The code is working well on some machines, but on a few it fails. The code execution stops atTThread.Synchronize command. I guess on these machines the function call is trapped inside a deadlock
Any chance to figure out the real problem behind ?
The procedure BitMap_PaintImageProcess , here I create a Bitmap and do a lot of painting stuff , but is seems that this code is never executed ?
I try to explain the very long code and reduce to the main points , the critical thread issues are hidden in processing the bitmap inside my Bitmapprocessingclass.
This class is accessed inside the GUIProcessing procedures of my ServerMainForm which also has the INDY TCP Server component.
{--------------- CLASS DEFINITION -----------------------------}
TBitMapProcessingClass = class()
FBitmap : TBitmap;
FList : TListOfSomething;
procedure ProcessTheBitmap(....);
......
(many many functions);
procedure Init;
procedure Free;
Procedure Create;
end;
TMainform = class(TForm)
MyServer : TIdTCPServer;
aBitMaoProcessingClass : TBitMaoProcessingClass;
procedure BitMap_PaintImageProcess;
procedure BitMap_ListProcess;
.....
end;
{------------------------- Implemantation ------------------------------}
procedure TMainform.IndyTCPServer.Onexecute()
begin
.......
ExecuteDUMMYCommand(Global_Send_Record);
BitMap_PaintImageProcess;
TThread.Synchronize(nil, BitMap_PaintImageProcess);
.......
end;
procedure TMainform.BitMap_PaintImageProcess;
begin
DoSomeServerVCLStuff(....);
aBitMapProcessingClass.ProcessTheBitmap;
DoSomeServerVCLStuff(....);
end;
Having no idea what BitMap_PaintImageProcess() does in fact, I have a few suppositions:
In the TThread.Synchronize call you try to read some data from the socket/idContext, but the data is not yet available. This will block the main thread until the data becomes available. But Indy's thread that is responsible for reading from the underlying socket buffer is currently blocked by your TThread.Synchronize call in the OnExecute event i.e. deadlock occurs;
In the TThread.Synchronize call you use Application.ProcessMessages (a common mistake);
In the OnExecute event you enter a critical section. Then during the TThread.Synchronize call you try to enter the same critical section again;
You modify the GUI in the onExecute event. Because onExecute is not thread safe, accessing VCL/FM from Indy's thread could lead to unpredictable results, including random deadlocks (hard to find).
I would suggest to use MadExcept / Eurekalog. They both have options to check if the main thread is "frozen". When that happens (during the deadlock) they will show you the current call stack. Having the call stack you can figure out which function is causing the deadlock.
Regarding the posted code:
procedure TMainform.IndyTCPServer.Onexecute()
begin
.......
ExecuteDUMMYCommand(Global_Send_Record);
BitMap_PaintImageProcess; //-> You do VCL stuff in the context of Indy's thread!
TThread.Synchronize(nil, BitMap_PaintImageProcess);
end;
In the BitMap_PaintImageProcess() you call DoSomeServerVCLStuff(....). Do not forget that OnExecute is fired from Indy's thread for the current context. I.e. you modify VCL from another thread (other from the Main Thread) which is not thread safe.
On your comment:
...but here my complex TBitmap processing Class must be alive the whole
time my Server is active...
If you have only one (global) instance for image processing, then what will happen if another client connects, while you are still processing the old connection (think Parallel :) )? Your image processing class should be instantiated separately for each new connection/context. For GUI updating you can use TIdNotify descendant.
A possible solution:
type
{ tIdNotify Stuff }
TVclProc= procedure(imgClass: tMyImageProcessingClass) of object;
tIdNotifyDescendant = (tIdNotify)
protected
fImgClass: tMyImageProcessingClass;
fProc: TVclProc;
procedure DoNotify; override;
public
class procedure updateVcl(imgClass: tMyImageProcessingClass; vclProc: TVclProc);
end;
procedure tIdNotifyDescendant.DoNotify;
begin
inherited DoNotify;
FProc(fImgClass);
end;
class procedure tIdNotifyDescendant.updateVcl(imgClass: tMyImageProcessingClass; vclProc: TVclProc);
begin
with Create do
begin
fImgClass := imgClass;
fProc := vclProc;
Notify;
end;
end;
{ Indy stuff & other logic }
procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
begin
// Create your instance when the client connects
AContext.Data := tMyImageProcessingClass.Create;
end;
procedure TForm1.IdTCPServer1Disconnect(AContext: TIdContext);
begin
// Do cleanup
if assinged(AContext.Data) then
(AContext.Data as tMyImageProcessingClass).Free // Casting just for clarity
end;
procedure TForm1.IdTCPServer1Execute(AContext: TIdContext);
var
imgProcClass: tMyImageProcessingClass;
begin
imgProcClass := acontext.Data as tMyImageProcessingClass;
// Do image processing
// Notify GUI for the progress:
tIdNotifyDescendant.updateVcl(AContext.data as tMyImageProcessingClass);
end;
Tip: If you do JPEG processing and you use Draw() method have in mind this: TJPEGImage.Draw() is not thread safe
I added a few more details on my BitmapProcessingclass and the idea of a thread safe extension of the existing class...
I need the existing class u nchanged in others apps ... I need a extension inside my app with the indy server.
ONly one client my connect to one server, or he has to query the state of the server
type TBmpNotify = class(TIdNotify)
protected
FBMP: MyImageProcessingClass;
procedure DoNotify; override;
public
constructor Create(aBMP: MyImageProcessingClass);
function SetImageView(LL, UR: TPoint): Boolean;
procedure PaintBitMap;
function InitBitMap(x, y: Integer;
PixelFormat: TPixelFormat = pf24bit): Boolean;
destructor free;
end;
implementation
{ TBmpNotify }
constructor TBmpNotify.Create(aBMP: MyImageProcessingClass);
begin
// indise this class I also create
// class.TBitmap
// class.TList
// much more stuff ....
FBmp := MyImageProcessingClass.Create;
end;
procedure TBmpNotify.DoNotify;
begin
inherited;
end;
destructor TBmpNotify.free;
begin
FBmp.Free;
inherited;
end;
function TBmpNotify.InitBitMap(x, y: Integer;
PixelFormat: TPixelFormat): Boolean;
begin
// Write values to the List
// also modify TBitmap
// execution time of this function ~ 5 min
FBmp.InitBitMap(x,y,PixelFormat)
end;
procedure TBmpNotify.PaintBitMap;
begin
// much TBitmap, bitmap.canvas .... is used
// execution time of this function ~ 1 min
FBmp.PaintBitMap;
end;
function TBmpNotify.SetImageView(LL, UR: TPoint): Boolean;
begin
// this function takes about 1 min
FBmp.SetImageView(LL, UR);
end;
end.
I've built a few services in Delphi 7 and did not have this problem. Now that I started a new service app in XE2, it won't stop properly. I don't know if it's something I'm doing wrong or if it might be a bug in the XE2 services.
The execute procedure looks like this:
procedure TMySvc.ServiceExecute(Sender: TService);
begin
try
CoInitialize(nil);
Startup;
try
while not Terminated do begin
DoSomething; //Problem persists even when nothing's here
end;
finally
Cleanup;
CoUninitialize;
end;
except
on e: exception do begin
PostLog('EXCEPTION in Execute: '+e.Message);
end;
end;
end;
I never have an exception, as you can see I log any exception. PostLog saves to an INI file, which works fine. Now I do use ADO components, so I use CoInitialize() and CoUninitialize. It does connect to the DB and do its job properly. The problem only happens when I stop this service. Windows gives me the following message:
Then the service continues. I have to stop it a second time. The second time it does stop, but with the following message:
The log file indicates that the service did successfully free (OnDestroy event was logged) but it never successfully stopped (OnStop was never logged).
In my above code, I have two procedures Startup and Cleanup. These simply create/destroy and initialize/uninitialize my necessary things...
procedure TMySvc.Startup;
begin
FUpdateThread:= TMyUpdateThread.Create;
FUpdateThread.OnLog:= LogUpdate;
FUpdateThread.Resume;
end;
procedure TMySvc.Cleanup;
begin
FUpdateThread.Terminate;
end;
As you can see, I have a secondary thread running. This service actually has numerous threads running like this, and the main service thread is only logging the events from each thread. Each thread has different responsibilities. The threads are reporting properly, and they are also being terminated properly.
What could be causing this stop failure? If my posted code doesn't expose anything, then I can post more code later - just have to 'convert' it because of internal naming, etc.
EDIT
I just started NEW service project in Delphi XE2, and have the same issue. This is all my code below:
unit JDSvc;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, JDSvcMgr;
type
TJDService = class(TService)
procedure ServiceExecute(Sender: TService);
private
FAfterInstall: TServiceEvent;
public
function GetServiceController: TServiceController; override;
end;
var
JDService: TJDService;
implementation
{$R *.DFM}
procedure ServiceController(CtrlCode: DWord); stdcall;
begin
JDService.Controller(CtrlCode);
end;
function TJDService.GetServiceController: TServiceController;
begin
Result := ServiceController;
end;
procedure TJDService.ServiceExecute(Sender: TService);
begin
while not Terminated do begin
end;
end;
end.
look at the source code for the Execute method:
procedure TServiceThread.Execute;
var
msg: TMsg;
Started: Boolean;
begin
PeekMessage(msg, 0, WM_USER, WM_USER, PM_NOREMOVE); { Create message queue }
try
// Allow initialization of the Application object after
// StartServiceCtrlDispatcher to prevent conflicts under
// Windows 2003 Server when registering a class object with OLE.
if Application.DelayInitialize then
Application.Initialize;
FService.Status := csStartPending;
Started := True;
if Assigned(FService.OnStart) then FService.OnStart(FService, Started);
if not Started then Exit;
try
FService.Status := csRunning;
if Assigned(FService.OnExecute) then
FService.OnExecute(FService)
else
ProcessRequests(True);
ProcessRequests(False);
except
on E: Exception do
FService.LogMessage(Format(SServiceFailed,[SExecute, E.Message]));
end;
except
on E: Exception do
FService.LogMessage(Format(SServiceFailed,[SStart, E.Message]));
end;
end;
as you can see if you don't assign a OnExecute method, Delphi will process SCM requests (Service Start, Stop, ...) until the service is stopped.
When you make an loop in the Service.Execute you must to process SCM requests yourself by calling ProcessRequests(False). A good habit is not to use Service.execute and start your workerthread in the Service.OnStart event and terminating/freeing it in the Service.OnStop event.
As told in the comments, another problem lies in the FUpdateThread.Terminate part.
David Heffernan was spot on with the Free/WaitFor comment.
Make sure you end your thread in correct fashion using synchronisation objects.