dxdatasetbintree.pas

Well known and usefull component for delphi 7

unit DXDataSetBinTree;

interface

///////////////////////////////////////////////////////////////////////////////
// Component: TDXDataSetBinaryTree
//    Author: G.E. Ozz Nixon Jr. ([e-mail])
// ============================================================================
// This was started in 2000 as a goal of having internal configuration files to
// our demonstrations. As of 2002, we have decided to go ahead and release this.
// Limitations: It does not have all of the D6 field types, but has everything
// you should probably need for your memory database.
// --V2.0--
// Implemented ability to have a shared memory image. All instances that have
// UseSharedMemory as true are slaves - meaning they can not destory the memory
// but can add/delete etc. Close will not destory the shared memory region
///////////////////////////////////////////////////////////////////////////////

uses
   DB,
   Classes,
{$IFDEF VER140}
   Variants,
{$ENDIF}
{$IFDEF VER150}
   Variants,
{$ENDIF}
{$IFDEF VER120}
   DBCommon,
{$ENDIF}
   DXDBCommon,
   DXDataListBinTree,
   DXBlobList;

{$IFDEF VER90}
   {$DEFINE VER100} // Make D2 compile as D3!
{$ENDIF}

Type
  TDXDataSetBinaryTree=class;

  TDXBlobStream=class(TMemoryStream)
  private
    FField:TBlobField;
    FDataSet:TDXDataSetBinaryTree;
    FFieldNo:Integer;
    FModified:Boolean;
    procedure ReadBlobData;
  public
    constructor Create(Field:TBlobField;Mode:TBlobStreamMode);
    destructor Destroy; override;
    function Write(const Buffer;Count:Longint):Longint; override;
    procedure Truncate;
  end;

  TDXDataSetBinaryTree = class(TDataSet)
  private
     fWantsExclusive:Boolean;
     fDatabaseName:String;
     fTableName:String;
     fNeedFields:TNotifyEvent;
     function FieldDefsStored: Boolean;
     procedure ResetBookmarkFlags;
  protected
    FUseShareDataList:Boolean;
    FNeedDataList:TNotifyEvent;
    FIgnoreSetFieldChk:Boolean;
    FIndexFieldNames:String;
    FIndexDefs:TIndexDefs;
    FDataSource:TDataSource;
    FBlobId:Integer;
    FBookmarkInfoOffset:Cardinal;
    FBufferSize:Integer;
    FBookmarkInfoSize:Integer;
    FStartCalculated:Integer;
    FRecordSize:Integer;
    FBlobRecSize:Integer;
    FBlobSize:Integer;
    FBlobCount:Cardinal;
    FRecBufferSize:Integer;
    FRecordPos:Cardinal;
    FIsOpen:Boolean;
    FFilterBuffer:PChar;
    FMasDetFiltered:Boolean;
    FIntBookmark:Cardinal;
    FRealRecNo:Cardinal;
    FStoreDefs:Boolean;
    FReadOnly:Boolean;
    FCanModify:Boolean;
    FBlobList:TDXBlobList;
    FLastBookmark:Cardinal;
    FUniDirectional:Boolean;
    FDataList:TDXDataList;
    FDoEvents:Boolean;
{ Mandatory overrides }
    // Record buffer methods:
    function AllocRecordBuffer: PChar; override;
    procedure FreeRecordBuffer(var Buffer: PChar); override;
    procedure InternalInitRecord(Buffer: PChar); override;
    procedure ClearCalcFields(Buffer: PChar); override;
    function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override;
    function GetRecordSize: Word; override;
    procedure SetFieldData(Field: TField; Buffer: Pointer); override;
    procedure SetFieldDataNoDataEvent(Field :TField; Buffer :Pointer);
    // Bookmark methods:
    procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
    function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;
    procedure InternalGotoBookmark(Bookmark: Pointer); override;
    procedure InternalSetToRecord(Buffer: PChar); override;
    procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
    procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
    // Navigational methods:
    procedure InternalFirst; override;
    procedure InternalLast; override;
    // Editing methods:
    procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); override;
    procedure InternalDelete; override;
    procedure InternalPost; override;
    // Misc methods:
    procedure InternalClose; override;
    procedure InternalHandleException; override;
    procedure InternalInitFieldDefs; override;
    procedure InternalOpen; override;
    function IsCursorOpen: Boolean; override;
    procedure DoAfterScroll; override;
    procedure DoBeforeScroll; override;
{ Optional overrides }
    function FindRecord(Restart, GoForward: Boolean): Boolean; override;
    function GetRecNo: Integer; override;
    function GetRecordCount: Integer; override;
    procedure SetRecNo(Value: Integer); override;
    procedure InitRecord(Buffer: PChar); override;
    function DXTabGetFieldOffset(FieldNo: integer): Integer;
    function DXTabGetFieldSize(FieldNo: integer): Integer;
    function DXTabGetFieldPointer(Buffer:PChar; Field:TField):PChar;
    function DXTabGetActiveBuffer(var Buffer: PChar): Boolean;

    procedure DXTabInsertRecord(RecNo :Integer; Buffer:PChar); virtual;

    function DXTabFilterRecord(Buffer: PChar): Boolean;
    function DXGetFieldData(RecNo:Cardinal; Field :TField) :PChar; virtual;
    function InternalLocate(const KeyFields :String;
                            const KeyValues :Variant;
                            Options :TLocateOptions;
                            FromStart:Boolean) :Boolean; virtual;
    procedure CreateTable;
    function GetCanModify: Boolean; override;
    procedure SetReadOnly(Value :Boolean);
    procedure SetFieldNull(FieldNo :Integer; IsNull :Boolean);
    function IsFieldNull(FieldNo :Integer) :Boolean;
    procedure CheckOpen;
    procedure SetfDatabaseName(Value:String);
    procedure StoreMemoryStream(Field :TField; M :TMemoryStream);
    procedure DataEvent(Event: TDataEvent; Info: Longint); override;
    function GetInternalFieldData(Field: TField ) :PChar;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function AssociateToMyDataList:TDXDataList;
    Procedure SetMyDataList(Value:TDXDataList);
    function GetFieldData(Field:TField;Buffer:Pointer):Boolean; override;
    function BookmarkValid(Bookmark:Pointer):Boolean; override;
    function CreateBlobStream(Field:TField;Mode:TBlobStreamMode):TStream; override;
    function CompareBookmarks(Bookmark1,Bookmark2:TBookmark):Integer; override;
    function IsBlobField(F:TField):Boolean;
    function GetMemoryStream(Field:TField):TMemoryStream;
    // Additional procedures
    procedure EmptyDataSet; virtual;
    function Locate(const KeyFields: string;
                    const KeyValues: Variant;
                    Options: TLocateOptions): Boolean; override;
    function LocateNext(const KeyFields : String;
                        const KeyValues :Variant;
                        Options :TLocateOptions) :Boolean; virtual;
    function Lookup(const KeyFields : String; const KeyValues : Variant;
                    const ResultFields :String): Variant; override;
    procedure AddField(FieldName:String;FType:TFieldType;FSize:Integer;FRequired:Boolean);
    procedure SaveToStream(Stream:TMemoryStream;Append:Boolean);
    procedure SaveToFile(Filename:String);
    Procedure LoadFromStream(Stream:TStream);
    procedure LoadFromFile(Filename:String);
    property BlobList:TDXBlobList read FBlobList write FBlobList;
  published
    property UseSharedMemory:Boolean read FUseShareDataList
                                     write FUseShareDataList;
    property Exclusive:Boolean read fWantsExclusive
                               write fWantsExclusive;
    property DatabaseName:String read fDatabaseName
                                 write SetfDatabaseName;
    property TableName:String read fTableName
                              write fTableName;
    property OnNeedFields:TNotifyEvent read fNeedFields
                                       write fNeedFields;
    property OnNeedSharedMemory:TNotifyEvent read FNeedDataList
                                             write FNeedDataList;
    property FieldDefs stored FieldDefsStored;
    property StoreDefs: Boolean read FStoreDefs write FStoreDefs default True;
    property ReadOnly :Boolean read FReadOnly write SetReadOnly; // default False;
    property AutoCalcFields;
    property CurrentRecord;
    property Filter;
    property Filtered;
    property FilterOptions;
    property BufferCount;
    property Active;
    property BeforeOpen;
    property AfterOpen;
    property BeforeClose;
    property AfterClose;
    property BeforeInsert;
    property AfterInsert;
    property BeforeEdit;
    property AfterEdit;
    property BeforePost;
    property AfterPost;
    property BeforeCancel;
    property AfterCancel;
    property BeforeDelete;
    property AfterDelete;
    property BeforeScroll;
    property AfterScroll;
    property OnDeleteError;
    property OnEditError;
    property OnCalcFields;
    property OnNewRecord;
    property OnPostError;
    property OnFilterRecord;
{$IFNDEF VER100}
    property BeforeRefresh;
    property AfterRefresh;
{$ENDIF}
  end;

procedure Register;

implementation

uses
   dxstring,
   Windows,
   SysUtils;

procedure Register;
begin
   RegisterComponents('BPDX Dataset', [TDXDataSetBinaryTree]);
end;

Procedure SetByteBit(Var L:Byte;const Bit:Byte;const Setting:Boolean);
Var
   Mask:Byte;

Begin
   Mask:=1;
   Mask:=Mask Shl (Bit-1);
   If Setting Then L:=L or Mask
   Else L:=(L and (Not Mask));
End;

Function GetByteBit(const L:Byte;const Bit:Byte):Boolean;
Var
   Mask:Byte;

Begin
   Mask:=1;
   Mask:=Mask Shl (Bit-1);
   Result:=(L and Mask)<>0;
End;

{ TDXDataSetBinaryTree }

constructor TDXDataSetBinaryTree.Create(AOwner: TComponent);
begin
   inherited Create(AOwner);
   FBookmarkInfoSize:=SizeOf(TDXBookmarkInfo);
   FBlobList:=TDXBlobList.Create;
   FUniDirectional:=False;
   FMasDetFiltered:=True;
   FDoEvents:=True;
   FStoreDefs:=True;
end;

destructor TDXDataSetBinaryTree.Destroy;
begin
   If Active then Close; //2-5-2002
   If Assigned(FBlobList) then FBlobList.Free;
   inherited Destroy;
end;

procedure TDXDataSetBinaryTree.SetfDatabaseName(Value:String);
Begin
   If Value<>'' then
{do an ifdef linux!}   
      If Copy(Value,Length(Value),1)<>'\' then Value:=Value+'\';
   fDatabaseName:=Value;
End;

function TDXDataSetBinaryTree.AllocRecordBuffer:PChar;
begin
   Result:=AllocMem(FRecBufferSize);
end;

procedure TDXDataSetBinaryTree.FreeRecordBuffer(var Buffer:PChar);
begin
   FreeMem(Buffer);
end;

procedure TDXDataSetBinaryTree.InitRecord(Buffer: PChar);
begin 
   inherited InitRecord(Buffer);
   with PRecInfo(Buffer+FBookmarkInfoOffset)^ do begin
      BookmarkFlag:=bfInserted;
      UpdateStatus:=TUpdateStatus(usInserted);
   end;
end;

procedure TDXDataSetBinaryTree.InternalInitRecord(Buffer: PChar);
var
   Loop:Integer;

begin
   for Loop:=0 to FieldDefs.Count-1 do begin
      case FieldDefs.Items[Loop].Datatype of
         ftString:PChar(Buffer+DXTabGetFieldOffset(Loop+1))^:=#0;
         ftBoolean:PBoolean(Buffer+DXTabGetFieldOffset(Loop+1))^:=False;
         ftFloat:PFloat(Buffer+DXTabGetFieldOffset(Loop+1))^:=0;
         ftSmallInt:PSmallInt(Buffer+DXTabGetFieldOffset(Loop+1))^:=0;
         ftCurrency:PFloat(Buffer+DXTabGetFieldOffset(Loop+1))^:=0;
         ftDate,
         ftTime,
         ftDateTime:PDateTime(Buffer+DXTabGetFieldOffset(Loop+1))^:=0;
         ftAutoInc:PInteger(Buffer+DXTabGetFieldOffset(Loop+1))^:=Loop+1;
         ftInteger,
         ftVarBytes,
         ftGraphic,
         ftBlob,
         ftMemo:PInteger(Buffer+DXTabGetFieldOffset(Loop+1))^:=0;
      end;
      PBoolean(Buffer+DXTabGetFieldOffset(Loop+1)+DXTabGetFieldSize(Loop+1))^:=True;
  end;
end;

{procedure TDataSet.GetAutoIncFields(Buffer: PChar);
var
  SaveState: TDataSetState;

begin
   If fAutoIncExists then Begin
      SaveState:=FState;
      FState:=dsCalcFields; // dont have one for autoinc
try
      CalculateAutoIncFields(Buffer);
finally
      FState:=SaveState;
end;
   end;
end;

procedure TDataSet.CalculateAutoIncFields(Buffer: PChar);
var
  I: Integer;

begin
  for I:=0 to FFields.Count-1 do
    with TField(FFields[I]) do
      if FieldKind=fkData then
end;}

function TDXDataSetBinaryTree.GetRecord(Buffer:PChar;GetMode:TGetMode;
  DoCheck:Boolean):TGetResult;

var
   Acceptable:Boolean;

begin
   Result:=grOk;
   Acceptable:=False;
   if FDataList.Count<1 then Result:=grEOF
   else begin
      repeat
         case GetMode of
            gmPrior:if FRecordPos<=1 then begin
               Result:=grBOF;
               FRecordPos:=0;
            end
            else Dec(FRecordPos);
            gmCurrent:if (FRecordPos<1) or
               (FRecordPos>=RecordCount) then Result:=grError;
            gmNext:if FRecordPos>=RecordCount then Begin
               Result:=grEOF;
               FRecordPos:=RecordCount;
            End
            else Inc(FRecordPos);
         end;
         if Result=grOK then begin
            FDataList.GetFromBuffer(Buffer,FRecordPos);
            PRecInfo(Buffer+FBookmarkInfoOffset)^.Bookmark:=FDataList.BookMark(FRecordPos);
            PRecInfo(Buffer+FBookmarkInfoOffset)^.BookmarkFlag:=bfCurrent;
            GetCalcFields(Buffer);
            if (Filtered) then Acceptable:=DXTabFilterRecord(Buffer)
            else Acceptable:=True;
            if (GetMode=gmCurrent) and (not Acceptable) then Result:=grError;
         end
         else
         if (Result=grError) and DoCheck then
{$IFDEF VER100}
            DatabaseError(SNoRecord);
{$ELSE}
            DatabaseError(SNoRecord,Self);
{$ENDIF}
      until (Result<>grOK) or Acceptable;
   end;
end;

function TDXDataSetBinaryTree.GetRecordSize: Word;
begin
   Result:=FRecordSize;
end;

function TDXDataSetBinaryTree.GetInternalFieldData(Field:TField):PChar;
var
   SrcBuffer:PChar;
   Res:PChar;

begin
   Result:=nil;
   if not DXTabGetActiveBuffer(SrcBuffer) then Exit;