From Asbjørn, 7 Years ago, written in Delphi (Object Pascal).
Embed
  1. program CheckpointTest;
  2.  
  3. {$APPTYPE CONSOLE}
  4.  
  5. {$R *.res}
  6.  
  7. uses
  8.   System.SysUtils;
  9.  
  10. type
  11.   ICheckpoint = interface
  12.     ['{4348A5AB-621D-4A18-8368-1388A44481C6}']
  13.   end;
  14.  
  15.   CheckpointLog = class
  16.   strict private
  17.     type
  18.       PCheckpointData = ^TCheckpointData;
  19.       TCheckpointData = record
  20.         Msg: string;
  21.         Prev: PCheckpointData;
  22.       end;
  23.   strict private
  24.     class var CurCheckpoint: PCheckpointData;
  25.   public
  26.     class function AddCheckpoint(const Msg: string): pointer;
  27.     class procedure RemoveCheckpoint(const Handle: pointer);
  28.  
  29.     class procedure PrintLog();
  30.   end;
  31.  
  32.   CheckpointImpl = class(TInterfacedObject, ICheckpoint)
  33.   strict private
  34.     FHandle: pointer;
  35.   public
  36.     constructor Create(const Msg: string);
  37.     destructor Destroy; override;
  38.   end;
  39.  
  40. function Checkpoint(const Msg: string): ICheckpoint;
  41. begin
  42.   result := CheckpointImpl.Create(Msg);
  43. end;
  44.  
  45. { CheckpointLog }
  46.  
  47. class function CheckpointLog.AddCheckpoint(const Msg: string): pointer;
  48. var
  49.   chk: PCheckpointData;
  50. begin
  51.   New(chk);
  52.  
  53.   chk.Msg := Msg;
  54.   chk.Prev := CurCheckpoint;
  55.  
  56.   CurCheckpoint := chk;
  57.  
  58.   result := chk;
  59. end;
  60.  
  61. class procedure CheckpointLog.PrintLog;
  62. var
  63.   chk: PCheckpointData;
  64. begin
  65.   chk := CurCheckpoint;
  66.  
  67.   if (chk = nil) then
  68.     exit;
  69.  
  70.   WriteLn('Checkpoints:');
  71.  
  72.   while (chk <> nil) do
  73.   begin
  74.     WriteLn('  ', chk.Msg);
  75.     chk := chk.Prev;
  76.   end;
  77. end;
  78.  
  79. class procedure CheckpointLog.RemoveCheckpoint(const Handle: pointer);
  80. var
  81.   chk: PCheckpointData;
  82. begin
  83.   if (Handle <> CurCheckpoint) then
  84.     raise EArgumentException.Create('RemoveCheckpoint: Invalid checkpoint handle');
  85.  
  86.   chk := CurCheckpoint;
  87.  
  88.   CurCheckpoint := chk.Prev;
  89.  
  90.   Dispose(chk);
  91. end;
  92.  
  93. { CheckpointImpl }
  94.  
  95. constructor CheckpointImpl.Create(const Msg: string);
  96. begin
  97.   inherited Create;
  98.  
  99.   FHandle := CheckpointLog.AddCheckpoint(Msg);
  100. end;
  101.  
  102. destructor CheckpointImpl.Destroy;
  103. begin
  104.   CheckpointLog.RemoveCheckpoint(FHandle);
  105.  
  106.   inherited;
  107. end;
  108.  
  109.  
  110.  
  111.  
  112. procedure ReadSomeFile;
  113. begin
  114.   raise EProgrammerNotFound.Create('Barf');
  115. end;
  116.  
  117. procedure ReadSome;
  118. begin
  119.   Checkpoint('ReadSome');
  120.   try
  121.     ReadSomeFile;
  122.   except
  123.     on E: Exception do
  124.     begin
  125.       Writeln(E.ClassName, ': ', E.Message);
  126.       CheckpointLog.PrintLog();
  127.     end;
  128.   end;
  129. end;
  130.  
  131. procedure Proc1;
  132. begin
  133.   Checkpoint('Proc1');
  134. end;
  135.  
  136. procedure Proc2;
  137. begin
  138.   Checkpoint('Proc2');
  139.   ReadSome;
  140. end;
  141.  
  142. procedure Test;
  143. begin
  144.   Checkpoint('Start test');
  145.  
  146.   Proc1;
  147.   Proc2;
  148. end;
  149.  
  150. begin
  151.   try
  152.     Test;
  153.   except
  154.     on E: Exception do
  155.     begin
  156.       Writeln(E.ClassName, ': ', E.Message);
  157.       CheckpointLog.PrintLog();
  158.     end;
  159.   end;
  160.   WriteLn('done...');
  161.   ReadLn;
  162. end.
  163.