我这样写了一个支持多线程写日志的动态库,为什么调用时老是出错,请高手指点 ( 积分: 50 )

  • 主题发起人 主题发起人 CADVector
  • 开始时间 开始时间
C

CADVector

Unregistered / Unconfirmed
GUEST, unregistred user!
unit DebugUt;
interface
uses Classes, SysUtils, Math, SyncObjs;
type
TDebug = class
private
FCircleFileCount: Integer;
FDebugFileName: string;
FDebugFilePath: string;
FCurrentFileId: Integer;
FLock: TCriticalSection;
protected
procedure ChangeFileStream;
public
Constructor Create;
Destructor Destroy;
override;
function InitDebug(ACircleFileCount: Integer;
ADebugFilePath, ADebugFileName: string): Integer;
procedure WriteDebug(ADebugStr: string);
procedure FreeDebug;

end;
implementation
{ TDebug }
procedure TDebug.ChangeFileStream;
var
fileStream: TFileStream;
begin

Inc(FCurrentFileID);
if FCurrentFileId > FCircleFileCount then
FCurrentFileId := 1;
fileStream := TFileStream.Create(FDebugFilePath+FDebugFileName+IntToStr(FCurrentFileId)+'.log', fmCreate);
try
finally
fileStream.Free;
end;
end;

constructor TDebug.Create;
begin
inherited;
FCurrentFileId := 1;
FCircleFileCount := 1;
FLock := TCriticalSection.Create;
end;

destructor TDebug.Destroy;
begin
FLock.Free;
inherited;
end;

procedure TDebug.FreeDebug;
begin

end;

function TDebug.InitDebug(ACircleFileCount: Integer;
ADebugFilePath,
ADebugFileName: string): Integer;
begin
result := -1;
try
FCircleFileCount := Max(ACircleFileCount, FCircleFileCount);
ForceDirectories(ADebugFilePath);
FDebugFilePath := ADebugFilePath;
FDebugFileName := ADebugFileName;
FCurrentFileId := 1;
except
exit;
end;
result := 0;
end;

procedure TDebug.WriteDebug(ADebugStr: string);
var
DebugStr: string;
filehandle: integer;
fileStream: TFileStream;
begin
try
FLock.Enter;
//检查当前文件是否存在
if not FileExists(FDebugFilePath+FDebugFileName+IntToStr(FCurrentFileId)+'.log') then
begin
fileHandle := FileCreate(FDebugFilePath+FDebugFileName+IntToStr(FCurrentFileId)+'.log');
FileClose( fileHandle);
end;
fileStream := TFileStream.Create(FDebugFilePath+FDebugFileName+IntToStr(FCurrentFileId)+'.log', fmOpenWrite);
try
fileStream.Seek(0, soFromend);
DebugStr := DateTimeToStr(now) + '-->' + ADebugStr+ #13#10;
fileStream.Write(DebugStr[1], Length(DebugStr)) ;
//检查文件是否过大
if fileStream.Size > 100*1024 then
begin
ChangeFileStream;
end;

finally
fileStream.Free;
end;
finally
FLock.Leave;
end;
end;

end.

导出单元
unit ExportUt;
interface
uses DebugUt;
function InitDebug(ACircleFileCount: Integer;
ADebugFilePath, ADebugFileName: pChar): Integer;stdcall;
procedure WriteDebug(ADebugStr: string);stdcall;
procedure FreeDebug;stdcall;
exports
InitDebug,
WriteDebug,
FreeDebug;
var
MyDebug : TDebug;
implementation
function InitDebug(ACircleFileCount: Integer;
ADebugFilePath, ADebugFileName: pChar): Integer;
begin
MyDebug := TDebug.Create;
result := MyDebug.InitDebug(ACircleFileCount, ADebugFilePath, ADebugFileName);
end;

procedure WriteDebug(ADebugStr: string);
begin
MyDebug.WriteDebug(ADebugStr);
end;

procedure FreeDebug;
begin
MyDebug.FreeDebug;
MyDebug.Free;
end;
end.

测试程序如下
unit TestUt;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, DebugThread;
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
FArrayThread: Array of Cardinal;
public
{ Public declarations }
end;
function InitDebug(ACircleFileCount: Integer;
ADebugFilePath, ADebugFileName: pChar): Integer;
stdcall;external 'WriteDebug.dll' name 'InitDebug';
procedure WriteDebug(ADebugStr: string);
stdcall;
external 'WriteDebug.dll' name 'WriteDebug';
procedure FreeDebug;
stdcall;external 'WriteDebug.dll' name 'FreeDebug';
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var
i: Integer;
begin
InitDebug(20, pChar(ExtractFilePath(Application.ExeName)), 'MyDebug');
SetLength(FArrayThread, 100);
for i:=0 to 99do
begin
FArrayThread := Cardinal(TWriteDebugThread.Create(False));
end;

end;

procedure TForm1.Button2Click(Sender: TObject);
var
i: integer;
begin
for i:=0 to 99do
begin
TWriteDebugThread(FArrayThread).Terminate;
WaitForSingleObject(FArrayThread, 1000);
TWriteDebugThread(FArrayThread).Free;
end;
FreeDebug;
end;

end.
线程单元
unit DebugThread;
interface
uses
Classes, SysUtils;
type
TWriteDebugThread = class(TThread)
private
{ Private declarations }
protected
procedure Execute;
override;
end;

implementation
uses TestUt;
{ Important: Methods and properties of objects in visual components can only be
used in a method called using Synchronize, for example,
Synchronize(UpdateCaption);
and UpdateCaption could look like,
procedure TWriteDebugThread.UpdateCaption;
begin
Form1.Caption := 'Updated in a thread';
end;
}
{ TWriteDebugThread }
procedure TWriteDebugThread.Execute;
begin
{ Place thread code here }
while not Terminateddo
begin
WriteDebug('Thread='+IntToStr(Self.ThreadId)+' 测试我的Debug程序');
sleep(100);
end;
end;

end.
 
单步跟踪一下哪里出错,发一大陀代码过来什么都不描述,算个鸟问题啊~~
 
就是在运行一段时间后,出现无法打开文件的错误。有时候是出现在调用动态库函数时出错
 
第一个错误点:fileStream := TFileStream.Create(FDebugFilePath+FDebugFileName+IntToStr(FCurrentFileId)+'.log', fmOpenWrite);
第二个错误点:WriteDebug('Thread='+IntToStr(Self.ThreadId)+' 测试我的Debug程序');
运行几分钟后经常在这两个语句上发生错误?
 
我将导出函数改成如下就OK了,不知道为什么
procedure WriteDebug(ADebugStr: string);
begin
try
Lock.enter;
MyDebug.WriteDebug(ADebugStr);
finally
lock.leave;
end;
end;
 
你把TDebug放在Thread里面的Private里Create
每一条线程就需要一个TDebug
否则你两个线程因为不同步同时调用了MyDebug就会出错了。。。
总结:线程不同步!
 

Similar threads

后退
顶部