===================类的代码========================== {*******************************************************}
_ { } _
_ { CodeMachine } _
_ { } _
_ { 版权所有 (C) 2004 nil } _
_ { } _
_ { 2004-6-10 } _
_ { } _
_ {*******************************************************} _
_ { _
_ 通常将TTracer的实例存放于application级的Session中,在使用时, _
_ 创建一个ITraceInfo,调用TTracer.Write(ITraceInfo)即可, _
_ } _
unit com . sunset . app . tracer ;
interface
uses StrUtils , classes , SysUtils ;
type
_ //============================================================================== _
_ // 接口声明 _
_ //============================================================================== _
_ //跟踪信息的接口 _
ITraceInfo = interface
function ToString : string ;
end ;
_ //输出目标的接口 _
IOutput = interface
procedure Write ( const aInfo : ITraceInfo ); _ //写入跟踪信息 _
end ;
_ //============================================================================== _
_ // 跟踪信息类 ,实现 ITraceInfo _
_ //============================================================================== _
_ //string形式的跟踪记录 _
TStringTI = class ( TInterfacedObject , ITraceInfo )
private
FData : string ;
public
constructor Create ( data : string );
function ToString : string ;
end ;
_ //============================================================================== _
_ // 跟踪信息输出类,实现 IOutput _
_ //============================================================================== _
TFileLog = class ( TInterfacedObject , IOutput )
private
FLogFile : string ;
public
constructor Create ( const FileName : string );
procedure Write ( const aInfo : ITraceInfo ); _ //写入跟踪信息 _
end ;
TProcStr = procedure ( const value : string ) of Object ;
TDatabaseLog = class ( TInterfacedObject , IOutput )
private
FWriteProc : TProcStr ;
public
constructor Create ( WriteProc : TProcStr );
procedure Write ( const aInfo : ITraceInfo ); _ //写入跟踪信息 _
end ;
_ //============================================================================== _
_ // 跟踪工具 _
_ //============================================================================== _
_ { TTracer } _
_ //用来进行记录跟踪日志的类 _
TTracer = class ( TObject )
private
FOutput : IOutput ; _ //输出目标 _
procedure SetOutput ( const Value : IOutput );
public
constructor Create ; overload ;
constructor Create ( aOutput : IOutput ); overload ;
destructor Destroy ; override ;
property Output : IOutput read FOutput write SetOutput ;
procedure Write ( const aInfo : ITraceInfo ); _ //写入跟踪信息 _
end ;
implementation
_ { TTracer } _
constructor TTracer . Create ;
begin
end ;
constructor TTracer . Create ( aOutput : IOutput );
begin
FOutput := aOutput ;
end ;
destructor TTracer . Destroy ;
begin
if FOutput <> nil then FOutput := nil ;
inherited ;
end ;
procedure TTracer . SetOutput ( const Value : IOutput );
begin
FOutput := Value ;
end ;
procedure TTracer . Write ( const aInfo : ITraceInfo );
begin
if FOutput = nil then raise Exception . CreateFmt ( '没有创建输出目标%s!!!' , []);
FOutput . Write ( aInfo );
end ;
_ { TStringTI } _
constructor TStringTI . Create ( data : string );
begin
FData := Data ;
end ;
function TStringTI . ToString : string ;
begin
Result := FData ;
end ;
_ { TStringLog } _
constructor TFileLog . Create ( const FileName : string );
begin
FLogFile := FileName ;
end ;
procedure TFileLog . Write ( const aInfo : ITraceInfo );
begin
if not FileExists ( FLogFile ) then FileClose ( FileCreate ( FLogFile ));
with TStringList . Create do
begin
try
LoadFromFile ( FLogFile );
Add ( aInfo . ToString );
SaveToFile ( FLogFile );
finally
Free ;
end ;
end ;
end ;
_ { TDatabaseLog } _
constructor TDatabaseLog . Create ( WriteProc : TProcStr );
begin
FWriteProc := WriteProc ;
if not Assigned ( FWriteProc ) then raise Exception . CreateFmt ( '没有传入正确的写入跟踪方法%s!!!' , []);
end ;
procedure TDatabaseLog . Write ( const aInfo : ITraceInfo );
begin
FWriteProc ( aInfo . ToString );
end ;
end .
===================测试代码==========================
_ {} _
_ { } _
_ { 测试名称： } _
_ { 作 者： } _
_ { 版 本： } _
_ { 说 明： } _
_ { 备 注： } _
_ { } _
_ {} _
unit test . com . sunset . app . tracer ;
interface
uses
Windows , SysUtils , Classes , TestFramework , TestExtensions ,
com . sunset . app . tracer ;
type
TTest = class ( TTestCase )
protected
procedure SetUp ; override ;
procedure TearDown ; override ;
published
procedure TestTracer ;
end ;
implementation
procedure TTest . Setup ;
begin
end ;
procedure TTest . TearDown ;
begin
end ;
procedure TTest . TestTracer ;
var
tracer : TTracer ;
aInfo : ITraceInfo ;
const
testData = 'adfadfdasf' ;
testFile = 'd:\2.txt' ;
begin
aInfo := TStringTI . Create ( testData );
Tracer := TTracer . Create ( TFileLog . Create ( testfile ));
Tracer . Write ( aInfo );
Tracer . Free ;
aInfo := nil ;
with TStringList . Create do
begin
LoadFromFile ( testfile );
Check ( Strings [ Count - 1 ] = testData );
Free ;
end ;
end ;
initialization
TestFramework . RegisterTest ( TTest . Suite );
end .
一竿残照@金棣.net