I have tried to use the multi-treading log solution described here: Delphi multi-threading file write: I/O error 32.
I have created an empty Delphi ISAPI project in order to test the TThreadFileLog class described in the above link.
When the instanziated log object is disposed in the finalize section (recycling the IIS app-pool) the ISAPI DLL is not released correctly and a whole IIS restart is necessary.
Might someone suggest me how to correctly free the log object? (I am a mechanical engineer so I may lack of some programming principles).
unit LogUnit;
interface
uses Winapi.Windows, System.Classes, System.SysUtils, ThreadFileLog;
type
PLogRequest = ^TLogRequest;
TLogRequest = record
LogText: String;
end;
TThreadFileLog = class(TObject)
private
FFileName: String;
FThreadPool: TThreadPool;
procedure HandleLogRequest(Data: Pointer; AThread: TThread);
public
constructor Create(const FileName: string);
destructor Destroy; override;
procedure Log(const LogText: string);
end;
var log: TThreadFileLog;
implementation
{ TThreadFileLog }
constructor TThreadFileLog.Create(const FileName: string);
begin
FFileName := FileName;
FThreadPool := TThreadPool.Create(HandleLogRequest, 1);
end;
destructor TThreadFileLog.Destroy;
begin
FThreadPool.Free;
inherited;
end;
procedure TThreadFileLog.HandleLogRequest(Data: Pointer; AThread: TThread);
var
Request: PLogRequest;
F: TextFile;
begin
Request := Data;
try
AssignFile(F, FFileName);
if not FileExists(FFileName) then
Rewrite(F)
else
Append(F);
try
Writeln(F, DateTimeToStr(Now) + ': ' + Request^.LogText);
finally
CloseFile(F);
end;
finally
Dispose(Request);
end;
end;
procedure TThreadFileLog.Log(const LogText: string);
var
Request: PLogRequest;
begin
New(Request);
Request^.LogText := LogText;
FThreadPool.Add(Request);
end;
initialization
OutputDebugString('I N I T');
log := TThreadFileLog.Create('C:\Temp\Test.log'); // <-- OK
finalization
log.Free; // *** some IIS problem here when app-pool is recycled (need to restart the whole IIS)
OutputDebugString('E N D'); // *** and this is never reached
end.
unit LogIsapiWebModuleUnit;
interface
uses System.SysUtils, System.Classes, Web.HTTPApp, Winapi.Windows;
type
TWebModule1 = class(TWebModule)
procedure WebModule1DefaultHandlerAction(Sender: TObject; Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
private
{ Private declarations }
public
{ Public declarations }
end;
var
WebModuleClass: TComponentClass = TWebModule1;
implementation
{$R *.dfm}
uses LogUnit;
procedure TWebModule1.WebModule1DefaultHandlerAction(Sender: TObject; Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
begin
log.Log('WEBMODULE1 DefaultHandlerAction');
Response.Content :=
'<html>' +
'<head><title>Web Server Application</title></head>' +
'<body>Web Server Application</body>' +
'</html>';
end;
Thanks to the valuable clue of Stijn Sanders I have made additional search and probably found a way to resolve the problem like this:
library TestIsapiProject;
uses
Winapi.Windows,
Winapi.ActiveX,
System.Win.ComObj,
Web.WebBroker,
Web.Win.ISAPIApp,
Web.Win.ISAPIThreadPool,
LogUnit in 'LogUnit.pas',
TestIsapiMainWebModuleUnit in 'TestIsapiMainWebModuleUnit.pas' {WebModule1: TWebModule};
function TerminateExtension(dwFlags: dword): bool; stdcall;
begin
// as per Microsoft "TerminateExtension provides a place to
// put code that cleans up threads or de-allocate resources
OutputDebugString('TerminateExtension BEGIN');
log.Free;
OutputDebugString('TerminateExtension END');
Result := Web.Win.ISAPIThreadPool.TerminateExtension(dwFlags);
end;
exports
GetExtensionVersion,
HttpExtensionProc,
TerminateExtension;
begin
CoInitFlags := COINIT_MULTITHREADED;
Application.Initialize;
Application.WebModuleClass := WebModuleClass;
Application.Run;
end.
Also I have found this article that illustrrate exactly the problem and propose this other solution. But as far I can verify it seems to me the DoTerminate is never called.
library TestIsapiProject;
uses
Winapi.Windows,
Winapi.ActiveX,
System.Win.ComObj,
Web.WebBroker,
Web.Win.ISAPIApp,
Web.Win.ISAPIThreadPool,
LogUnit in 'LogUnit.pas',
TestIsapiMainWebModuleUnit in 'TestIsapiMainWebModuleUnit.pas' {WebModule1: TWebModule};
procedure DoTerminate;
begin
// free global objects and wait/terminate threads here
OutputDebugString('TerminateExtension BEGIN');
log.Free;
OutputDebugString('TerminateExtension END');
end;
exports
GetExtensionVersion,
HttpExtensionProc,
TerminateExtension;
begin
CoInitFlags := COINIT_MULTITHREADED;
Application.Initialize;
Application.WebModuleClass := WebModuleClass;
TISAPIApplication(Application).OnTerminate := DoTerminate; // added
Application.Run;
end.
Thanks.
Does your ISAPI DLL export a function TerminateExtension? It's advised to call all cleaning-up code from there and not depend on finalization sections to do their work.
Related
I do something wrong, but what exactly?
I have simple DLL with thread. From App I put message in DLL queue, and DLL thread put message to callback.
When I use push in the application not in main thread everything fine.
Also everything is fine if I don't use DLL at all, and use thread with queue just in the application (or use DLL without TThread).
But when I push from main thread - I get random AV (in random time, in a random place)
uTestThread.pas
unit uTestThread;
interface
uses
Winapi.Windows, System.Classes, System.SyncObjs,
System.Generics.Collections;
type
TTestCallback = procedure(Data: Pointer);
TTestThread = class(TThread)
private
FLock: TRTLCriticalSection;
FQueue: TQueue<Pointer>;
FCallback: TTestCallback;
protected
procedure Execute; override;
public
constructor Create;
destructor Destroy; override;
procedure Push(Data: Pointer);
property Callback: TTestCallback read FCallback write FCallback;
end;
implementation
{ TTestThread }
constructor TTestThread.Create;
begin
InitializeCriticalSection(FLock);
FQueue:=TQueue<Pointer>.Create;
Inherited Create(True);
end;
destructor TTestThread.Destroy;
begin
FQueue.Free;
DeleteCriticalSection(FLock);
inherited;
end;
procedure TTestThread.Execute;
var
O: Pointer;
begin
while not Terminated do
begin
EnterCriticalSection(FLock);
try
if FQueue.Count > 0 then
begin
if Assigned(FCallback) then
begin
O:=FQueue.Dequeue;
FCallback(O);
end;
end;
except //on E: Exception do
//OutputDebugString(PChar('==='+E.Message+'==='));
end;
LeaveCriticalSection(FLock);
end;
end;
procedure TTestThread.Push(Data: Pointer);
begin
EnterCriticalSection(FLock);
try
FQueue.Enqueue(Data);
finally
LeaveCriticalSection(FLock);
end;
end;
end.
DLL
library lib;
uses
uTestThread in 'src\test\uTestThread.pas';
{$R *.res}
var
TT: TTestThread;
procedure Push(Data: TTestDataOut);
begin
TT.Push(Data);
end;
procedure TestThreadCreate(Callback: TTestCallback);
begin
TT:=TTestThread.Create;
TT.Callback:=Callback;
TT.Start;
end;
exports
TestThreadCreate,
Push;
begin
end.
App form
unit frmMain;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, uTestThread;
type
TForm2 = class(TForm)
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
procedure AddX;
public
{ Public declarations }
end;
var
Form2: TForm2;
procedure TestThreadCreate(Data: TTestCallback); external 'lib.dll';
procedure Push(Data: Pointer); external 'lib.dll';
implementation
{$R *.dfm}
procedure TestCallback(Data: TTestDataOut);
begin
// OutputDebugString(PChar(TStringStream(Data).DataString));
TObject(Data).Free;
end;
{ TForm2 }
procedure TForm2.AddX;
var
I: Integer;
S: string;
O: Pointer;
begin
for I:=0 to 9999 do
begin
// S:='F'+IntToStr(I)+' zzzzzzzzzzzzzzzzzzzzzzzzzWWzzzzzzzzzzzsssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssszzzx';
// O:=TStringStream.Create(S);
O:=TObject.Create;
Push(O);
end;
OutputDebugString(PChar('End'));
end;
procedure TForm2.Button1Click(Sender: TObject);
begin
TestThreadCreate(TestCallback);
end;
procedure TForm2.Button2Click(Sender: TObject);
begin
// Everything fine !!!
//
// TThread.CreateAnonymousThread(procedure
// begin
// AddX;
// end).Start;
// Get random AV !!!
AddX;
end;
end.
AV example
---------------------------
GExperts Debugger Exception Notification
---------------------------
Project lib.exe raised exception class EAccessViolation with message 'Access violation at address 004059B1. Read of address FFFFFFFC'.
---------------------------
ThreadId=2644
ProcessId=130
ThreadName=""
ExceptionMessage="Access violation at address 004059B1. Read of address FFFFFFFC"
ExceptionName="EAccessViolation"
ExceptionDisplayName="$C0000005"
ExceptionAddress=004059B1
FileName="GETMEM.INC"
LineNumber=1973
---------------------------
To demonstrate the problem, I use "while True do"
I know that FCallback should also be protected, but for demonstration I skip this
I dont create a thread in DllMain because:
https://learn.microsoft.com/en-us/windows/win32/dlls/dynamic-link-library-best-practices
As lock I tried to use TRTLCriticalSection / TCriticalSection / TMonitor / TMutex
As message I tried to use Pointer / WideString / PChar (and copy string)
As callback I tried to use Interface and Pointer to Procedure
As queue I tried TQueue<> / TList<> / TList / Array
I suspect something wrong with callback, because if I use queued item in DLL memory everything also fine
How can I run a single instance of my Delphi application on Linux?
I have seen that on Windows it is possible to achieve this through the use of TMutex or through the JclAppInst library, I have not found anything about Linux. The JclAppInst library is not usable on linux, while for what concerns the mutex using this code...
var
LMutex : TMutex;
begin
LMutex := TMutex.Create(nil, True, 'D4904154-E778-4762-9C74-BEB567DC4AA4');
if GetLastError <> 183 then
begin
//...do something
end;
FreeAndNil(LMutex);
end;
...I get the following error message:
Named synchronization objects not supported on this platform
As suggested by #AmigoJack, I solved it by locking the same file.
uMyMutex.pas:
unit uMyMutex;
interface
uses
Classes,
SysUtils,
DateUtils;
type
TMutex = class
private
FFilePath: string;
FFileStream: TFileStream;
public
constructor Create(const AName: string);
destructor Destroy; override;
end;
implementation
function GetTempDir: string;
begin
Result := '/tmp/';
end;
constructor TMutex.Create(const AName: string);
var
LMask: UInt16;
begin
inherited Create;
FFileStream := nil;
FFilePath := IncludeTrailingPathDelimiter(GetTempDir) + AName + '.pid';
LMask := fmOpenReadWrite or fmShareExclusive;
if not FileExists(FFilePath) then
LMask := LMask or fmCreate;
FFileStream := TFileStream.Create(FFilePath, LMask);
end;
destructor TMutex.Destroy;
begin
FreeAndNil(FFileStream);
inherited;
end;
end.
main.pas:
program Test;
uses
System.Classes,
uMyMutex;
var
LPidFileName: string;
begin
LPidFileName := 'test';
try
with TMutex.Create(LPidFileName) do
try
//...do something
finally
Free;
end;
except
on E: EFOpenError do
begin
Writeln(Format('Process already running [%s]; %s', [E.ClassName, E.Message]));
end;
end;
end.
Continue from my other question:
How do I pass and retrieve memory stream from my Application to/from DLL?
I have wrote the DLL using IStream as input/output. The DLL uses IXMLDocument (which at first I thought was related to the follow problem)
Tested it, and it worked well in the main UI. Problems began when I was calling the DLL from a worker thread.
The DLL:
library MyDLL;
uses
Windows,
Variants,
SysUtils,
Classes,
AxCtrls,
ActiveX,
XMLDoc,
XMLIntf;
{$R *.res}
procedure Debug(V: Variant);
begin
OutputDebugString(PChar(VarToStr(V)));
end;
procedure DoProcess(InStream, OutStream: TStream);
var
Doc: IXMLDocument;
begin
InStream.Position := 0;
Doc := TXMLDocument.Create(nil);
Doc.LoadFromStream(InStream);
// plans to do some real work...
OutStream.Position := 0;
Debug('MyDLL DoProcess OK');
end;
function Process(AInStream, AOutStream: IStream): Integer; stdcall;
var
InStream, OutStream: TStream;
begin
try
InStream := TOleStream.Create(AInStream);
try
OutStream := TOleStream.Create(AOutStream);
try
DoProcess(InStream, OutStream);
Result := 0;
finally
OutStream.Free;
end;
finally
InStream.Free;
end;
except
on E: Exception do
begin
Result := -1;
Debug('MyDLL Error: ' + E.Message);
end;
end;
end;
exports
Process;
begin
end.
And my caller application:
implementation
uses
ActiveX,ComObj;
{$R *.dfm}
procedure Debug(V: Variant);
begin
OutputDebugString(PChar(VarToStr(V)));
end;
const
MyDLL = 'MyDLL.dll';
{$DEFINE STATIC_DLL}
{$IFDEF STATIC_DLL}
function Process(AInStream, AOutStream: IStream): Integer; stdcall; external MyDLL;
{$ENDIF}
type
// Dynamic
TDLLProcessProc = function(AInStream, AOutStream: IStream): Integer; stdcall;
function DLLProcess(AInStream, AOutStream: TStream): Integer;
var
InStream, OutStream: IStream;
Module: HMODULE;
DLLProc: TDLLProcessProc;
begin
InStream := TStreamAdapter.Create(AInStream, soReference);
OutStream := TStreamAdapter.Create(AOutStream, soReference);
{$IFDEF STATIC_DLL}
Result := Process(InStream, OutStream); // Static
Exit;
{$ENDIF}
// Dynamic load DLL ...
Module := LoadLibrary(MyDLL);
if Module = 0 then RaiseLastOSError;
try
DLLProc := GetProcAddress(Module, 'Process');
if #DLLProc = nil then RaiseLastOSError;
Result := DLLProc(InStream, OutStream);
finally
FreeLibrary(Module);
end;
end;
type
TDLLThread = class(TThread)
private
FFileName: string;
public
constructor Create(CreateSuspended: Boolean; AFileName: string);
procedure Execute(); override;
end;
constructor TDLLThread.Create(CreateSuspended: Boolean; AFileName: string);
begin
FreeOnTerminate := True;
FFileName := AFileName;
inherited Create(CreateSuspended);
end;
procedure TDLLThread.Execute;
var
InStream, OutStream: TMemoryStream;
RetValue: Integer;
begin
try
//CoInitializeEx(nil, COINIT_APARTMENTTHREADED);
CoInitialize(nil);
try
InStream := TMemoryStream.Create;
try
InStream.LoadFromFile(FFileName);
OutStream := TMemoryStream.Create;
try
RetValue := DLLProcess(InStream, OutStream);
Sleep(0);
Debug('TDLLThread Result=> ' + IntToStr(RetValue));
if RetValue = 0 then
begin
Debug('TDLLThread OK');
end;
finally
OutStream.Free;
end;
finally
InStream.Free;
end;
finally
CoUninitialize;
end;
except
on E: Exception do
begin
Debug('TDLLThread Error: ' + E.Message);
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject); // Test
var
I: Integer;
begin
for I := 1 to 5 do
TDLLThread.Create(False, '1.xml');
end;
When running some tests I sometimes get Access Violations which even the exceptions blocks can't catch. And the program simply crashes with Runtime error 216 at xxxxxxx or Invalid pointer operation.
I have tried both static and dynamic DLL linking (figured maybe the dynamic linking has race condition in the LoadLibrary/FreeLibrary).
First I thought IXMLDocument was the main issue:
Doc := TXMLDocument.Create(nil);
Doc.LoadFromStream(InStream);
This sometimes randomly failed with no apparent reason with:
Invalid at the top level of the
document.
Or:
A name was started with an invalid character.
I thought maybe it used some shared resources. but even omitting these lines caused AVs!
So the DLL is practically doing nothing special.
I also Don't see anything special which could infect DLLMain.
I have no Idea what is going on... Can someone suggest how to handle this situation? (Can someone reproduce this behavior?)
EDIT: I just wanted to add a related question (with similar IsMultiThread solution):
Delphi DLL - thread safe
And some tips about IsMultiThread:
IsMultiThread Variable
The memory manager in Delphi has optimisations for single threaded use. These are enabled by default. If your code is multi-threaded then this optimisation needs to be disabled. Do that by setting IsMultiThread to True.
In a module that creates a Delphi thread, the framework sets IsMultiThread to True when a thread is created. In your program the threads are created by the host and so nothing in the library sets IsMultiThread to True. So you must do that explicitly in the DLL. In the main section of the library .dpr file write this:
begin
IsMultiThread := True;
end.
I need to get received string before page is loaded (to use with asterix http AMI events).
So i am trying to access received string in OnWork event of idHttp, but I am getting error:
var
Form2: TForm2;
s:TStringStream;
procedure TForm2.Button1Click(Sender: TObject);
begin
s:=TStringStream.Create;
idhttp1.Get('http://website.com:8088/asterisk/rawman?action=waitevent&timeout=10',s);
showmessage(s.DataString); //NO ERROR
end;
procedure TForm2.IdHTTP1Work(ASender: TObject; AWorkMode: TWorkMode;
AWorkCount: Int64);
begin
showmessage(s.DataString); //ERROR HERE
end;
UPDATE:
I created custom class (TAMIStringStream) as Remy Lebeau adviced, but still getting an error. What am I doiung wrong?
unit Unit2;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, IdBaseComponent, IdComponent,
IdTCPConnection, IdTCPClient, IdHTTP, cxGraphics, cxControls, cxLookAndFeels,
cxLookAndFeelPainters, cxContainer, cxEdit, Vcl.StdCtrls, cxTextEdit, cxMemo,
cxCheckBox;
type
TAMIStringStream = class(TStringStream)
FEncoding: TEncoding;
public
ReceivedSTR:string;
function Write(const Buffer; Count: Longint): Longint; override;
end;
TForm2 = class(TForm)
IdHTTP1: TIdHTTP;
Button1: TButton;
cxCheckBox1: TcxCheckBox;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form2: TForm2;
s:TAMIStringStream;
implementation
{$R *.dfm}
function TAMIStringStream.Write(const Buffer; Count: Longint): Longint;
var t:string;
begin
Inherited;
t := FEncoding.GetString(Bytes, Position - Count, Count);
form2.memo1.lines.add(t);
ReceivedSTR := ReceivedSTR + t;
end;
procedure TForm2.Button1Click(Sender: TObject);
begin
idhttp1.Get('http://website.com:8088/asterisk/rawman?action=login&username=1cami&secret=111');
s:=TAMIStringStream.Create;
while cxCheckBox1.Checked do begin
idhttp1.Get('http://website.com:8088/asterisk/rawman?action=waitevent&timeout=10',s);
end;
end;
end.
To get at the server's HTTP response data while it is still being downloaded by TIdHTTP, you need to write your own TStream-derived class that overrides the virtual TStream.Write() method, and then you can pass an instance of that class to the AResponseContent parameter of TIdHTTP.Get(). Your Write() method can process data as it is being "written" to your stream (be prepared to process that data in arbitrary chunks, since it is streaming live).
Otherwise, you would have to skip TIdHTTP altogether and use TIdTCPClient instead, implementing the HTTP protocol manually so that you are in full control over reading and writing.
The "AMI over HTTP" protocol documentation (see this and this) shows how to send HTTP requests to AMI and how to poll for events (yes, you have to poll for events when using HTTP). Since the polling does not return until an event is delivered, there is not much reason to read the server's response data in-flight. TIdHTTP.Get() will block until the event is received, then you can process it as needed. So, your first approach should have been fine without a custom stream:
procedure TForm2.Button1Click(Sender: TObject);
var
s: TStringStream;
begin
idhttp1.Get('http://website.com:8088/asterisk/rawman?action=login&username=1cami&secret=111');
s := TStringStream.Create;
try
while cxCheckBox1.Checked do
begin
IdHttp1.Get('http://website.com:8088/asterisk/rawman?action=waitevent&timeout=10', s);
Memo1.Lines.Add(s.DataString);
s.Clear;
end;
finally
s.Free;
end;
end;
Alternatively:
procedure TForm2.Button1Click(Sender: TObject);
var
s: String;
begin
idhttp1.Get('http://website.com:8088/asterisk/rawman?action=login&username=1cami&secret=111');
while cxCheckBox1.Checked do
begin
s := IdHttp1.Get('http://website.com:8088/asterisk/rawman?action=waitevent&timeout=10');
Memo1.Lines.Add(s);
end;
end;
Because of TIdHTTP's blocking nature, I would suggest moving the polling into a worker thread:
procedure TMyThread.Execute;
var
http: TIdHTTP;
s: String;
begin
http := TIdHTTP.Create(nil);
try
http.Get('http://website.com:8088/asterisk/rawman?action=login&username=1cami&secret=111');
while not Terminated do
begin
s := http.Get('http://website.com:8088/asterisk/rawman?action=waitevent&timeout=10');
// do something...
end;
finally
http.Free;
end;
end;
If HTTP polling does not suit your needs, you should consider using "AMI over TCP" instead (see this and this), and use TIdTCPClient for that. You can use a timer or a thread to check for incoming data.
I created a class for writing thread-safe log in a text file using CriticalSection.
I am not an expert of CriticalSection and multi-threading programming (...and Delphi), I'm definitely doing something wrong...
unit ErrorLog;
interface
uses
Winapi.Windows, System.SysUtils;
type
TErrorLog = class
private
FTextFile : TextFile;
FLock : TRTLCriticalSection;
public
constructor Create(const aLogFilename:string);
destructor Destroy; override;
procedure Write(const ErrorText: string);
end;
implementation
constructor TErrorLog.Create(const aLogFilename:string);
begin
inherited Create;
InitializeCriticalSection(FLock);
AssignFile(FTextFile, aLogFilename);
if FileExists(aLogFilename) then
Append(FTextFile)
else
Rewrite(FTextFile);
end;
destructor TErrorLog.Destroy;
const
fmTextOpenWrite = 55218;
begin
EnterCriticalSection(FLock);
try
if TTextRec(FTextFile).Mode <> fmTextOpenWrite then
CloseFile(FTextFile);
inherited Destroy;
finally
LeaveCriticalSection(FLock);
DeleteCriticalSection(FLock);
end;
end;
procedure TErrorLog.Write(const ErrorText: string);
begin
EnterCriticalSection(FLock);
try
WriteLn(FTextFile, ErrorText);
finally
LeaveCriticalSection(FLock);
end;
end;
end.
to test the class I created a form with a timer set to 100 milliseconds:
procedure TForm1.Timer1Timer(Sender: TObject);
var
I : integer;
aErrorLog : TErrorLog;
begin
aErrorLog := nil;
for I := 0 to 1000 do begin
try
aErrorLog := TErrorLog.Create(FormatDateTime('ddmmyyyy', Now) + '.txt');
aErrorLog.Write('new line');
finally
if Assigned(aErrorLog) then FreeAndNil(aErrorLog);
end;
end;
end;
the logs are written, but occasionally raise I/O Error 32 exception on CloseFile(FTextFile) (probably because in use in another thread)
where am I doing wrong?
UPDATE:
after reading all the comments and the answers I have totally changed approach. I share my solution.
ThreadUtilities.pas
(* Implemented for Delphi3000.com Articles, 11/01/2004
Chris Baldwin
Director & Chief Architect
Alive Technology Limited
http://www.alivetechnology.com
*)
unit ThreadUtilities;
interface
uses Windows, SysUtils, Classes;
type
EThreadStackFinalized = class(Exception);
TSimpleThread = class;
// Thread Safe Pointer Queue
TThreadQueue = class
private
FFinalized: Boolean;
FIOQueue: THandle;
public
constructor Create;
destructor Destroy; override;
procedure Finalize;
procedure Push(Data: Pointer);
function Pop(var Data: Pointer): Boolean;
property Finalized: Boolean read FFinalized;
end;
TThreadExecuteEvent = procedure (Thread: TThread) of object;
TSimpleThread = class(TThread)
private
FExecuteEvent: TThreadExecuteEvent;
protected
procedure Execute(); override;
public
constructor Create(CreateSuspended: Boolean; ExecuteEvent: TThreadExecuteEvent; AFreeOnTerminate: Boolean);
end;
TThreadPoolEvent = procedure (Data: Pointer; AThread: TThread) of Object;
TThreadPool = class(TObject)
private
FThreads: TList;
FThreadQueue: TThreadQueue;
FHandlePoolEvent: TThreadPoolEvent;
procedure DoHandleThreadExecute(Thread: TThread);
public
constructor Create( HandlePoolEvent: TThreadPoolEvent; MaxThreads: Integer = 1); virtual;
destructor Destroy; override;
procedure Add(const Data: Pointer);
end;
implementation
{ TThreadQueue }
constructor TThreadQueue.Create;
begin
//-- Create IO Completion Queue
FIOQueue := CreateIOCompletionPort(INVALID_HANDLE_VALUE, 0, 0, 0);
FFinalized := False;
end;
destructor TThreadQueue.Destroy;
begin
//-- Destroy Completion Queue
if (FIOQueue <> 0) then
CloseHandle(FIOQueue);
inherited;
end;
procedure TThreadQueue.Finalize;
begin
//-- Post a finialize pointer on to the queue
PostQueuedCompletionStatus(FIOQueue, 0, 0, Pointer($FFFFFFFF));
FFinalized := True;
end;
(* Pop will return false if the queue is completed *)
function TThreadQueue.Pop(var Data: Pointer): Boolean;
var
A: Cardinal;
OL: POverLapped;
begin
Result := True;
if (not FFinalized) then
//-- Remove/Pop the first pointer from the queue or wait
GetQueuedCompletionStatus(FIOQueue, A, ULONG_PTR(Data), OL, INFINITE);
//-- Check if we have finalized the queue for completion
if FFinalized or (OL = Pointer($FFFFFFFF)) then begin
Data := nil;
Result := False;
Finalize;
end;
end;
procedure TThreadQueue.Push(Data: Pointer);
begin
if FFinalized then
Raise EThreadStackFinalized.Create('Stack is finalized');
//-- Add/Push a pointer on to the end of the queue
PostQueuedCompletionStatus(FIOQueue, 0, Cardinal(Data), nil);
end;
{ TSimpleThread }
constructor TSimpleThread.Create(CreateSuspended: Boolean;
ExecuteEvent: TThreadExecuteEvent; AFreeOnTerminate: Boolean);
begin
FreeOnTerminate := AFreeOnTerminate;
FExecuteEvent := ExecuteEvent;
inherited Create(CreateSuspended);
end;
procedure TSimpleThread.Execute;
begin
if Assigned(FExecuteEvent) then
FExecuteEvent(Self);
end;
{ TThreadPool }
procedure TThreadPool.Add(const Data: Pointer);
begin
FThreadQueue.Push(Data);
end;
constructor TThreadPool.Create(HandlePoolEvent: TThreadPoolEvent;
MaxThreads: Integer);
begin
FHandlePoolEvent := HandlePoolEvent;
FThreadQueue := TThreadQueue.Create;
FThreads := TList.Create;
while FThreads.Count < MaxThreads do
FThreads.Add(TSimpleThread.Create(False, DoHandleThreadExecute, False));
end;
destructor TThreadPool.Destroy;
var
t: Integer;
begin
FThreadQueue.Finalize;
for t := 0 to FThreads.Count-1 do
TThread(FThreads[t]).Terminate;
while (FThreads.Count > 0) do begin
TThread(FThreads[0]).WaitFor;
TThread(FThreads[0]).Free;
FThreads.Delete(0);
end;
FThreadQueue.Free;
FThreads.Free;
inherited;
end;
procedure TThreadPool.DoHandleThreadExecute(Thread: TThread);
var
Data: Pointer;
begin
while FThreadQueue.Pop(Data) and (not TSimpleThread(Thread).Terminated) do begin
try
FHandlePoolEvent(Data, Thread);
except
end;
end;
end;
end.
ThreadFileLog.pas
(* From: http://delphi.cjcsoft.net/viewthread.php?tid=45763 *)
unit ThreadFileLog;
interface
uses Windows, ThreadUtilities, System.Classes;
type
PLogRequest = ^TLogRequest;
TLogRequest = record
LogText : String;
FileName : String;
end;
TThreadFileLog = class(TObject)
private
FThreadPool: TThreadPool;
procedure HandleLogRequest(Data: Pointer; AThread: TThread);
public
constructor Create();
destructor Destroy; override;
procedure Log(const FileName, LogText: string);
end;
implementation
uses
System.SysUtils;
(* Simple reuse of a logtofile function for example *)
procedure LogToFile(const FileName, LogString: String);
var
F: TextFile;
begin
AssignFile(F, FileName);
if not FileExists(FileName) then
Rewrite(F)
else
Append(F);
try
Writeln(F, LogString);
finally
CloseFile(F);
end;
end;
constructor TThreadFileLog.Create();
begin
FThreadPool := TThreadPool.Create(HandleLogRequest, 1);
end;
destructor TThreadFileLog.Destroy;
begin
FThreadPool.Free;
inherited;
end;
procedure TThreadFileLog.HandleLogRequest(Data: Pointer; AThread: TThread);
var
Request: PLogRequest;
begin
Request := Data;
try
LogToFile(Request^.FileName, Request^.LogText);
finally
Dispose(Request);
end;
end;
procedure TThreadFileLog.Log(const FileName, LogText: string);
var
Request: PLogRequest;
begin
New(Request);
Request^.LogText := LogText;
Request^.FileName := FileName;
FThreadPool.Add(Request);
end;
end.
Basic form example
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls,
Vcl.StdCtrls, ThreadFileLog;
type
TForm1 = class(TForm)
BtnStart: TButton;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure BtnStartClick(Sender: TObject);
private
FThreadFileLog : TThreadFileLog;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.BtnStartClick(Sender: TObject);
var
I : integer;
aNow : TDateTime;
begin
aNow := Now;
for I := 0 to 500 do
FThreadFileLog.Log(
FormatDateTime('ddmmyyyyhhnn', aNow) + '.txt',
FormatDateTime('dd-mm-yyyy hh:nn:ss.zzz', aNow) + ': I: ' + I.ToString
);
ShowMessage('logs are performed!');
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FThreadFileLog := TThreadFileLog.Create();
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FThreadFileLog.Free;
ReportMemoryLeaksOnShutdown := true;
end;
end.
Output log:
30-11-2014 14.01.13.252: I: 0
30-11-2014 14.01.13.252: I: 1
30-11-2014 14.01.13.252: I: 2
30-11-2014 14.01.13.252: I: 3
30-11-2014 14.01.13.252: I: 4
30-11-2014 14.01.13.252: I: 5
30-11-2014 14.01.13.252: I: 6
30-11-2014 14.01.13.252: I: 7
30-11-2014 14.01.13.252: I: 8
30-11-2014 14.01.13.252: I: 9
...
30-11-2014 14.01.13.252: I: 500
Instead of checking TTextRec(FTextFile).Mode <> fmTextOpenWrite you should check whether your file is closed or not, and if it is not closed then you close it.
Try replacing the mentioned check with this code:
if TTextRec(FTextFile).Mode <> fmClosed then
CloseFile(FTextFile);
Edited:
This has nothing to do with antivirus locking the file. This is just a simple mistake in the destructor.
File is already opened in open write mode, original code is closing the file only when it is not in open write mode - so it is never closing the file.
Hope this explains where the mistake has happened.
As for the overall design of the logger's class. This was not the question, questions was simple, and I've provided a simple and working solution.
I think that if Simone would want us to teach him how to design logger class then he would ask for it.
If you want an error log class, where multiple threads can write to a log file, it is correct to protect the writing method with a critical section.
Now, since you will only instantiate one of those error logging objects in your application, there is no need to protect the destructor method with a critical section.
The location of your error log file should reside in the application data folder.
The I/O error 32 is: The process cannot access the file because it is being used by another process.
The reason for this sharing violation could be in your application or an external application.
Writing inside the application directory could trigger some antivirus protection for example. Or your application is holding the file open in several places with different file modes.
Your test is flawed in multiple ways:
Instantiate the error log class once at application start, and destroy it when the application closes.
Write to your error log from different threads, not from multiple iterations within a timer event.
A timer event should only execute a program sequence for a short duration.
A try / finally sequence is structured like this:
anObject := TObject.Create;
try
// Do something with anObject
finally
anObject.Free;
end;