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.
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.