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

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

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.

{/codecitation}

Добавить комментарий