unit uScopeGuard;
interface
uses
  SysUtils, Classes, Contnrs;
type
  TShenMethod = record
    Code, Sender, Data: Pointer;
    T: Integer;
  end;
  TShenMethodDynArray = array of TShenMethod;
  TObjProcedure = procedure (Sender: TObject);
  TObjectGuard = class;
  IScopeGuard = interface
  ['{7561A2E9-F368-429F-9982-BCFFACC32573}']
    function CreateObject(AObject: TObject): TObject;
    function CreateSubScopeGuard: IScopeGuard;
    procedure Add(AObject: TObjectGuard);
    procedure Clear;
    procedure DismissAll;
    procedure Remove(AObject: TObjectGuard);
  end;
  TScopeGuard = class(TInterfacedObject, IScopeGuard)
  private
    FStack: TStack;
  protected
    procedure Clear; virtual;
  public
    constructor Create;
    destructor Destroy; override;
    function CreateObject(AObject: TObject): TObject;
    function CreateSubScopeGuard: IScopeGuard;
    procedure Add(AObject: TObjectGuard);
    procedure DismissAll;
    procedure Remove(AObject: TObjectGuard);
  end;
  TObjectGuard = class
  private
    FDismiss: Boolean;
  protected
    FMethods: TShenMethodDynArray;
    constructor InternalCreate;
    procedure AddMethods(M: TShenMethodDynArray); virtual;
  public
    constructor Create;
    destructor Destroy; override;
    procedure CleanUp; virtual;
    procedure Dismiss;
  end;
  TObjectGuardFactory = class
  public
    class function Make(M: TShenMethod): TObjectGuard; overload;
    class function Make(M: array of TShenMethod): TObjectGuard; overload;
  end;
  ISG = IScopeGuard;
  TSG = TScopeGuard;
  TOG = TObjectGuard;
  TOGF = TObjectGuardFactory;
function MakeMethod(const Code: PLongint; const Sender: Pointer = nil; const Data: Pointer = nil): TShenMethod; overload;
function MakeMethod(const Code: TProcedure): TShenMethod; overload;
function MakeMethod(const Code: TObjProcedure; const Sender: TObject): TShenMethod; overload;
function MakeMethod(const Code: TNotifyEvent; const Sender, Data: TObject): TShenMethod; overload;
function MakeMethod(const Code: TThreadMethod; const Sender: TObject): TShenMethod; overload;
function MakeFreeAndNil(var P): TShenMethod;
function MakeAssignOrd(var Dest; const Src: Integer): TShenMethod;
function MakeAssignStr(var Dest: string; const Src: string): TShenMethod;
procedure CallMethod(const M: TShenMethod); overload;
implementation
const
  SMNormal = 0;
  SMFreeAndNil = 1;
  SMAssignOrd = 2;
  SMAssignStr = 3;
function MakeMethod(const Code: PLongint; const Sender, Data: Pointer): TShenMethod;
begin
  Result.Code := Code;
  Result.Sender := Sender;
  Result.Data := Data;
  Result.T := SMNormal;
end;
function MakeMethod(const Code: TProcedure): TShenMethod;
begin
  Result := MakeMethod(PLongint(@Code));
end;
function MakeMethod(const Code: TObjProcedure; const Sender: TObject): TShenMethod;
begin
  Result := MakeMethod(PLongint(@Code), Sender);
end;
function MakeMethod(const Code: TNotifyEvent; const Sender, Data: TObject): TShenMethod;
begin
  Result := MakeMethod(PLongint(@Code), Sender, Data);
end;
function MakeMethod(const Code: TThreadMethod; const Sender: TObject): TShenMethod;
begin
  Result := MakeMethod(PLongint(@Code), Sender);
end;
function MakeFreeAndNil(var P): TShenMethod;
begin
  Result.Code := nil;
  Result.Sender := nil;
  Result.Data := @P;
  Result.T := SMFreeAndNil;
end;
function MakeAssignOrd(var Dest; const Src: Integer): TShenMethod;
begin
  Result.Code := nil;
  Result.Sender := Pointer(Src);
  Result.Data := @Dest;
  Result.T := SMAssignOrd;
end;
function MakeAssignStr(var Dest: string; const Src: string): TShenMethod;
begin
  Result.Code := nil;
  Result.Sender := PChar(Src);
  Result.Data := PChar(@Dest);
  Result.T := SMAssignStr;
end;
procedure CallMethodNormal(const M: TShenMethod);
asm
  CMP  M.Code, 0;
  JZ   @@end;
  MOV  ECX, EAX;
  MOV  EAX, [ECX].TShenMethod.Sender;
  MOV  EDX, [ECX].TShenMethod.Data;
  Call [ECX].TShenMethod.Code;
@@end:
end;
procedure CallMethodFreeAndNil(const M: TShenMethod);
begin
  FreeAndNil((M.Data)^);
end;
procedure CallMethodAssignOrd(const M: TShenMethod);
begin
  PLongint(M.Data)^ := Longint(M.Sender);
end;
procedure CallMethodAssignStr(const M: TShenMethod);
var
  s: string;
begin
  s := StrPas(M.Sender);
  PChar((M.Data)^) := PChar(s);
end;
procedure CallMethod(const M: TShenMethod);
begin
  case M.T of
    SMNormal: CallMethodNormal(M);
    SMFreeAndNil: CallMethodFreeAndNil(M);
    SMAssignOrd: CallMethodAssignOrd(M);
    SMAssignStr: CallMethodAssignStr(M);
  end;
end;
{ TScopeGuard }
type TStackAccess = class(TStack);
procedure TScopeGuard.Add(AObject: TObjectGuard);
begin
  FStack.Push(AObject);
end;
procedure TScopeGuard.Clear;
var
  AObject: TObject;
begin
  while FStack.Count > 0 do
  begin
    AObject := FStack.Pop;
    if Assigned(AObject) then
    begin
      AObject.Free;
    end;
  end;
end;
constructor TScopeGuard.Create;
begin
  inherited Create;
  FStack := TStack.Create;
end;
function TScopeGuard.CreateObject(AObject: TObject): TObject;
begin
  Result := AObject;
  Add(TObjectGuardFactory.Make(MakeMethod(Result.Free, Result)));
end;
function TScopeGuard.CreateSubScopeGuard: IScopeGuard;
begin
  Result := TScopeGuard.Create;
end;
destructor TScopeGuard.Destroy;
begin
  Clear;
  FStack.Free;
  inherited;
end;
procedure TScopeGuard.DismissAll;
var
  i: Integer;
  AObject: TObjectGuard;
begin
  with TStackAccess(FStack).List do
  begin
    for i := Count - 1 downto 0 do
    begin
      AObject := Items[i];
      AObject.Dismiss;
    end;
  end;
end;
procedure TScopeGuard.Remove(AObject: TObjectGuard);
begin
  TStackAccess(FStack).List.Remove(AObject); // Do not free AObject
end;
{ TObjectGuard }
procedure TObjectGuard.AddMethods(M: TShenMethodDynArray);
var
  i, OldLen, MLen: Integer;
begin
  MLen := Length(M);
  if MLen > 0 then
  begin
    OldLen := Length(FMethods);
    SetLength(FMethods, OldLen + MLen);
    for i := 0 to MLen - 1 do
    begin
      FMethods[OldLen + i] := M[i];
    end;
  end;
end;
procedure TObjectGuard.CleanUp;
var
  i: Integer;
begin
  for i := 0 to Length(FMethods) - 1 do
  begin
    CallMethod(FMethods[i]);
  end;
end;
constructor TObjectGuard.Create;
begin
  raise Exception.Create('Please use TObjectGuardFactory.make instead of TObjectGuard.Create');
end;
destructor TObjectGuard.Destroy;
begin
  if not FDismiss then CleanUp;
  inherited;
end;
procedure TObjectGuard.Dismiss;
begin
  FDismiss := True;
end;
constructor TObjectGuard.InternalCreate;
begin
  inherited Create;
end;
{ TObjectGuardFactory }
class function TObjectGuardFactory.Make(M: TShenMethod): TObjectGuard;
var
  _M: TShenMethodDynArray;
begin
  Result := TObjectGuard.InternalCreate;
  SetLength(_M, 1);
  _M[0] := M;
  Result.AddMethods(_M);
end;
class function TObjectGuardFactory.Make(M: array of TShenMethod): TObjectGuard;
var
  _M: TShenMethodDynArray;
  I, Count: Integer;
begin
  Result := nil;
  Count := Length(M);
  if Count <= 0 then Exit;
  Result := TObjectGuard.InternalCreate;
  SetLength(_M, Count);
  for I := 0 to Count - 1 do _M[I] := M[I];
  Result.AddMethods(_M);
end;
end.

type
  TMO = class(TObject)
    procedure DoIt;
    procedure Undo;
  end;
  TDO = class(TObject)
    procedure DoIt;
    procedure Undo;
  end;
procedure TMO.DoIt;
begin
  ShowMessage('Do memory operation');
end;
procedure TMO.Undo;
begin
  ShowMessage('Undo memory operation');
end;
procedure TDO.DoIt;
begin
  raise Exception.Create('Exception while processing database operation');
  ShowMessage('Do database operation');
end;
procedure TDO.Undo;
begin
  ShowMessage('Undo database operation');
end;
procedure TForm3.NotUseGuardClick(Sender: TObject);
var
  _MO, _MO2: TMO;
  _DO: TDO;
begin
  _MO := TMO.Create;
  try
    _MO.DoIt;
    _MO2 := TMO.Create;
    try
      _MO2.DoIt;
      _DO := TDO.Create;
      try
        try
          _DO.DoIt;
        except
          on E: Exception do
          begin
            _MO2.Undo;
            _MO.Undo;
            raise ;
          end;
        end;
      finally
        _DO.Free;
      end;
    finally
      _MO2.Free;
    end;
  finally
    _MO.Free;
  end;
end;
procedure TForm3.UseGuardClickClick(Sender: TObject);
var
  SG, SGUndo: ISG;
  _MO, _MO2: TMO;
  _DO: TDO;
begin
  SG := TScopeGuard.Create;
  SGUndo := TScopeGuard.Create;
  _MO := TMO(SG.CreateObject(TMO.Create));
  _MO.DoIt;
  SGUndo.Add(TOGF.Make(MakeMethod(_MO.Undo, _MO)));
  _MO2 := TMO(SG.CreateObject(TMO.Create));
  _MO2.DoIt;
  SGUndo.Add(TOGF.Make(MakeMethod(_MO2.Undo, _MO2)));
  _DO := TDO.Create;
  SG.Add(TOGF.Make(MakeMethod(_DO.Free, _DO)));
  _DO.DoIt;
  SGUndo.DismissAll; // or SGUndo.Clear;
end;

procedure TForm3.Button12Click(Sender: TObject);
var
  SG: ISG;
  ss: TStringList;
begin
  SG := TSG.Create;
  ss := TStringList.Create;
  SG.Add(TOGF.Make(MakeMethod(ss.Free, ss)));
  with SG.CreateSubScopeGuard do
  begin
    ss := TStringList.Create;
    Add(TOGF.Make(MakeFreeAndNil(ss)));
  end;
end;

procedure TForm3.Button8Click(Sender: TObject);
var
  SG: ISG;
  OG: TOG;
  TestException: TTestException;
  i: Integer;
begin
  SG := TSG.Create;
  for i := 0 to 9999 do
    try
      TestException := TTestException.Create;
      OG := TOGF.Make(MakeMethod(TestException.Close, TestException));
      SG.Add(OG);
      if i mod 2 = 0 then
        TestException.RaiseException;
      TestException.Close;
      OG.Dismiss;
    except
    end;
end;

procedure TForm3.Button14Click(Sender: TObject);
var
  SG: ISG;
  ss, ss1: TStringList;
begin
  SG := TSG.Create;
  ss := TStringList.Create;
  SG.Add(TOGF.Make(MakeFreeAndNil(ss)));
  with SG.CreateSubScopeGuard do
  begin
    ss1 := TStringList.Create;
    Add(TOGF.Make(MakeFreeAndNil(ss1)));
    ss1.Free;
    DismissAll;
  end;
  ss.Free;
  SG.DismissAll;
end;