program CheckpointTest;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils;
type
ICheckpoint = interface
['{4348A5AB-621D-4A18-8368-1388A44481C6}']
end;
CheckpointLog = class
strict private
type
PCheckpointData = ^TCheckpointData;
TCheckpointData = record
Msg: string;
Prev: PCheckpointData;
end;
strict private
class var CurCheckpoint: PCheckpointData;
public
class function AddCheckpoint(const Msg: string): pointer;
class procedure RemoveCheckpoint(const Handle: pointer);
class procedure PrintLog();
end;
CheckpointImpl = class(TInterfacedObject, ICheckpoint)
strict private
FHandle: pointer;
public
constructor Create(const Msg: string);
destructor Destroy; override;
end;
function Checkpoint(const Msg: string): ICheckpoint;
begin
result := CheckpointImpl.Create(Msg);
end;
{ CheckpointLog }
class function CheckpointLog.AddCheckpoint(const Msg: string): pointer;
var
chk: PCheckpointData;
begin
New(chk);
chk.Msg := Msg;
chk.Prev := CurCheckpoint;
CurCheckpoint := chk;
result := chk;
end;
class procedure CheckpointLog.PrintLog;
var
chk: PCheckpointData;
begin
chk := CurCheckpoint;
if (chk = nil) then
exit;
WriteLn('Checkpoints:');
while (chk <> nil) do
begin
WriteLn(' ', chk.Msg);
chk := chk.Prev;
end;
end;
class procedure CheckpointLog.RemoveCheckpoint(const Handle: pointer);
var
chk: PCheckpointData;
begin
if (Handle <> CurCheckpoint) then
raise EArgumentException.Create('RemoveCheckpoint: Invalid checkpoint handle');
chk := CurCheckpoint;
CurCheckpoint := chk.Prev;
Dispose(chk);
end;
{ CheckpointImpl }
constructor CheckpointImpl.Create(const Msg: string);
begin
inherited Create;
FHandle := CheckpointLog.AddCheckpoint(Msg);
end;
destructor CheckpointImpl.Destroy;
begin
CheckpointLog.RemoveCheckpoint(FHandle);
inherited;
end;
procedure ReadSomeFile;
begin
raise EProgrammerNotFound.Create('Barf');
end;
procedure ReadSome;
begin
Checkpoint('ReadSome');
try
ReadSomeFile;
except
on E: Exception do
begin
Writeln(E.ClassName, ': ', E.Message);
CheckpointLog.PrintLog();
end;
end;
end;
procedure Proc1;
begin
Checkpoint('Proc1');
end;
procedure Proc2;
begin
Checkpoint('Proc2');
ReadSome;
end;
procedure Test;
begin
Checkpoint('Start test');
Proc1;
Proc2;
end;
begin
try
Test;
except
on E: Exception do
begin
Writeln(E.ClassName, ': ', E.Message);
CheckpointLog.PrintLog();
end;
end;
WriteLn('done...');
ReadLn;
end.