Nach etwas Gesuche habe ich eine Lösung gefunden, die sowohl unter Windows als auch unter Linux funktioniert.
Um das nachfolgende Beispiel zum Laufen zu bekommen erzeugt man eine neue Anwendung und setzt einen Button und zwei Memos auf das Formular.
Anschließen kopiert man den Quelltext in die Unit1.
Code: Alles auswählen
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls;
type
{ TLockFolderThread }
TLockFolderThread = class(TThread)
private
FThreadNum : Integer;
FLineCount : Integer;
procedure SynchMessage;
protected
procedure Execute;override;
public
constructor Create(const AThreadNum : Integer);
end;
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
Memo2: TMemo;
procedure Button1Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
FLockFolderThreads : array of TLockFolderThread;
public
procedure CreateThreads;
procedure DestroyThreads;
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
const
LockFileSubFolder = 'Test';
LockFileName = 'test.LOCK';
LockTestFileName = 'test.txt';
function UnlockFolder(const ALockFolderName : String; const AHandle : THandle) : Boolean;
var
b : Boolean;
begin
Result := (AHandle <> THandle(-1));
if Result then
begin
b := DeleteFile(IncludeTrailingPathDelimiter(ALockFolderName)+LockFileName);
FileClose(AHandle);
end;
end;
function LockFolder(const ALockFolderName : String; out AHandle : THandle; const MaxWait : Integer = -1) : Boolean;
var
t0, t1 : Int64;
begin
t0 := GetTickCount64;
AHandle := THandle(-1);
Result := False;
if not DirectoryExists(ALockFolderName) then Exit;
repeat
AHandle := FileCreate(IncludeTrailingPathDelimiter(ALockFolderName)+LockFileName,fmShareExclusive,$000);
Result := (AHandle <> THandle(-1));
if Result then Break;
Sleep(0);
if MaxWait >= 0 then
begin
if MaxWait = 0 then
Break;
t1 := GetTickCount64;
if t1-t0 > MaxWait then
Break;
end;
until Result;
end;
{ TLockFolderThread }
procedure TLockFolderThread.SynchMessage;
begin
if FLineCount < 0 then
begin
Form1.Memo1.Lines.Add(Format('%d %8.8x (%d)',[FThreadNum,ThreadID,ThreadID]));
Inc(FLineCount);
end;
while Form1.Memo2.Lines.Count <= FThreadNum do
Form1.Memo2.Lines.Add(IntToStr(Form1.Memo2.Lines.Count));
Form1.Memo2.Lines[FThreadNum] := Format('%d %d',[FThreadNum,FLineCount]);
end;
procedure TLockFolderThread.Execute;
var
lockfn : String;
lock : THandle;
sl : TStringList;
begin
try
lockfn := GetUserDir()+IncludeTrailingPathDelimiter('Documents')+IncludeTrailingPathDelimiter(LockFileSubFolder);
Synchronize(@SynchMessage);
while not Terminated do
begin
if LockFolder(lockfn,lock) then
try
sl := TStringList.Create;
try
try
if FileExists(lockfn+LockTestFileName) then
sl.LoadFromFile(lockfn+LockTestFileName);
while sl.Count > 10000 do
sl.Delete(0);
sl.Add(Format('This is Thread %8.8x (%d)',[ThreadID, ThreadID]));
sl.SaveToFile(lockfn+LockTestFileName);
except
end;
finally
if Assigned(sl) then
sl.Free;
end;
Inc(FLineCount);
Synchronize(@SynchMessage);
finally
UnLockFolder(lockfn,lock);
end;
// Sleep(Random(250));
Sleep(0);
end;
finally
if not Terminated then
Terminate;
end;
end;
constructor TLockFolderThread.Create(const AThreadNum: Integer);
begin
inherited Create(True);
// Priority := tpHighest;
FThreadNum := AThreadNum;
FLineCount := -1;
Suspended := False;
end;
{ TForm1 }
procedure TForm1.Button1Click(Sender: TObject);
begin
if Length(FLockFolderThreads) <= 0 then
begin
Button1.Caption := 'Stop';
Memo1.Clear;
Memo2.Clear;
CreateThreads;
end
else
begin
Button1.Caption := 'Start';
DestroyThreads;
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
DestroyThreads;
end;
procedure TForm1.CreateThreads;
var
i : Integer;
lockfn : String;
begin
DestroyThreads;
lockfn := GetUserDir()+IncludeTrailingPathDelimiter('Documents')+IncludeTrailingPathDelimiter(LockFileSubFolder);
if not DirectoryExists(lockfn) then
ForceDirectories(lockfn);
if not DirectoryExists(lockfn) then Exit;
SetLength(FLockFolderThreads,5);
for i := 0 to High(FLockFolderThreads) do
FLockFolderThreads[i] := TLockFolderThread.Create(i);
end;
procedure TForm1.DestroyThreads;
var
i : Integer;
lockfn : String;
begin
for i := 0 to High(FLockFolderThreads) do
begin
if Assigned(FLockFolderThreads[i]) then
FLockFolderThreads[i].Terminate;
end;
for i := 0 to High(FLockFolderThreads) do
begin
if Assigned(FLockFolderThreads[i]) then
FLockFolderThreads[i].WaitFor;
end;
for i := 0 to High(FLockFolderThreads) do
begin
if Assigned(FLockFolderThreads[i]) then
FreeAndNil(FLockFolderThreads[i]);
end;
SetLength(FLockFolderThreads,0);
lockfn := GetUserDir()+IncludeTrailingPathDelimiter('Documents')+IncludeTrailingPathDelimiter(LockFileSubFolder);
DeleteFile(lockfn+LockFileName);
end;
end.
Der Schlüssel zur Funktion in Linux war
DeleteFile(IncludeTrailingPathDelimiter(ALockFolderName)+LockFileName);
vor
FileClose(AHandle);
in der Funktion
UnlockFolder.
Unter Windows schlägt das Löschen fehl (Datei ist ja geöffnet) unter Linux nicht, vielmehr ist es dort zwingend erforderlich.
In
FileCreate(IncludeTrailingPathDelimiter(ALockFolderName)+LockFileName,fmShareExclusive,$000);
is ein
fmOpenWrite entbehrlich.
Unter Windows wird mit FileCreate auch eine existierende Datei geöffnet.
Unter Linux schlägt das fehl. Deshalb muss diese auch in der Freigabe gelöscht werden. Dies wiederum muss zwingend geschehen solange die Datei geöffnet und somit gegen den Zugriff Dritter geschützt ist.
Hier ergibt sich aber ein wirklich blödes Problem mit mehreren Anwendungen unter Linux: Sollte eine Anwendung sterben, während die Datei geöffnet und existent ist, bleibt das System für immer gesperrt. Ich kümmere mich später darum.
Verein
Links
Suche