Набор данных для отладки

unit DebugSet;

interface

uses
  DbTables, Classes, Controls, Db, SysUtils;

type
  TDebugNotify = procedure(const DegubStr: string) of object;

  TDebugDataSet = class(TTable)
  private
    FDebugNotify: TDebugNotify;
  protected
    // TDataSet virtual abstract methods
    function AllocRecordBuffer: PChar; override;
    procedure FreeRecordBuffer(var Buffer: PChar); override;
    procedure GetBookmarkData(Buffer: PChar;
      Data: Pointer); override;
    function GetBookmarkFlag(Buffer: PChar):
      TBookmarkFlag; override;
    function GetFieldData(Field: TField;
      Buffer: Pointer): Boolean; override;
    function GetRecord(Buffer: PChar; GetMode: TGetMode;
      DoCheck: Boolean): TGetResult; override;
    function GetRecordSize: Word; override;
    procedure InternalAddRecord(Buffer: Pointer;
      Append: Boolean); override;
    procedure InternalClose; override;
    procedure InternalDelete; override;
    procedure InternalFirst; override;
    procedure InternalGotoBookmark(
      Bookmark: Pointer); override;
    procedure InternalHandleException; override;
    procedure InternalInitFieldDefs; override;
    procedure InternalInitRecord(Buffer: PChar); override;
    procedure InternalLast; override;
    procedure InternalOpen; override;
    procedure InternalPost; override;
    procedure InternalSetToRecord(Buffer: PChar); override;
    function IsCursorOpen: Boolean; override;
    procedure SetBookmarkFlag(Buffer: PChar;
      Value: TBookmarkFlag); override;
    procedure SetBookmarkData(Buffer: PChar;
      Data: Pointer); override;
    procedure SetFieldData(Field: TField;
      Buffer: Pointer); override;
    // TDataSet virtual methods (optional)
    procedure InternalRefresh; override;
    function GetRecordCount: Integer; override;
    procedure SetRecNo(Value: Integer); override;
    function GetRecNo: Integer; override;
  public
    property OnDebugNotify: TDebugNotify
      read FDebugNotify write FDebugNotify;
  end;

implementation

procedure TDebugDataSet.InternalOpen;
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('InternalOpen');
  inherited;
end;

procedure TDebugDataSet.InternalInitFieldDefs;
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('InternalInitFieldDefs');
  inherited;
end;

procedure TDebugDataSet.InternalClose;
begin
  FDebugNotify('InternalClose');
  inherited;
end;

function TDebugDataSet.IsCursorOpen: Boolean;
begin
  Result := inherited IsCursorOpen;
  if Result then
    if Assigned(FDebugNotify) then
      FDebugNotify('IsCursorOpen: True')
    else if Assigned(FDebugNotify) then
      FDebugNotify('IsCursorOpen: False');
end;

procedure TDebugDataSet.InternalGotoBookmark(Bookmark: Pointer);
begin
  FDebugNotify('InternalGotoBookmark' +
    IntToStr(Integer(Bookmark)));
  inherited;
end;

procedure TDebugDataSet.InternalSetToRecord(Buffer: PChar);
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('InternalSetToRecord');
  inherited;
end;

function TDebugDataSet.GetBookmarkFlag(
  Buffer: PChar): TBookmarkFlag;
begin
  FDebugNotify('GetBookmarkFlag');
  Result := inherited GetBookmarkFlag(Buffer);
end;

procedure TDebugDataSet.SetBookmarkFlag(Buffer: PChar;
  Value: TBookmarkFlag);
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('SetBookmarkFlag');
  inherited;
end;

procedure TDebugDataSet.GetBookmarkData(
  Buffer: PChar; Data: Pointer);
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('GetBookmarkData');
  inherited;
end;

procedure TDebugDataSet.SetBookmarkData(
  Buffer: PChar; Data: Pointer);
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('SetBookmarkData');
  inherited;
end;

function TDebugDataSet.GetRecordSize: Word;
begin
  Result := inherited GetRecordSize;
  if Assigned(FDebugNotify) then
    FDebugNotify('GetRecordSize: ' + IntToStr(Result));
end;

function TDebugDataSet.AllocRecordBuffer: PChar;
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('AllocRecordBuffer');
  Result := inherited AllocRecordBuffer;
end;

procedure TDebugDataSet.InternalInitRecord(Buffer: PChar);
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('InternalInitRecord');
  inherited;
end;

procedure TDebugDataSet.FreeRecordBuffer(var Buffer: PChar);
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('FreeRecordBuffer');
  inherited;
end;

function TDebugDataSet.GetRecord(Buffer: PChar;
  GetMode: TGetMode; DoCheck: Boolean): TGetResult;
begin
  case GetMode of
    gmNext:
      if Assigned(FDebugNotify) then
        FDebugNotify('GetRecord: Next');
    gmPrior:
      if Assigned(FDebugNotify) then
        FDebugNotify('GetRecord: Prior');
    gmCurrent:
      if Assigned(FDebugNotify) then
        FDebugNotify('GetRecord: Current');
  end;
  Result := inherited GetRecord(Buffer, GetMode, DoCheck);
end;

procedure TDebugDataSet.InternalFirst;
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('InternalFirst');
  inherited;
end;

procedure TDebugDataSet.InternalLast;
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('InternalLast');
  inherited;
end;

procedure TDebugDataSet.InternalPost;
begin
  if State = dsEdit then
    if Assigned(FDebugNotify) then
      FDebugNotify('InternalPost ***** dsEdit')
    else if Assigned(FDebugNotify) then
      FDebugNotify('InternalPost ***** dsInsert');
  inherited;
end;

procedure TDebugDataSet.InternalAddRecord(
  Buffer: Pointer; Append: Boolean);
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('InternalAddRecord ****');
  inherited;
end;

procedure TDebugDataSet.InternalDelete;
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('InternalDelete');
  inherited;
end;

function TDebugDataSet.GetFieldData(
  Field: TField; Buffer: Pointer): Boolean;
begin
  Result := inherited GetFieldData(Field, Buffer);
end;

procedure TDebugDataSet.SetFieldData(Field: TField; Buffer: Pointer);
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('SetFieldData');
  inherited;
end;

function TDebugDataSet.GetRecordCount: Longint;
begin
  Result := inherited GetRecordCount;
  if Assigned(FDebugNotify) then
    FDebugNotify('GetRecordCount: ' + IntToStr(Result));
end;

function TDebugDataSet.GetRecNo: Longint;
begin
  Result := inherited GetRecNo;
  if Assigned(FDebugNotify) then
    FDebugNotify('GetRecNo: ' + IntToStr(Result));
end;

procedure TDebugDataSet.SetRecNo(Value: Integer);
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('SetRecNo: ' + IntToStr(Value));
  inherited;
end;

procedure TDebugDataSet.InternalRefresh;
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('InternalRefresh');
  inherited;
end;

procedure TDebugDataSet.InternalHandleException;
begin
  if Assigned(FDebugNotify) then
    FDebugNotify('InternalHandleException');
  inherited;
end;

end.

unit DebugDSForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics,
  Controls, Forms, Dialogs, DebugSet, Grids, DBGrids, DBCtrls, ExtCtrls,
  StdCtrls, Db, DBTables, Menus;

type
  TForm1 = class(TForm)
    Table1: TTable;
    DataSource1: TDataSource;
    ListBox1: TListBox;
    Splitter1: TSplitter;
    Panel1: TPanel;
    DBNavigator1: TDBNavigator;
    DBGrid1: TDBGrid;
    Panel2: TPanel;
    BtnOpen: TButton;
    BtnClose: TButton;
    BtnClear: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure BtnClearClick(Sender: TObject);
    procedure BtnOpenClick(Sender: TObject);
    procedure BtnCloseClick(Sender: TObject);
  private
    TableClone: TDebugDataSet;
  public
    procedure LocalNotify(const DebugText: string);
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  Table1.Close;
  TableClone := TDebugDataSet.Create(nil);
  TableClone.DatabaseName := Table1.DatabaseName;
  TableClone.TableName := Table1.TableName;
  TableClone.OnDebugNotify := LocalNotify;
  DataSource1.DataSet := TableClone;
end;

procedure TForm1.LocalNotify(const DebugText: string);
var
  nItem: Integer;
begin
  if Assigned(ListBox1) then
  begin
    // add the text to the string
    nItem := ListBox1.Items.Add(DebugText);
    // select the new item
    ListBox1.ItemIndex := nItem;
  end;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  TableClone.Close;
  TableClone.Free;
end;

procedure TForm1.BtnClearClick(Sender: TObject);
begin
  ListBox1.Items.Clear;
end;

procedure TForm1.BtnOpenClick(Sender: TObject);
begin
  TableClone.Active := True;
end;

procedure TForm1.BtnCloseClick(Sender: TObject);
begin
  TableClone.Active := False;
end;

end.