memtableeh.pas

增加了条件求和功能

{*******************************************************}
{                                                       }
{                     EhLib vX.X                        }
{                                                       }
{            TMemTableEh component (Build 5)            }
{                                                       }
{      Copyright (c) 2003 by Dmitry V. Bolshakov        }
{                                                       }
{*******************************************************}

unit MemTableEh;

{$I EHLIB.INC}

interface

uses Windows, SysUtils, Classes, Controls, DB,
{$IFDEF EH_LIB_6} Variants, {$ENDIF}
{$IFDEF EH_LIB_5} Contnrs, {$ENDIF}
  ToolCtrlsEh, DBCommon, MemTableDataEh;

type

  TCustomMemTableEh = class;

  TLoadMode = (lmCopy, lmAppend);

{ TMasterDataLinkEh }

  TMasterDataLinkEh = class(TDetailDataLink)
  private
    FDataSet: TDataSet;
    FFieldNames: string;
    FFields: TList;
    FOnMasterChange: TNotifyEvent;
    FOnMasterDisable: TNotifyEvent;
    procedure SetFieldNames(const Value: string);
  protected
    function GetDetailDataSet: TDataSet; override;
    procedure ActiveChanged; override;
    procedure CheckBrowseMode; override;
    procedure LayoutChanged; override;
    procedure RecordChanged(Field: TField); override;
  public
    constructor Create(DataSet: TDataSet);
    destructor Destroy; override;
    property FieldNames: string read FFieldNames write SetFieldNames;
    property Fields: TList read FFields;
    property OnMasterChange: TNotifyEvent read FOnMasterChange write FOnMasterChange;
    property OnMasterDisable: TNotifyEvent read FOnMasterDisable write FOnMasterDisable;
  end;

{ TCustomMemTableEh }

  TMasterDetailSideEh = (mdsOnSelfEh, mdsOnProviderEh);

  TMTUpdateActionEh = (uaFailEh, uaAbortEh, uaSkipEh, uaRetryEh, uaApplyEh, uaAppliedEh);

  TMTUpdateRecordEventEh = procedure(DeltaDataSet: TDataSet; UpdateKind: TUpdateKind;
    var UpdateAction: TMTUpdateActionEh) of object;

  TMTFetchRecordEventEh = procedure(PacketDataSet: TDataSet; var ProviderEOF,
    Applied: Boolean) of object;

  TMTRefreshRecordEventEh = procedure(PacketDataSet: TDataSet; var Applied: Boolean)
    of object;

  TCustomMemTableEh = class(TDataSet, IMemTableEh, IUnknown)
  private
    FActive: Boolean;
    FAutoInc: Longint;
    FDataRecordSize: Integer;
    FDetailFieldList: TList;
    FDetailFields: String;
    FDetailMode: Boolean;
    FInstantBuffer: PChar;
    FInstantReadCurRow: Integer;
    FFetchAllOnOpen: Boolean;
    FKeyFields: String;
    FMasterDetailSide: TMasterDetailSideEh;
    FMasterValues: Variant;
    FOnFetchRecord: TMTFetchRecordEventEh;
    FOnUpdateRecord: TMTUpdateRecordEventEh;
    FOrderByList: TList;
    FParams: TParams;
    FProviderDataSet: TDataSet;
    FProviderEOF: Boolean;
    FReadOnly: Boolean;
    FRecBufSize: Integer;
    FRecordPos: Integer;
    FRecordsView: TRecordsViewEh;
    FFilterExpr: TDataSetExprParserEh;
    FCachedUpdates: Boolean;
    function FindFieldData(Buffer: Pointer; Field: TField): Pointer;
    function GetCachedUpdates: Boolean;
    function GetDataFieldsCount: Integer;
    function GetInstantReadCurRow: Integer;
    function GetMasterFields: String;
    function GetMasterSource: TDataSource;
    function IsRecordInFilter(RecValues: PRecValues): Boolean;
    procedure ClearRecords;
    procedure InitBufferPointers(GetProps: Boolean);
    procedure RefreshParams;
    procedure SetCachedUpdates(const Value: Boolean);
    procedure SetDetailFields(const Value: String);
    procedure SetKeyFields(const Value: String);
    procedure SetMasterDetailSide(const Value: TMasterDetailSideEh);
    procedure SetMasterFields(const Value: String);
    procedure SetMasterSource(const Value: TDataSource);
    procedure SetParams(const Value: TParams);
    procedure SetParamsFromCursor;
    procedure SetProviderDataSet(const Value: TDataSet);
    procedure SortData(SortList: TList);
    procedure AncestorNotFound(Reader: TReader; const ComponentName: string; ComponentClass: TPersistentClass; var Component: TComponent);
    procedure CreateComponent(Reader: TReader; ComponentClass: TComponentClass; var Component: TComponent);
    procedure SetAggregatesActive(const Value: Boolean);
    function GetAggregatesActive: Boolean;
  protected
    FInstantReadMode: Boolean;
    FMasterDataLink: TMasterDataLinkEh;

    procedure RecreateFilterExpr;
    procedure DestroyFilterExpr;

{$IFNDEF EH_LIB_5}
    function BCDToCurr(BCD: Pointer; var Curr: Currency): Boolean; override;
    function CurrToBCD(const Curr: Currency; BCD: Pointer; Precision,
      Decimals: Integer): Boolean; override;
{$ENDIF}
    function AllocRecordBuffer: PChar; override;
    function ApplyUpdate(OldRecValues, NewRecValues: PRecValues; UpdateKind: TUpdateKind; TargetDataSet: TDataSet; OutRecValues: PRecValues): Integer;
    function CompareRecords(Item1, Item2: PRecValues): Integer; virtual;
    function CreateDeltaDataSet: TCustomMemTableEh;
    function DoFetchRecords(Count: Integer): Integer;
    function GetActiveRecBuf(var RecBuf: PChar): Boolean; virtual;
    function GetAggregateValue(Field: TField): Variant; override;
    function GetBlobData(Field: TField; Buffer: PChar): TMemBlobData;
    function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;
    function GetBookmarkStr: TBookmarkStr; override;
    function GetCanModify: Boolean; override;
    function GetRecNo: Integer; override;
    function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override;
    function GetRecordCount: Integer; override;
    function GetRecordSize: Word; override;
    function IsCursorOpen: Boolean; override;
    function InternalApplyUpdates(MaxErrors: Integer): Integer; virtual;
//    function LocateProviderRec: Boolean; virtual;
    function UpdateRecord(DeltaDataSet: TDataSet; UpdateKind: TUpdateKind; RefreshRecord: Boolean): Integer; virtual;
    procedure ClearCalcFields(Buffer: PChar); override;
    procedure CloseBlob(Field: TField); override;
    procedure CopyBuffer(FromBuf, ToBuf: PChar);
    procedure CreateFields; override;
    procedure DataEvent(Event: TDataEvent; Info: Longint); override;
    procedure DoOnNewRecord; override;
    procedure DoOrderBy(const OrderByStr: String); virtual;
    procedure FieldValueToVarValue(FieldBuffer: Pointer; var VarValue: Variant; Field: TField);
    procedure FreeRecordBuffer(var Buffer: PChar); override;
    procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
    procedure ReadState(Reader: TReader); override;
    procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
    procedure InitFieldDefsFromFields;
    procedure InitRecord(Buffer: PChar); override;
    procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); override;
    procedure InternalCancel; override;
    procedure InternalClose; override;
    procedure InternalDelete; override;
    procedure InternalFirst; override;
    procedure InternalGotoBookmark(Bookmark: TBookmark); override;
    procedure InternalHandleException; override;
    procedure InternalInitFieldDefs; override;
    procedure InternalInitRecord(Buffer: PChar); override;
    procedure InternalInsert; override;
    procedure InternalLast; override;
    procedure InternalOpen; override;
    procedure InternalPost; override;
    procedure InternalRefresh; override;
    procedure InternalSetToRecord(Buffer: PChar); override;
    procedure MasterChange(Sender: TObject);
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure OpenCursor(InfoQuery: Boolean); override;
    procedure RecordToBuffer(Rec: PRecValues; Buffer: PChar);
    procedure ResetAggField(Field: TField); override;
    procedure SetAutoIncFields(Buffer: PChar); virtual;
    procedure SetBlobData(Field: TField; Buffer: PChar; Value: TMemBlobData);
    procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
    procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
    procedure SetFieldData(Field: TField; Buffer: Pointer); override;
    procedure SetFiltered(Value: Boolean); override;
    procedure SetMemoryRecordData(Buffer: PChar; ARecValues: PRecValues); virtual;
    procedure SetOnFilterRecord(const Value: TFilterRecordEvent); override;
    procedure SetRecNo(Value: Integer); override;
    procedure UpdateDetailMode(AutoRefresh: Boolean);
//    procedure UpdateThroughProvider(MemRec: TMemoryRecordEh; NewBuffer: PChar; UpdateKind: TUpdateKind; RecPos: Integer);
    procedure VarValueToFieldValue(VarValue: Variant; FieldBuffer: Pointer; Field: TField);
    property AggregatesActive: Boolean read GetAggregatesActive write SetAggregatesActive default False;
    property DataFieldsCount: Integer read GetDataFieldsCount;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    function ApplyUpdates(MaxErrors: Integer): Integer; virtual;
    function BookmarkValid(Bookmark: TBookmark): Boolean; override;
    function CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer; override;
    function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override;
    function DefaultFetchRecord(PacketDataSet: TDataSet; var ProviderEOF: Boolean): Integer;
    function DefaultUpdateRecord(DeltaDataSet: TDataSet; UpdateKind: TUpdateKind; RefreshRecord: Boolean): Integer; virtual;
    function FetchRecords(Count: Integer): Integer;
    function FindRec(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions): Integer;
    function GetCurrentRecord(Buffer: PChar): Boolean; override;
    function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
    function InstantReadIndexOfBookmark(Bookmark: TBookmark): Integer;
    function InstantReadRowCount: Integer;
    function IsSequenced: Boolean; override;
    function LoadFromDataSet(Source: TDataSet; RecordCount: Integer; Mode: TLoadMode): Integer;
    function Locate(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions): Boolean; override;
    function Lookup(const KeyFields: string; const KeyValues: Variant; const ResultFields: string): Variant; override;
    function SaveToDataSet(Dest: TDataSet; RecordCount: Integer): Integer;
    function UpdateStatus: TUpdateStatus; override;
    procedure CancelUpdates;
    procedure CreateDataSet;
    procedure CopyStructure(Source: TDataSet);
    procedure EmptyTable;
    procedure InstantReadEnter(RowNum: Integer);
    procedure InstantReadLeave;
    procedure FetchParams;
    procedure MergeChangeLog;
    procedure SortByFields(const SortByStr: string);
    procedure RefreshRecord;
    procedure RevertRecord;
    procedure SetFilterText(const Value: string); override;

    property CachedUpdates: Boolean read GetCachedUpdates write SetCachedUpdates default False;
    property DetailFields: String read FDetailFields write SetDetailFields;
    property InstantReadCurRow: Integer read GetInstantReadCurRow;
    property FetchAllOnOpen: Boolean read FFetchAllOnOpen write FFetchAllOnOpen default False;
    property KeyFields: String read FKeyFields write SetKeyFields;
    property MasterDetailSide: TMasterDetailSideEh read FMasterDetailSide write SetMasterDetailSide default mdsOnSelfEh;
    property MasterFields: String read GetMasterFields write SetMasterFields;
    property MasterSource: TDataSource read GetMasterSource write SetMasterSource;
    property Params: TParams read FParams write SetParams;
    property ProviderDataSet: TDataSet read FProviderDataSet write SetProviderDataSet;
    property ProviderEOF: Boolean read FProviderEOF;
    property ReadOnly: Boolean read FReadOnly write FReadOnly default False;
    property OnUpdateRecord: TMTUpdateRecordEventEh read FOnUpdateRecord write FOnUpdateRecord;
    property OnFetchRecord: TMTFetchRecordEventEh read FOnFetchRecord write FOnFetchRecord;

    property RecordsView: TRecordsViewEh read FRecordsView;
  end;

{ TMemBlobStreamEh }

  TMemBlobStreamEh = class(TStream)
  private
    FBuffer: PChar;
    FCached: Boolean;
    FDataSet: TCustomMemTableEh;
    FField: TBlobField;
    FMode: TBlobStreamMode;
    FModified: Boolean;
    FOpened: Boolean;
    FPosition: Longint;
    function GetBlobFromRecord(Field: TField): TMemBlobData;
    function GetBlobSize: Longint;
  public
    constructor Create(Field: TBlobField; Mode: TBlobStreamMode);
    destructor Destroy; override;
    function Read(var Buffer; Count: Longint): Longint; override;
    function Seek(Offset: Longint; Origin: Word): Longint; override;
    function Write(const Buffer; Count: Longint): Longint; override;
    procedure Truncate;
  end;

{ TMemTableEh }

  TMemTableEh = class(TCustomMemTableEh)
  published
    property Active;
    property AggregatesActive;
    property AutoCalcFields;
    property CachedUpdates;
    property DetailFields;
    property FieldDefs;
    property Filtered;
    property FetchAllOnOpen; //FetchAllOnOpen
    property KeyFields;
    property MasterDetailSide;
    property MasterFields;
    property MasterSource;
    property Params;
    property ProviderDataSet;
    property ReadOnly;
//    property ObjectView default False;

    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 BeforeRefresh;
    property AfterRefresh;
    property OnCalcFields;
    property OnDeleteError;
    property OnEditError;
    property OnFetchRecord;
    property OnFilterRecord;
    property OnNewRecord;
    property OnPostError;
    property OnUpdateRecord;
  end;

implementation

uses Forms, DbConsts, Math;

resourcestring
  SMemNoRecords = 'No data found';

const
  ftBlobTypes = [ftBlob, ftMemo, ftGraphic, ftFmtMemo, ftParadoxOle,
    ftDBaseOle, ftTypedBinary {$IFDEF EH_LIB_5}, ftOraBlob, ftOraClob {$ENDIF}];

  ftSupported = [ftString, ftSmallint, ftInteger, ftWord, ftBoolean, ftFloat,
    ftCurrency, ftDate, ftTime, ftDateTime, ftAutoInc, ftBCD, ftBytes,
    ftVarBytes, ftADT, ftFixedChar, ftWideString,
    ftLargeint {$IFDEF EH_LIB_5}, ftVariant, ftGuid {$ENDIF}] +
    ftBlobTypes;

  fkStoredFields = [fkData];

{$IFDEF EH_LIB_5}
  GuidSize = 38;
{$ENDIF}

type
  PRecInfo = ^TRecInfo;
  TRecInfo = packed record
    Bookmark: TRecIdEh;
    BookmarkFlag: TBookmarkFlag;
    RecordStatus: Integer;
    RecordNumber: Integer;
  end;

  TFieldValBuf = packed record
    IsNull: Boolean;
    DataValue: String;
  end;

  PFieldValBuf = ^TFieldValBuf;

//  TRecBufValues = array [0..0] of Pointer;
//  PRecBufValues = ^TRecBufValues;
  TFBRecBufValues = array of TFieldValBuf;

  TRecBuf = packed record
    RecInfo: TRecInfo;
    Values: TFBRecBufValues;
  end;

  PRecBuf = ^TRecBuf;

{ Utility routines }

function CompareFields(Data1, Data2: Pointer; FieldType: TFieldType;
  CaseInsensitive: Boolean): Integer;
begin
  Result := 0;
  case FieldType of
    ftString:
      if CaseInsensitive then
        Result := AnsiCompareText(PChar(Data1), PChar(Data2))
      else
        Result := AnsiCompareStr(PChar(Data1), PChar(Data2));
    ftSmallint:
      if SmallInt(Data1^) > SmallInt(Data2^) then
        Result := 1
      else if SmallInt(Data1^) < SmallInt(Data2^) then
        Result := -1;
    ftInteger, ftDate, ftTime, ftAutoInc:
      if Longint(Data1^) > Longint(Data2^) then
        Result := 1
      else if Longint(Data1^) < Longint(Data2^) then
        Result := -1;
    ftWord:
      if Word(Data1^) > Word(Data2^) then Result := 1
      else if Word(Data1^) < Word(Data2^) then Result := -1;
    ftBoolean:
      if WordBool(Data1^) and not WordBool(Data2^) then Result := 1
      else if not WordBool(Data1^) and WordBool(Data2^) then Result := -1;
    ftFloat, ftCurrency:
      if Double(Data1^) > Double(Data2^) then Result := 1
      else if Double(Data1^) < Double(Data2^) then Result := -1;
    ftDateTime:
      if TDateTime(Data1^) > TDateTime(Data2^) then Result := 1
      else if TDateTime(Data1^) < TDateTime(Data2^) then Result := -1;
    ftFixedChar:
      if CaseInsensitive then
        Result := AnsiCompareText(PChar(Data1), PChar(Data2))
      else
        Result := AnsiCompareStr(PChar(Data1), PChar(Data2));
    ftWideString:
      if CaseInsensitive then
        Result := AnsiCompareText(WideCharToString(PWideChar(Data1)),
          WideCharToString(PWideChar(Data2)))
      else
        Result := AnsiCompareStr(WideCharToString(PWideChar(Data1)),
          WideCharToString(PWideChar(Data2)));
    ftLargeint:
      if Int64(Data1^) > Int64(Data2^) then Result := 1
      else if Int64(Data1^) < Int64(Data2^) then Result := -1;
{$IFDEF EH_LIB_5}
    ftVariant:
      Result := 0;
    ftGuid:
      Result := AnsiCompareText(PChar(Data1), PChar(Data2));
{$ENDIF}
  end;
end;

function CalcFieldLen(FieldType: TFieldType; Size: Word): Word;
begin
  if not (FieldType in ftSupported) then
    Result := 0
  else if (FieldType in ftBlobTypes) then
    Result := SizeOf(Longint)
  else
  begin
    Result := Size;