memtableeh.pas

ehlib31控件包

{*******************************************************}
{                                                       }
{                     EhLib vX.X                        }
{                                                       }
{            TMemTableEh component (Build 4)            }
{                                                       }
{      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;

type

  TCustomMemTableEh = class;

  TRecDataValues = array of Variant;
  PRecValues = ^TRecDataValues;

  TMemBlobData = string;
  TMemoryRecordEh = class;
  TLoadMode = (lmCopy, lmAppend);
  TCompareRecords = function (Item1, Item2: PRecValues): Integer of object;

  TRecordsListEh = class;

  TRecordsListNotification =
    (rlnRecAddedEh, rlnRecChangedEh, rlnRecDeletedEh, rlnListChangedEh,
     rlnRecMarkedForDelEh);

  TRecordsListNotificatorDataEventEh =
    procedure (MemRec: TMemoryRecordEh; Index: Integer; Action: TRecordsListNotification) of object;

  TRecIdEh = LongWord;

{ TMemoryRecordEh }

  TMemoryRecordEh = class(TPersistent)
  private
    FChangeCount: Integer;
    FChanged: Boolean;
    FData: PRecValues;
    FMemoryData: TCustomMemTableEh;
    FOldData: PRecValues;
    FRecordsList: TRecordsListEh;
    FTmpOldRecValue: PRecValues;
    FUpdateIndex: Integer;
    FUpdateStatus: TUpdateStatus;
    FID: TRecIdEh;
    function GetAttached: Boolean;
    function GetIndex: Integer;
    procedure SetUpdateStatus(const Value: TUpdateStatus);
  protected
    procedure SetIndex(Value: Integer);
  public
    constructor Create(MemoryData: TCustomMemTableEh); reintroduce; overload;
    destructor Destroy; override;
    procedure BeginEdit;
    procedure EndEdit(Changed: Boolean);
    procedure MergeChanges;
    procedure RevertRecord;
    procedure RefreshRecord(RecValues: TRecDataValues);
    property Attached: Boolean read GetAttached;
    property Data: PRecValues read FData;
    property Index: Integer read GetIndex write SetIndex;
    property MemoryData: TCustomMemTableEh read FMemoryData;
    property RecordsList: TRecordsListEh read FRecordsList;
    property ID: TRecIdEh read FID;
    property UpdateStatus: TUpdateStatus read FUpdateStatus write SetUpdateStatus;
  end;

  TMemoryRecordEhClass = class of TMemoryRecordEh;

{ TRecordsListNotificatorEh }

  TRecordsListNotificatorEh = class
  private
    FOnDataEvent: TRecordsListNotificatorDataEventEh;
    FRecordsList: TRecordsListEh;
    procedure SetRecordsList(const Value: TRecordsListEh);
  protected
    procedure DataEvent(MemRec: TMemoryRecordEh; Index: Integer; Action: TRecordsListNotification); virtual;
    procedure RecordAdded(MemRec: TMemoryRecordEh; Index: Integer); virtual;
    procedure RecordChanged(MemRec: TMemoryRecordEh; Index: Integer); virtual;
    procedure RecordDeleted(MemRec: TMemoryRecordEh; Index: Integer); virtual;
    procedure RecordListChanged; virtual;
    property RecordsList: TRecordsListEh read FRecordsList write SetRecordsList;
  public
    constructor Create;
    destructor Destroy; override;
    property OnDataEvent: TRecordsListNotificatorDataEventEh read FOnDataEvent write FOnDataEvent;
  end;

  {TRecordsListEh}

  TRecordsListEh = class(TObjectList)
  private
    FCachedUpdates: Boolean;
    FDeltaList: TList;
    FItemClass: TMemoryRecordEhClass;
    FNewRecId: TRecIdEh;
    FNotificators: TList;
    FRecValCount: Integer;
//    FRecListById: TList;
    function GetRec(Index: Integer): TMemoryRecordEh;
    function GetRecValues(RecNo: Integer): TRecDataValues;
    function GetValue(RecNo, ValNo: Integer): Variant;
    procedure SetCachedUpdates(const Value: Boolean);
    procedure SetRec(Index: Integer; const Value: TMemoryRecordEh);
    procedure SetRecValCount(const Value: Integer);
    procedure SetRecValues(RecNo: Integer; const Value: TRecDataValues);
    procedure SetValue(RecNo, ValNo: Integer; const Value: Variant);
  protected
    function NewRecId: TRecIdEh;
    procedure AddNotificator(RecordsList: TRecordsListNotificatorEh);
    procedure InitRecord(RecValues: PRecValues);
    procedure Notify(MemRec: TMemoryRecordEh; Index: Integer; Action: TRecordsListNotification); reintroduce; virtual;
    procedure PersistDeleteRecord(Index: Integer);
    procedure RemoveNotificator(RecordsList: TRecordsListNotificatorEh);
  public
    constructor Create;
    destructor Destroy; override;

    function AddRecord(Rec: TMemoryRecordEh): Integer;
    function NewRecord: TMemoryRecordEh;
    procedure RevertRecord(Index: Integer);
    procedure CancelUpdates;
    procedure RefreshRecord(Index: Integer; RecValues: TRecDataValues);
    procedure Clear; override;
    procedure DeleteRecord(Index: Integer);
    procedure InsertRecord(Index: Integer; Rec: TMemoryRecordEh);
    procedure QuickSort(L, R: Integer; Compare: TCompareRecords);
    procedure SortData(SortList: TList; Compare: TCompareRecords);
    property CachedUpdates: Boolean read FCachedUpdates write SetCachedUpdates;
    property Rec[Index: Integer]: TMemoryRecordEh read GetRec write SetRec; default;
    property RecValCount: Integer read FRecValCount write SetRecValCount;
    property RecValues[RecNo: Integer]: TRecDataValues read GetRecValues write SetRecValues;
    property Value[RecNo, ValNo: Integer]: Variant read GetValue write SetValue;
  end;

{ TFilteredRecordsListEh }

  TFilteredRecordsListEh = class(TObject)
  private
    FCachedUpdates: Boolean;
    FCachedUpdatesLockCount: Integer;
    FCatchChanged: Boolean;
    FFilteredRecsList: TList;
    FRecordsList: TRecordsListEh;
    FRLNotificator: TRecordsListNotificatorEh;
    function GetCount: Integer;
    function GetOldRecVals(Index: Integer): PRecValues;
    function GetRec(Index: Integer): TMemoryRecordEh;
    function GetRecValCount: Integer;
    function GetRecValues(RecNo: Integer): TRecDataValues;
    function GetValue(RecNo, ValNo: Integer): Variant;
    procedure SetCachedUpdates(const Value: Boolean);
    procedure SetRec(Index: Integer; const Value: TMemoryRecordEh);
    procedure SetRecValCount(const Value: Integer);
    procedure SetRecValues(RecNo: Integer; const Value: TRecDataValues);
    procedure SetValue(RecNo, ValNo: Integer; const Value: Variant);
  protected
    FMemTable: TCustomMemTableEh;
    function CreateDeltaDataSet: TCustomMemTableEh;
    function FetchRecord(Rec: TMemoryRecordEh): Boolean;
    function FilterRecord(MemRec: TMemoryRecordEh; Index: Integer): Boolean; virtual;
    procedure Notify(MemRec: TMemoryRecordEh; Index: Integer; Action: TRecordsListNotification); virtual;
    procedure RefreshFilteredRecsList;
    procedure RLDataEvent(MemRec: TMemoryRecordEh; Index: Integer; Action: TRecordsListNotification);
  public
    constructor Create(MemTable: TCustomMemTableEh);
    destructor Destroy; override;
    function AddRecord(Rec: TMemoryRecordEh): Integer;
    function ApplyUpdate(OldRecValues, NewRecValues: PRecValues; UpdateKind: TUpdateKind; TargetDataSet: TDataSet; OutRecValues: PRecValues): Integer;
    function ApplyUpdates(MaxErrors: Integer; TargetDataSet: TDataSet): Integer; virtual;
    function FindRecId(RecId: TRecIdEh): Integer;
    function NewRecord: TMemoryRecordEh;
    procedure CancelUpdates;
    procedure DeleteRecord(Index: Integer);
    procedure InsertRecord(Index: Integer; Rec: TMemoryRecordEh);
    procedure LockCachedUpdates;
    procedure MergeChangeLog;
    procedure RevertRecord(Index: Integer);
    procedure RefreshRecord(Index: Integer; RecValues: TRecDataValues);
    procedure UnlockCachedUpdates;
    property CachedUpdates: Boolean read FCachedUpdates write SetCachedUpdates;
    property Count: Integer read GetCount;
    property OldRecVals[Index: Integer]: PRecValues read GetOldRecVals;
    property Rec[Index: Integer]: TMemoryRecordEh read GetRec write SetRec; default;
    property RecValCount: Integer read GetRecValCount write SetRecValCount;
    property RecValues[RecNo: Integer]: TRecDataValues read GetRecValues write SetRecValues;
    property Value[RecNo, ValNo: Integer]: Variant read GetValue write SetValue;
  end;

{ 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;
    FRecords: TFilteredRecordsListEh;
    FFilterExpr: TExprParser;
    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);
  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 CompareRecords(Item1, Item2: PRecValues): Integer; virtual;
    function DoFetchRecords(Count: Integer): Integer;
    function GetActiveRecBuf(var RecBuf: PChar): Boolean; virtual;
    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 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 InitFieldDefsFromFields;
    procedure InitRecord(Buffer: PChar); override;
    procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); 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 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 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 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;
  end;

{ TMemBlobStreamEh }

  TMemBlobStreamEh = class(TStream)
  private
    FBuffer: PChar;
    FCached: Boolean;
    FDataSet: TCustomMemTableEh;
    FField: TBlobField;
    FMode: TBlobStreamMode;
    FModified: Boolean;
    FOpened: Boolean;
    FPosition: Longint;