debugset.pas

Delphi高级开发指南是开发程序的好帮手

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.