zsqlbuffer.pas

控件名称：WINZEOS.ZIP 2002年08月03日 作者：CapellaDevelopment Zeos系列构件套件包含一组可直接存取Linux知名的免费数据库MySQL、Postgre

{********************************************************}
{                                                        }
{                 Zeos Database Objects                  }
{                  Sql records buffer                    }
{                                                        }
{       Copyright (c) 1999-2001 Sergey Seroukhov         }
{    Copyright (c) 1999-2001 Zeos Development Group      }
{                                                        }
{********************************************************}

unit ZSqlBuffer;

interface

{$IFNDEF LINUX}
{$INCLUDE ..\ZeosDef.inc}
{$ELSE}
{$INCLUDE ../ZeosDef.inc}
{$ENDIF}

uses Classes, Windows,Variants, SysUtils, DB, ZSqlTypes, ZSqlItems, 
  ZList;

{$IFNDEF LINUX}
{$INCLUDE ..\Zeos.inc}
{$ELSE}
{$INCLUDE ../Zeos.inc}
{$ENDIF}

type
  { Buffer records class }
  TSqlBuffer = class (TZItemList)
  private
    FIsCache: Boolean;
    FBlobCount: Integer;
    FRecBufSize: Integer;
    FLastIndex: Integer;
    FSqlFields: TSqlFields;
    FSqlIndices: TSqlIndices;
    FDataset: TDataset;

    FSortFields: TFieldList;
    FSortFieldCount: Integer;
    FSortType: TSortType;
    FIsSortInverse: Boolean;

    FFilterFields: TFieldList;
    FFilterFieldCount: Integer;
    FFilterTypes: TZUpdateRecordTypes;
    FFilterBuffer: PRecordData;

    function GetItem(Index: Integer): PRecordData;
    function GetRecordSize: Integer;
    function GetRecBufSize: Integer;
    function GetFilterFields(Index: Integer): Integer;
    procedure SetFilterFields(Index: Integer; Value: Integer);
    function GetSortFields(Index: Integer): Integer;
    procedure SetSortFields(Index: Integer; Value: Integer);
  protected
    procedure DoProgress(Stage: Integer; Proc: Integer; Position, Max: Integer);
    procedure UpdateBufferSize;
    function SortRecord(Item1, Item2: Pointer): Integer;
    function FilterRecord(Item: Pointer): Boolean;
  public
    constructor Create(Dataset: TDataset);
    constructor CreateCache(SqlBuffer: TSqlBuffer);
    destructor  Destroy; override;

    procedure SetCache(SqlBuffer: TSqlBuffer);
    procedure SetSort(Fields: string; SortType: TSortType);
    procedure SortInverse;
    procedure SortRestore;
    procedure ClearBuffer(Force: Boolean);

    function Add: PRecordData;
    function Insert(Index: Integer): PRecordData;
    function Delete(Index: Integer): PRecordData;
    function IndexOfIndex(Index: Integer): Integer;
    function SafeIndexOfIndex(Index: Integer): Integer;

    function GetFieldData(FieldDesc: PFieldDesc; Buffer: Pointer;
      RecordData: PRecordData): Boolean;
    procedure SetFieldData(FieldDesc: PFieldDesc; Buffer: Pointer;
      RecordData: PRecordData);
    procedure SetFieldDataLen(FieldDesc: PFieldDesc; Buffer: Pointer;
      RecordData: PRecordData; Length: Integer);

    function GetFieldValue(FieldDesc: PFieldDesc;
      RecordData: PRecordData): Variant;
    procedure SetFieldValue(FieldDesc: PFieldDesc; Value: Variant;
      RecordData: PRecordData);
    function GetField(FieldDesc: PFieldDesc;
      RecordData: PRecordData): string;
    procedure SetField(FieldDesc: PFieldDesc; Value: string;
      RecordData: PRecordData);
    function GetFieldNull(FieldDesc: PFieldDesc;
      RecordData: PRecordData): Boolean;
    procedure SetFieldNull(FieldDesc: PFieldDesc; Value: Boolean;
      RecordData: PRecordData);

    procedure InitRecord(Value: PRecordData);
    procedure CopyRecord(Source, Dest: PRecordData; Force: Boolean);
    procedure FreeRecord(Value: PRecordData; Clear: Boolean);
    procedure BindFields(SqlFields: TSqlFields);
    procedure BindIndices(Indices: TIndexDefs; SqlIndices: TSqlIndices);
    procedure ProcessFieldList(Fields: string; var FieldList: TFieldList;
      var FieldCount: Integer);
    function CompareRecord(Item1, Item2: PRecordData; var FieldList: TFieldList;
      var FieldCount: Integer): Integer;

    property Dataset: TDataset read FDataset write FDataset;
    property Items[Index: Integer]: PRecordData read GetItem; default;
    property SqlFields: TSqlFields read FSqlFields;
    property SqlIndices: TSqlIndices read FSqlIndices;
    property BlobCount: Integer read FBlobCount;
    property RecBufSize: Integer read GetRecBufSize;
    property RecordSize: Integer read GetRecordSize;

    property SortFields[Index: Integer]: Integer read GetSortFields
      write SetSortFields;
    property SortFieldCount: Integer read FSortFieldCount write FSortFieldCount;
    property SortType: TSortType read FSortType write FSortType;
    property IsSortInverse: Boolean read FIsSortInverse write FIsSortInverse;

    property FilterFields[Index: Integer]: Integer read GetFilterFields
      write SetFilterFields;
    property FilterFieldCount: Integer read FFilterFieldCount write FFilterFieldCount;
    property FilterBuffer: PRecordData read FFilterBuffer write FFilterBuffer;
    property FilterTypes: TZUpdateRecordTypes read FFilterTypes write FFilterTypes;
  end;

const
  RecInfoSize = SizeOf(TRecordData) - SizeOf(TByteArray);

implementation

uses ZExtra, ZSqlExtra, ZToken, ZQuery;

{*************** TSqlBuffer class implementation **************}

{ Class constructor }
constructor TSqlBuffer.Create(Dataset: TDataset);
begin
  inherited Create(SizeOf(TRecordData));
  Self.Dataset := Dataset;
  FSqlFields := TSqlFields.Create;
  FSqlIndices := TSqlIndices.Create;
  FIsCache := False;
  FFilterTypes := [ztModified, ztInserted, ztUnmodified];
  OnFilter := FilterRecord;
  OnSort := SortRecord;
end;

{ Class cache constructor }
constructor TSqlBuffer.CreateCache(SqlBuffer: TSqlBuffer);
begin
  inherited Create(SizeOf(TRecordData));
  Self.Dataset := SqlBuffer.Dataset;
  FSqlFields := SqlBuffer.SqlFields;
  FSqlIndices := SqlBuffer.SqlIndices;
  FIsCache := True;
end;


{ Class destructor }
destructor TSqlBuffer.Destroy;
begin
  ClearBuffer(True);
  if not FIsCache then
  begin
    FSqlFields.Free;
    FSqlIndices.Free;
  end;
  inherited Destroy;
end;

{ Update cache data }
procedure TSqlBuffer.SetCache(SqlBuffer: TSqlBuffer);
begin
  if FIsCache then
  begin
    FBlobCount := SqlBuffer.FBlobCount;
    FRecBufSize := SqlBuffer.RecBufSize;
    ItemSize := SqlBuffer.ItemSize;
  end;
end;

{ Get record buffer }
function TSqlBuffer.GetItem(Index: Integer): PRecordData;
begin
  if (Index < 0) or (Index >= Count) then
    Error('List Index Error at %d', Index);
  Result := PRecordData(List^[Index]);
end;

{ Get filter fields value }
function TSqlBuffer.GetFilterFields(Index: Integer): Integer;
begin
  Result := FFilterFields[Index];
end;

{ Set filter fields value }
procedure TSqlBuffer.SetFilterFields(Index, Value: Integer);
begin
  FFilterFields[Index] := Value;
end;

{ Get sort fields value }
function TSqlBuffer.GetSortFields(Index: Integer): Integer;
begin
  Result := FSortFields[Index];
end;

{ Set Sort fields value }
procedure TSqlBuffer.SetSortFields(Index, Value: Integer);
begin
  FSortFields[Index] := Value;
end;

{ Init record buffer }
procedure TSqlBuffer.InitRecord(Value: PRecordData);
begin
  FillChar(Value.Bytes, RecordSize, 1);
  Value.Signature := 123;
  Value.Index := FLastIndex;
  Value.BookmarkFlag := bfCurrent;
  Value.RecordType := ztUnmodified;
  Inc(FLastIndex);
end;

{ Copy record buffer }
procedure TSqlBuffer.CopyRecord(Source, Dest: PRecordData; Force: Boolean);
var
  I: Integer;
  SourceBlob, DestBlob: PRecordBlob;
begin
  FreeRecord(Dest, False);
  if Force then
    System.Move(Source^, Dest^, RecBufSize)
  else
    System.Move(Source.Bytes, Dest.Bytes, RecordSize);
  for I := 0 to SqlFields.Count-1 do
    if (SqlFields[I].FieldType in [ftBlob, ftMemo, ftGraphic, ftFmtMemo])
      and (Dest.Bytes[SqlFields[I].Offset] = 0) then
    begin
      SourceBlob := PRecordBlob(@Source.Bytes[SqlFields[I].Offset+1]);
      DestBlob := PRecordBlob(@Dest.Bytes[SqlFields[I].Offset+1]);

      DestBlob.Data := AllocMem(DestBlob.Size);
      System.Move(SourceBlob.Data^, DestBlob.Data^, DestBlob.Size);
   end;
  TZDataset(Dataset).CopyRecord(Self, Source, Dest);
end;

{ Free record buffer }
procedure TSqlBuffer.FreeRecord(Value: PRecordData; Clear: Boolean);
var
  I: Integer;
begin
  TZDataset(Dataset).FreeRecord(Self, Value);
  for I := 0 to SqlFields.Count-1 do
  begin
    if (SqlFields[I].FieldType in [ftBlob, ftMemo, ftGraphic, ftFmtMemo])
      and (Value.Bytes[SqlFields[I].Offset] = 0) then
    begin
      FreeMem(PRecordBlob(@Value.Bytes[SqlFields[I].Offset+1]).Data);
    end;
    if Clear then
      Value.Bytes[SqlFields[I].Offset] := 1;
  end;
end;

{ Add new item }
function TSqlBuffer.Add: PRecordData;
begin
  Result := PRecordData(inherited Add);
  InitRecord(Result);
end;

{ Delete item }
function TSqlBuffer.Delete(Index: Integer): PRecordData;
begin
  if (Index < 0) or (Index >= Count) then
    Error('List Index Error at %d', Index);
  FreeRecord(PRecordData(List^[Index]), False);
  Result := PRecordData(inherited Delete(Index));
end;

{ Clear all buffer }
procedure TSqlBuffer.ClearBuffer(Force: Boolean);
var
  I: Integer;
  Ptr: Pointer;
begin
  { Clear all records }
  if BlobCount > 0 then
  begin
    { Invoke on progress event }
    DoProgress(Ord(psStarting), Ord(ppClosing), 0, FillCount);
    { Free blob buffers }
    for I := 0 to FillCount-1 do
    begin
      Ptr := FillList^[I];
      if PByte(Ptr)^ <> ITEM_DELETED then
        FreeRecord(PRecordData(LongInt(Ptr) + 1), False);
      { Invoke on progress event }
      DoProgress(Ord(psRunning), Ord(ppClosing), I+1, FillCount);
    end;
    { Invoke on progress event }
    DoProgress(Ord(psEnding), Ord(ppClosing), FillCount, FillCount);
  end;
  { Free allocated memory }
  inherited Clear;
  FLastIndex := 0;
  { Clear in full mode }
  if Force then
  begin
    { Free filter buffer }
    if Assigned(FFilterBuffer) then
      FreeRecord(FFilterBuffer, False);
    FreeMem(FFilterBuffer);
    FFilterBuffer := nil;
    { Zero variables }
    FBlobCount := 0;
    FRecBufSize := 0;
    FSortFieldCount := 0;
    FFilterFieldCount := 0;
    FIsSortInverse := False;
    { Clear fields and indices }
    SqlFields.Clear;
    SqlIndices.Clear;
  end;
end;

{ Insert new record }
function TSqlBuffer.Insert(Index: Integer): PRecordData;
begin
  Result := PRecordData(inherited Insert(Index));
  InitRecord(Result);
end;

{ Update record buffer lengths }
procedure TSqlBuffer.UpdateBufferSize;
var
  I: Integer;
begin
  FRecBufSize := 0;
  FBlobCount := 0;
  for I := 0 to SqlFields.Count - 1 do
    with SqlFields.Items[I]^ do
    begin
      if not Assigned(FieldObj) then
        DatabaseError('Fatal internal error');
      Offset := FRecBufSize;
      DataSize := FieldObj.DataSize;
      FieldType := FieldObj.DataType;
      FieldNo := FieldObj.FieldNo - 1;
      if FieldType in [ftBlob, ftMemo, ftGraphic, ftFmtMemo] then
      begin
        DataSize := SizeOf(TRecordBlob);
        Inc(FBlobCount);
      end;

      Inc(FRecBufSize, Max(DataSize, 4) + 1);
    end;
  Inc(FRecBufSize, RecInfoSize {!!!});
  ReallocMem(FFilterBuffer, FRecBufSize);
  InitRecord(FFilterBuffer);
end;

{ Get record size }
function TSqlBuffer.GetRecordSize: Integer;
begin
  Result := FRecBufSize - RecInfoSize {!!!};
end;

{ Get record buffer size }
function TSqlBuffer.GetRecBufSize: Integer;
begin
  Result := FRecBufSize
end;

{ Setup all fields }
procedure TSqlBuffer.BindFields(SqlFields: TSqlFields);
var
  I: Integer;
  FieldDesc: PFieldDesc;
  NewFieldDesc: PFieldDesc;
begin
  Self.SqlFields.Clear;
  Self.Clear;
  for I := 0 to Dataset.FieldCount-1 do
  begin
    FieldDesc := SqlFields.FindByAlias(Dataset.Fields[I].FieldName);
    if Assigned(FieldDesc) then
    begin
      NewFieldDesc := Self.SqlFields.AddDesc(FieldDesc);
      NewFieldDesc.FieldObj := Dataset.Fields[I];
    end else
      Self.SqlFields.AddField(Dataset.Fields[I]);
  end;

  UpdateBufferSize;
  ItemSize := RecBufSize + 1;
end;

{ Setup all indices }
procedure TSqlBuffer.BindIndices(Indices: TIndexDefs; SqlIndices: TSqlIndices);
var
  I, J: Integer;
  FieldCount: Integer;
  IndexDesc: PIndexDesc;
  NewIndexDesc: PIndexDesc;
begin
  Self.SqlIndices.Clear;
  for I := 0 to SqlIndices.Count - 1 do
  begin
    FieldCount := 0;
    IndexDesc := SqlIndices[I];
    NewIndexDesc := Self.SqlIndices.Add;
    NewIndexDesc.Table := IndexDesc.Table;
    NewIndexDesc.Name := IndexDesc.Name;
    NewIndexDesc.KeyType := IndexDesc.KeyType;
    NewIndexDesc.SortType := IndexDesc.SortType;
    for J := 0 to IndexDesc.FieldCount - 1 do
    begin
      if Assigned(SqlFields.FindByName(IndexDesc.Table, IndexDesc.Fields[J])) then
      begin
        NewIndexDesc.Fields[FieldCount] := IndexDesc.Fields[J];
        Inc(FieldCount);
      end else
        NewIndexDesc.KeyType := ktIndex;
    end;
    if FieldCount > 0 then
      NewIndexDesc.FieldCount := FieldCount