Unexpected Thread behaviour calling Delphi DLL - multithreading

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.

Related

Run only a single instance of my application on Linux?

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.

Delphi ISAPI multi-threading log object not disposed correctly

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.

Threading inconsistency Delphi xe6

So, I've always faced MAJOR headaches when threading in delphi xe4-6, whether it be from threads not executing, exception handling causes app crashes, or simply the on terminate method never getting called. All the workarounds I've been instructed to use have become very tedious with issues still haunting me in XE6. My code generally has looked something like this:
procedure TmLoginForm.LoginClick(Sender: TObject);
var
l:TLoginThread;
begin
SyncTimer.Enabled:=true;
l:=TLoginThread.Create(true);
l.username:=UsernameEdit.Text;
l.password:=PasswordEdit.Text;
l.FreeOnTerminate:=true;
l.Start;
end;
procedure TLoginThread.Execute;
var
Success : Boolean;
Error : String;
begin
inherited;
Success := True;
if login(USERNAME,PASSWORD) then
begin
// do another network call maybe to get dif data.
end else
begin
Success := False;
Error := 'Login Failed. Check User/Pass combo.';
end;
Synchronize(
procedure
if success = true then
begin
DifferentForm.Show;
end else
begin
ShowMessage('Error: '+SLineBreak+Error);
end;
SyncTimer.Enabled := False;
end);
end;
And then I came across this unit from the samples in Delphi and from the forums:
unit AnonThread;
interface
uses
System.Classes, System.SysUtils, System.Generics.Collections;
type
EAnonymousThreadException = class(Exception);
TAnonymousThread<T> = class(TThread)
private
class var
CRunningThreads:TList<TThread>;
private
FThreadFunc: TFunc<T>;
FOnErrorProc: TProc<Exception>;
FOnFinishedProc: TProc<T>;
FResult: T;
FStartSuspended: Boolean;
private
procedure ThreadTerminate(Sender: TObject);
protected
procedure Execute; override;
public
constructor Create(AThreadFunc: TFunc<T>; AOnFinishedProc: TProc<T>;
AOnErrorProc: TProc<Exception>; ACreateSuspended: Boolean = False;
AFreeOnTerminate: Boolean = True);
class constructor Create;
class destructor Destroy;
end;
implementation
{$IFDEF MACOS}
uses
{$IFDEF IOS}
iOSapi.Foundation
{$ELSE}
MacApi.Foundation
{$ENDIF IOS}
;
{$ENDIF MACOS}
{ TAnonymousThread }
class constructor TAnonymousThread<T>.Create;
begin
inherited;
CRunningThreads := TList<TThread>.Create;
end;
class destructor TAnonymousThread<T>.Destroy;
begin
CRunningThreads.Free;
inherited;
end;
constructor TAnonymousThread<T>.Create(AThreadFunc: TFunc<T>; AOnFinishedProc: TProc<T>;
AOnErrorProc: TProc<Exception>; ACreateSuspended: Boolean = False; AFreeOnTerminate: Boolean = True);
begin
FOnFinishedProc := AOnFinishedProc;
FOnErrorProc := AOnErrorProc;
FThreadFunc := AThreadFunc;
OnTerminate := ThreadTerminate;
FreeOnTerminate := AFreeOnTerminate;
FStartSuspended := ACreateSuspended;
//Store a reference to this thread instance so it will play nicely in an ARC
//environment. Failure to do so can result in the TThread.Execute method
//not executing. See http://qc.embarcadero.com/wc/qcmain.aspx?d=113580
CRunningThreads.Add(Self);
inherited Create(ACreateSuspended);
end;
procedure TAnonymousThread<T>.Execute;
{$IFDEF MACOS}
var
lPool: NSAutoreleasePool;
{$ENDIF}
begin
{$IFDEF MACOS}
//Need to create an autorelease pool, otherwise any autorelease objects
//may leak.
//See https://developer.apple.com/library/ios/#documentation/Cocoa/Conceptual/MemoryMgmt/Articles/mmAutoreleasePools.html#//apple_ref/doc/uid/20000047-CJBFBEDI
lPool := TNSAutoreleasePool.Create;
try
{$ENDIF}
FResult := FThreadFunc;
{$IFDEF MACOS}
finally
lPool.drain;
end;
{$ENDIF}
end;
procedure TAnonymousThread<T>.ThreadTerminate(Sender: TObject);
var
lException: Exception;
begin
try
if Assigned(FatalException) and Assigned(FOnErrorProc) then
begin
if FatalException is Exception then
lException := Exception(FatalException)
else
lException := EAnonymousThreadException.Create(FatalException.ClassName);
FOnErrorProc(lException)
end
else if Assigned(FOnFinishedProc) then
FOnFinishedProc(FResult);
finally
CRunningThreads.Remove(Self);
end;
end;
end.
Why is that this anon thread unit above works flawlessly 100% of the time and my code crashes sometimes? For example, I can exec the same thread 6 times in a row, but then maybe on the 7th (or the first for that matter) time it causes the app to crash. No exceptions ever come up when debugging so I dont have a clue where to start fixing the issue. Also, why is it that I need a separate timer that calls "CheckSynchronize" for my code in order to GUI updates to happen but it is not needed when I use the anon thread unit?
Maybe someone can point me in the right direction to ask this question elsewhere if here is not the place. Sorry, I'm diving into documentation already, trying my best to understand.
Here is an example of a thread that may work 20 times in a row, but then randomly cause app to crash
inherited;
try
SQL:= 'Some SQL string';
if GetSQL(SQL,XMLData) then
synchronize(
procedure
var
i:Integer;
begin
try
mTasksForm.TasksListView.BeginUpdate;
if mTasksForm.TasksListView.Items.Count>0 then
mTasksForm.TasksListView.Items.Clear;
XMLDocument := TXMLDocument.Create(nil);
XMLDocument.Active:=True;
XMLDocument.Version:='1.0';
XMLDocument.LoadFromXML(XMLData);
XMLNode:=XMLDocument.DocumentElement.ChildNodes['Record'];
i:=0;
if XMLNode.ChildNodes['ID'].Text <>'' then
while XMLNode <> nil do
begin
LItem := mTasksForm.TasksListView.Items.AddItem;
with LItem do
begin
Text := XMLNode.ChildNodes['LOCATION'].Text;
Detail := XMLNode.ChildNodes['DESC'].Text +
SLineBreak+
'Assigned To: '+XMLNode.ChildNodes['NAME'].Text
tag := StrToInt(XMLNode.ChildNodes['ID'].Text);
color := TRectangle.Create(nil);
with color do
begin
if XMLNode.ChildNodes['STATUS'].Text = STATUS_DONE then
fill.Color := TAlphaColors.Lime
else if XMLNode.ChildNodes['STATUS'].Text = STATUS_OK then
fill.Color := TAlphaColors.Yellow
else
fill.Color := TAlphaColors.Crimson;
stroke.Color := fill.Color;
ButtonText := XMLNode.ChildNodes['STATUS'].Text;
end;
Bitmap := Color.MakeScreenshot;
end;
XMLNode:=XMLNode.NextSibling;
end;
finally
mTasksForm.TasksListView.EndUpdate;
for i := 0 to mTasksForm.TasksListView.Controls.Count-1 do
begin
if mTasksForm.TasksListView.Controls[I].ClassType = TSearchBox then
begin
SearchBox := TSearchBox(mTasksForm.TasksListView.Controls[I]);
Break;
end;
end;
SearchBox.Text:=' ';
SearchBox.text := ''; //have in here because if the searchbox has text, when attempting to add items then app crashes
end;
end)
else
error := 'Please check internet connection.';
finally
synchronize(
procedure
begin
if error <> '' then
ShowMessage('Erorr: '+error);
mTasksForm.Spinner.Visible:=false;
mTasksForm.SyncTimer.Enabled:=false;
end);
end;
end;
here is the GETSQL method
function GetSQL(SQL:String;var XMLData:String):Boolean;
var
PostResult,
ReturnCode : String;
PostData : TStringList;
IdHTTP : TIdHTTP;
XMLDocument : IXMLDocument;
XMLNode : IXMLNode;
Test : String;
begin
Result:=False;
XMLData:='';
XMLDocument:=TXMLDocument.Create(nil);
IdHTTP:=TIdHTTP.Create(nil);
PostData:=TStringList.Create;
PostData.Add('session='+SessionID);
PostData.Add('database='+Encode(DATABASE,''));
PostData.Add('sql='+Encode(SQL,''));
IdHTTP.Request.ContentEncoding:='UTF-8';
IdHTTP.Request.ContentType:='application/x-www-form-urlencoded';
IdHTTP.ConnectTimeout:=100000;
IdHTTP.ReadTimeout:=1000000;
try
PostResult:=IdHTTP.Post(SERVER_URL+GET_METHOD,PostData);
XMLDocument.Active:=True;
XMLDocument.Version:='1.0';
test := Decode(PostResult,'');
XMLDocument.LoadFromXML(Decode(PostResult,''));
XMLNode:=XMLDocument.DocumentElement;
try
ReturnCode:=XMLNode.ChildNodes['status'].Text;
except
ReturnCode:='200';
end;
if ReturnCode='' then begin
ReturnCode:='200';
end;
if ReturnCode='200' then begin
Result:=True;
XMLData:=Decode(PostResult,'');
end;
except
on E: Exception do begin
result:=false;
end;
end;
PostData.Free;
IdHTTP.Free;
end;

Copying files which the main thread adds to a stringlist using a thread

I have a web creation program which, when building a site, creates hundreds of files.
When the internet root folder is situated on the local pc, the program runs fine. If the internet root folder is situated on a network drive, the copying of a created page takes longer than creating the page itself (the creation of the page is fairly optimized).
I was thinking of creating the files locally, adding the names of the created files to a TStringList and let another thread copy them to the network drive (removing the copied file from the TStringList).
Howerver, I have never, ever used threads before and I couldn't find an existing answer in the other Delphi questions involving threads (if only we could use an and operator in the search field), so I am now asking if anyone has got a working example which does this (or can point me to some article with working Delphi code) ?
I am using Delphi 7.
EDITED: My sample project (thx to the original code by mghie - who is hereby thanked once again).
...
fct : TFileCopyThread;
...
procedure TfrmMain.FormCreate(Sender: TObject);
begin
if not DirectoryExists(DEST_FOLDER)
then
MkDir(DEST_FOLDER);
fct := TFileCopyThread.Create(Handle, DEST_FOLDER);
end;
procedure TfrmMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
FreeAndNil(fct);
end;
procedure TfrmMain.btnOpenClick(Sender: TObject);
var sDir : string;
Fldr : TedlFolderRtns;
i : integer;
begin
if PickFolder(sDir,'')
then begin
// one of my components, returning a filelist [non threaded :) ]
Fldr := TedlFolderRtns.Create();
Fldr.FileList(sDir,'*.*',True);
for i := 0 to Fldr.TotalFileCnt -1 do
begin
fct.AddFile( fldr.ResultList[i]);
end;
end;
end;
procedure TfrmMain.wmFileBeingCopied(var Msg: Tmessage);
var s : string;
begin
s := fct.FileBeingCopied;
if s <> ''
then
lbxFiles.Items.Add(fct.FileBeingCopied);
lblFileCount.Caption := IntToStr( fct.FileCount );
end;
and the unit
unit eFileCopyThread;
interface
uses
SysUtils, Classes, SyncObjs, Windows, Messages;
const
umFileBeingCopied = WM_USER + 1;
type
TFileCopyThread = class(TThread)
private
fCS: TCriticalSection;
fDestDir: string;
fSrcFiles: TStrings;
fFilesEvent: TEvent;
fShutdownEvent: TEvent;
fFileBeingCopied: string;
fMainWindowHandle: HWND;
fFileCount: Integer;
function GetFileBeingCopied: string;
protected
procedure Execute; override;
public
constructor Create(const MainWindowHandle:HWND; const ADestDir: string);
destructor Destroy; override;
procedure AddFile(const ASrcFileName: string);
function IsCopyingFiles: boolean;
property FileBeingCopied: string read GetFileBeingCopied;
property FileCount: Integer read fFileCount;
end;
implementation
constructor TFileCopyThread.Create(const MainWindowHandle:HWND;const ADestDir: string);
begin
inherited Create(True);
fMainWindowHandle := MainWindowHandle;
fCS := TCriticalSection.Create;
fDestDir := IncludeTrailingBackslash(ADestDir);
fSrcFiles := TStringList.Create;
fFilesEvent := TEvent.Create(nil, True, False, '');
fShutdownEvent := TEvent.Create(nil, True, False, '');
Resume;
end;
destructor TFileCopyThread.Destroy;
begin
if fShutdownEvent <> nil then
fShutdownEvent.SetEvent;
Terminate;
WaitFor;
FreeAndNil(fFilesEvent);
FreeAndNil(fShutdownEvent);
FreeAndNil(fSrcFiles);
FreeAndNil(fCS);
inherited;
end;
procedure TFileCopyThread.AddFile(const ASrcFileName: string);
begin
if ASrcFileName <> ''
then begin
fCS.Acquire;
try
fSrcFiles.Add(ASrcFileName);
fFileCount := fSrcFiles.Count;
fFilesEvent.SetEvent;
finally
fCS.Release;
end;
end;
end;
procedure TFileCopyThread.Execute;
var
Handles: array[0..1] of THandle;
Res: Cardinal;
SrcFileName, DestFileName: string;
begin
Handles[0] := fFilesEvent.Handle;
Handles[1] := fShutdownEvent.Handle;
while not Terminated do
begin
Res := WaitForMultipleObjects(2, #Handles[0], False, INFINITE);
if Res = WAIT_OBJECT_0 + 1 then
break;
if Res = WAIT_OBJECT_0
then begin
while not Terminated do
begin
fCS.Acquire;
try
if fSrcFiles.Count > 0
then begin
SrcFileName := fSrcFiles[0];
fSrcFiles.Delete(0);
fFileCount := fSrcFiles.Count;
PostMessage( fMainWindowHandle,umFileBeingCopied,0,0 );
end else
SrcFileName := '';
fFileBeingCopied := SrcFileName;
if SrcFileName = '' then
fFilesEvent.ResetEvent;
finally
fCS.Release;
end;
if SrcFileName = '' then
break;
DestFileName := fDestDir + ExtractFileName(SrcFileName);
CopyFile(PChar(SrcFileName), PChar(DestFileName), True);
end;
end;
end;
end;
function TFileCopyThread.IsCopyingFiles: boolean;
begin
fCS.Acquire;
try
Result := (fSrcFiles.Count > 0)
// last file is still being copied
or (WaitForSingleObject(fFilesEvent.Handle, 0) = WAIT_OBJECT_0);
finally
fCS.Release;
end;
end;
// new version - edited after receiving comments
function TFileCopyThread.GetFileBeingCopied: string;
begin
fCS.Acquire;
try
Result := fFileBeingCopied;
finally
fCS.Release;
end;
end;
// old version - deleted after receiving comments
//function TFileCopyThread.GetFileBeingCopied: string;
//begin
// Result := '';
// if fFileBeingCopied <> ''
// then begin
// fCS.Acquire;
// try
// Result := fFileBeingCopied;
// fFilesEvent.SetEvent;
// finally
// fCS.Release;
// end;
// end;
//end;
end.
Any additional comments would be much appreciated.
Reading the comments and looking at the examples, you find different approaches to the solutions, with pro and con comments on all of them.
The problem when trying to implement a complicated new feature (as threads are to me), is that you almost always find something which seems to work ... at first. Only later on you find out the hard way that things should have been done differently. And threads are a very good example of this.
Sites like StackOverflow are great. What a community.
A quick and dirty solution:
type
TFileCopyThread = class(TThread)
private
fCS: TCriticalSection;
fDestDir: string;
fSrcFiles: TStrings;
fFilesEvent: TEvent;
fShutdownEvent: TEvent;
protected
procedure Execute; override;
public
constructor Create(const ADestDir: string);
destructor Destroy; override;
procedure AddFile(const ASrcFileName: string);
function IsCopyingFiles: boolean;
end;
constructor TFileCopyThread.Create(const ADestDir: string);
begin
inherited Create(True);
fCS := TCriticalSection.Create;
fDestDir := IncludeTrailingBackslash(ADestDir);
fSrcFiles := TStringList.Create;
fFilesEvent := TEvent.Create(nil, True, False, '');
fShutdownEvent := TEvent.Create(nil, True, False, '');
Resume;
end;
destructor TFileCopyThread.Destroy;
begin
if fShutdownEvent <> nil then
fShutdownEvent.SetEvent;
Terminate;
WaitFor;
FreeAndNil(fFilesEvent);
FreeAndNil(fShutdownEvent);
FreeAndNil(fSrcFiles);
FreeAndNil(fCS);
inherited;
end;
procedure TFileCopyThread.AddFile(const ASrcFileName: string);
begin
if ASrcFileName <> '' then begin
fCS.Acquire;
try
fSrcFiles.Add(ASrcFileName);
fFilesEvent.SetEvent;
finally
fCS.Release;
end;
end;
end;
procedure TFileCopyThread.Execute;
var
Handles: array[0..1] of THandle;
Res: Cardinal;
SrcFileName, DestFileName: string;
begin
Handles[0] := fFilesEvent.Handle;
Handles[1] := fShutdownEvent.Handle;
while not Terminated do begin
Res := WaitForMultipleObjects(2, #Handles[0], False, INFINITE);
if Res = WAIT_OBJECT_0 + 1 then
break;
if Res = WAIT_OBJECT_0 then begin
while not Terminated do begin
fCS.Acquire;
try
if fSrcFiles.Count > 0 then begin
SrcFileName := fSrcFiles[0];
fSrcFiles.Delete(0);
end else
SrcFileName := '';
if SrcFileName = '' then
fFilesEvent.ResetEvent;
finally
fCS.Release;
end;
if SrcFileName = '' then
break;
DestFileName := fDestDir + ExtractFileName(SrcFileName);
CopyFile(PChar(SrcFileName), PChar(DestFileName), True);
end;
end;
end;
end;
function TFileCopyThread.IsCopyingFiles: boolean;
begin
fCS.Acquire;
try
Result := (fSrcFiles.Count > 0)
// last file is still being copied
or (WaitForSingleObject(fFilesEvent.Handle, 0) = WAIT_OBJECT_0);
finally
fCS.Release;
end;
end;
To use this in production code you would need to add error handling, maybe some progress notifications, and the copying itself should probably be implemented differently, but this should get you started.
In answer to your questions:
should I create the FileCopyThread in the FormCreate of the main program (and let it running), will that slow down the program somehow ?
You can create the thread, it will block on the events and consume 0 CPU cycles until you add a file to be copied. Once all files have been copied the thread will block again, so keeping it over the whole runtime of the program has no negative effect apart from consuming some memory.
Can I add normal event notification to the FileCopyThread (so that I can send an event as in property onProgress:TProgressEvent read fOnProgressEvent write fOnProgressEvent; with f.i. the current number of files in the list, and the file currently processed. I would like to call this when adding and before and after the copy routine
You can add notifications, but for them to be really useful they need to be executed in the context of the main thread. The easiest and ugliest way to do that is to wrap them with the Synchronize() method. Look at the Delphi Threads demo for an example how to do this. Then read some of the questions and answers found by searching for "[delphi] synchronize" here on SO, to see how this technique has quite a few drawbacks.
However, I wouldn't implement notifications in this way. If you just want to display progress it's unnecessary to update this with each file. Also, you have all the necessary information in the VCL thread already, in the place where you add the files to be copied. You could simply start a timer with an Interval of say 100, and have the timer event handler check whether the thread is still busy, and how many files are left to be copied. When the thread is blocked again you can disable the timer. If you need more or different information from the thread, then you could easily add more thread-safe methods to the thread class (for example return the number of pending files). I started with a minimal interface to keep things small and easy, use it as inspiration only.
Comment on your updated question:
You have this code:
function TFileCopyThread.GetFileBeingCopied: string;
begin
Result := '';
if fFileBeingCopied <> '' then begin
fCS.Acquire;
try
Result := fFileBeingCopied;
fFilesEvent.SetEvent;
finally
fCS.Release;
end;
end;
end;
but there are two problems with it. First, all access to data fields needs to be protected to be safe, and then you are just reading data, not adding a new file, so there's no need to set the event. The revised method would simply be:
function TFileCopyThread.GetFileBeingCopied: string;
begin
fCS.Acquire;
try
Result := fFileBeingCopied;
finally
fCS.Release;
end;
end;
Also you only set the fFileBeingCopied field, but never reset it, so it will always equal the last copied file, even when the thread is blocked. You should set that string empty when the last file has been copied, and of course do that while the critical section is acquired. Simply move the assignment past the if block.
If you're somewhat reluctant to go down to the metal and deal with TThread directly like in mghie solution, an alternative, maybe quicker, is to use Andreas Hausladen's AsyncCalls.
skeleton code:
procedure MoveFile(AFileName: TFileName; const DestFolder: string);
//------------------------------------------------------------------------------
begin
if DestFolder > '' then
if CopyFile(PChar(AFileName), PChar(IncludeTrailingPathDelimiter(DestFolder) + ExtractFileName(AFileName)), False) then
SysUtils.DeleteFile(AFileName)
else
RaiseLastOSError;
end;
procedure DoExport;
//------------------------------------------------------------------------------
var
TempPath, TempFileName: TFileName;
I: Integer;
AsyncCallsList: array of IAsyncCall;
begin
// find Windows temp directory
SetLength(TempPath, MAX_PATH);
SetLength(TempPath, GetTempPath(MAX_PATH, PChar(TempPath)));
// we suppose you have an array of items (1 per file to be created) with some info
SetLength(AsyncCallsList, Length(AnItemListArray));
for I := Low(AnItemListArray) to High(AnItemListArray) do
begin
AnItem := AnItemListArray[I];
LogMessage('.Processing current file for '+ AnItem.NAME);
TempFileName := TempPath + Format(AFormatString, [AnItem.NAME, ...]);
CreateYourFile(TempFileName);
LogMessage('.File generated for '+ AnItem.NAME);
// Move the file to Dest asynchronously, without waiting
AsyncCallsList[I] := AsyncCall(#MoveFile, [TempFileName, AnItem.DestFolder])
end;
// final rendez-vous synchronization
AsyncMultiSync(AsyncCallsList);
LogMessage('Job finished... ');
end;
A good start for using thread is Delphi is found at the Delphi about site
In order to make your solution work, you need a job queue for the worker thread. A stringlist can be used. But in any case you need to guard the queue so that only one thread can write to it at any single moment. Even if the writing thread is suspended.
Your application writes to the queue. So there must be a guarded write method.
Your thread reads and removes from the queue. So there must be a guarded read/remove method.
You can use a critical section to make sure only one of these has access to the queue at any single moment.

copy file in a thread

I am trying to write to copy a file by invoking a separate thread.
Here is my form code:
unit frmFileCopy;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ComCtrls, StdCtrls;
type
TForm2 = class(TForm)
Button3: TButton;
procedure Button3Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
private
ThreadNumberCounter : integer;
procedure HandleTerminate (Sender: Tobject);
end;
var
Form2: TForm2;
implementation
uses
fileThread;
{$R *.dfm}
{ TForm2 }
const
sourcePath = 'source\'; //'
destPath = 'dest\'; //'
fileSource = 'bigFile.zip';
fileDest = 'Copy_bigFile.zip';
procedure TForm2.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
CanClose := true;
if ThreadNumberCounter >0 then
begin
if MessageDlg('The file is being copied. Do you want to quit?', mtWarning,
[mbYes, mbNo],0) = mrNo then
CanClose := false;
end;
end;
procedure TForm2.FormCreate(Sender: TObject);
begin
ThreadNumberCounter := 0;
end;
procedure TForm2.Button3Click(Sender: TObject);
var
sourceF, destF : string;
copyFileThread : TCopyThread;
begin
sourceF := ExtractFilePath(ParamStr(0)) + sourcePath + fileSource;
destF := ExtractFilePath(ParamStr(0)) + sourcePath + fileDest;
copyFileThread := TCopyThread.create(sourceF,destF);
copyFileThread.FreeOnTerminate := True;
try
Inc(ThreadNumberCounter);
copyFileThread.Execute;
copyFileThread.OnTerminate := HandleTerminate;
copyFileThread.Resume;
except
on Exception do
begin
copyFileThread.Free;
ShowMessage('Error in thread');
end;
end;
end;
procedure TForm2.HandleTerminate(Sender: Tobject);
begin
Dec(ThreadNumberCounter);
end;
Here is my class:
unit fileThread;
interface
uses
Classes, SysUtils;
type
TCopyThread = class(TThread)
private
FIn, FOut : string;
procedure copyfile;
public
procedure Execute ; override;
constructor create (const source, dest : string);
end;
implementation
{ TCopyThread }
procedure TCopyThread.copyfile;
var
streamSource, streamDest : TFileStream;
bIn, bOut : byte;
begin
streamSource := TFileStream.Create(FIn, fmOpenRead);
try
streamDest := TFileStream.Create(FOut,fmCreate);
try
streamDest.CopyFrom(streamSource,streamSource.Size);
streamSource.Position := 0;
streamDest.Position := 0;
{check file consinstency}
while not (streamSource.Position = streamDest.Size) do
begin
streamSource.Read(bIn, 1);
streamDest.Read(bOut, 1);
if bIn <> bOut then
raise Exception.Create('files are different at position' +
IntToStr(streamSource.Position));
end;
finally
streamDest.Free;
end;
finally
streamSource.Free;
end;
end;
constructor TCopyThread.create(const source, dest: string);
begin
FIn := source;
FOut := dest;
end;
procedure TCopyThread.Execute;
begin
copyfile;
inherited;
end;
end.
When I run the application, I received a following error:
Project prjFileCopyThread raised exception class EThread with message: 'Cannot call Start on a running or suspended thread'.
I do not have experience with threads.
I use Martin Harvey's tutorial as a guide, but any advice how to improve it make safe thread would be appreciated.
Based on the answers, I've changed my code. This time it worked. I would appreciate if you can review it again and tell what should be improved.
procedure TForm2.Button3Click(Sender: TObject);
var
sourceF, destF : string;
copyFileThread : TCopyThread;
begin
sourceF := ExtractFilePath(ParamStr(0)) + sourcePath + fileSource;
destF := ExtractFilePath(ParamStr(0)) + destPath + fileDest;
copyFileThread := TCopyThread.create;
try
copyFileThread.InFile := sourceF;
copyFileThread.OutFile := destF;
except
on Exception do
begin
copyFileThread.Free;
ShowMessage('Error in thread');
end;
end;
Here is my class:
type
TCopyThread = class(TThread)
private
FIn, FOut : string;
procedure setFin (const AIN : string);
procedure setFOut (const AOut : string);
procedure FCopyFile;
protected
procedure Execute ; override;
public
constructor Create;
property InFile : string write setFin;
property OutFile : string write setFOut;
end;
implementation
{ TCopyThread }
procedure TCopyThread.FCopyfile;
var
streamSource, streamDest : TFileStream;
bIn, bOut : byte;
begin
{removed the code to make it shorter}
end;
procedure TCopyThread.setFin(const AIN: string);
begin
FIn := AIN;
end;
procedure TCopyThread.setFOut(const AOut: string);
begin
FOut := AOut;
end;
constructor TCopyThread.create;
begin
FreeOnTerminate := True;
inherited Create(FALSE);
end;
procedure TCopyThread.Execute;
begin
FCopyfile;
end;
end.
You have a few problems:
You don't call inherited Create. In this case, since you want to do things first and start it yourself, you should use
inherited Create(True); // Creates new thread suspended.
You should never call Execute yourself. It's called automatically if you create non-suspended, or if you call Resume.
There is no inherited Execute, but you call it anyway.
BTW, you could also use the built-in Windows Shell function SHFileOperation to do the copy. It will work in the background, handles multiple files and wildcards, and can automatically display progress to the user. You can probably find an example of using it in Delphi here on SO; here is a link for using it to recursively delete files, for example.
A good search here on SO is (without the quotes) shfileoperation [delphi]
Just for comparison - that's how you'd do it with OmniThreadLibrary.
uses
OtlCommon, OtlTask, OtlTaskControl;
type
TForm3 = class(TForm)
...
FCopyTask: IOmniTaskControl;
end;
procedure BackgroundCopy(const task: IOmniTask);
begin
CopyFile(PChar(string(task.ParamByName['Source'])), PChar(string(task.ParamByName['Dest'])), true);
//Exceptions in CopyFile will be mapped into task's exit status
end;
procedure TForm3.BackgroundCopyComplete(const task: IOmniTaskControl);
begin
if task.ExitCode = EXIT_EXCEPTION then
ShowMessage('Exception in copy task: ' + task.ExitMessage);
FCopyTask := nil;
end;
procedure TForm3.Button3Click(Sender: TObject);
begin
FCopyTask := CreateOmniTask(BackgroundCopy)
.SetParameter('Source', ExtractFilePath(ParamStr(0)) + sourcePath + fileSource)
.SetParameter('Dest', ExtractFilePath(ParamStr(0)) + destPath + fileDest)
.SilentExceptions
.OnTerminate(BackgroundCopyComplete)
.Run;
end;
procedure TForm3.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
CanClose := true;
if assigned(FCopyTask) then
begin
if MessageDlg('The file is being copied. Do you want to quit?', mtWarning,
[mbYes, mbNo],0) = mrNo then
CanClose := false
else
FCopyTask.Terminate;
end;
end;
Your edited code still has at least two big problems:
You have a parameterless constructor, then set the source and destination file names by means of thread class properties. All you have been told about creating suspended threads not being necessary holds true only if you do all setup in the thread constructor - after this has finished thread execution will begin, and access to thread properties need to be synchronized. You should (as indeed your first version of the code did) give both names as parameters to the thread. It's even worse: the only safe way to use a thread with the FreeOnTerminate property set is to not access any property once the constructor has finished, because the thread may have destroyed itself already, or could do while the property is accessed.
In case of an exception you free the thread object, even though you have set its FreeOnTerminate property. This will probably result in a double free exception from the memory manager.
I do also wonder how you want to know when the copying of the file is finished - if there is no exception the button click handler will exit with the thread still running in the background. There is also no means of cancelling the running thread. This will cause your application to exit only when the thread has finished.
All in all you would be better off to use one of the Windows file copying routines with cancel and progress callbacks, as Ken pointed out in his answer.
If you do this only to experiment with threads - don't use file operations for your tests, they are a bad match for several reasons, not only because there are better ways to do the same in the main thread, but also because I/O bandwidth will be used best if no concurrent operations are attempted (that means: don't try to copy several files in parallel by creating several of your threads).
The Execute method of a thread is normally not explicitly called by client code. In other words: delete CopyFileThread.Execute in unit frmFileCopy. The thread is started when the Resume method is invoked.
Also in unit fileThread in the constructor of TCopyThread inherited Create(True) should be called as first to create a thread in suspended state.
You execute the thread and then trying to Resume it while it is running.
copyFileThread.Execute;
copyFileThread.OnTerminate := HandleTerminate;
copyFileThread.Resume;

Resources