memtableeh.pas

最新的 DBGRIDEH4.0

    procedure GetBookmarkData(Buffer: TRecordBuffer; var Bookmark: TBookmark); override;
    procedure InitRecord(Buffer: TRecordBuffer); override;
    procedure InternalAddRecord(Buffer: TRecordBuffer; Append: Boolean); override;
    procedure InternalGotoBookmark(const Bookmark: TBookmark); override;
    procedure InternalInitRecord(Buffer: TRecordBuffer); override;
    procedure InternalSetToRecord(Buffer: TRecordBuffer); override;
    procedure RecordToBuffer(MemRec: TMemoryRecordEh; DataValueVersion: TDataValueVersionEh; Buffer: TRecordBuffer; RecIndex: Integer);
    procedure SetBookmarkData(Buffer: TRecordBuffer; const Bookmark: TBookmark); override;
    procedure SetBookmarkFlag(Buffer: TRecordBuffer; Value: TBookmarkFlag); override;
    procedure SetFieldData(Field: TField; Buffer: TValueBuffer); override;
    procedure SetFieldData(Field: TField; Buffer: TValueBuffer; NativeFormat: Boolean); override;
    procedure SetMemoryRecordData(Buffer: TRecordBuffer; Rec: TMemoryRecordEh); virtual;
    procedure VarValueToFieldValue(VarValue: Variant; FieldBuffer: TObject; Field: TField);
{$ELSE}
    procedure DataEvent(Event: TDataEvent; Info: Longint); override;
    procedure DefChanged(Sender: TObject); override;
    procedure FetchRecord(DataSet: TDataSet);
    procedure FreeRecordBuffer(var Buffer: PChar); override;
    procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
    procedure InitRecord(Buffer: PChar); override;
    procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); override;
    procedure InternalGotoBookmark(Bookmark: TBookmark); override;
    procedure InternalInitRecord(Buffer: PChar); override;
    procedure InternalSetToRecord(Buffer: PChar); override;
    procedure RecordToBuffer(MemRec: TMemoryRecordEh; DataValueVersion: TDataValueVersionEh; Buffer: PChar; RecIndex: Integer);
    procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
    procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
    procedure SetFieldData(Field: TField; Buffer: Pointer); override;
    procedure SetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean); override;
    procedure SetMemoryRecordData(Buffer: PChar; Rec: TMemoryRecordEh); virtual;
    procedure VarValueToFieldValue(VarValue: Variant; FieldBuffer: Pointer; Field: TField);
{$ENDIF}
    procedure DoOnNewRecord; override;
    procedure DoOrderBy(const OrderByStr: String); virtual;
    procedure ReadState(Reader: TReader); override;
    procedure SetExtraStructParams;
{$IFNDEF CIL}
    procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
{$ENDIF}
    procedure InitFieldDefsFromFields;
    procedure InternalCancel; override;
    procedure InternalClose; override;
    procedure InternalDelete; override;
    procedure InternalFirst; override;
    procedure InternalHandleException; override;
    procedure InternalInitFieldDefs; override;
    procedure InternalInsert; override;
    procedure InternalLast; override;
    procedure InternalOpen; override;
    procedure InternalPost; override;
    procedure InternalRefresh; override;
    procedure MasterChange(Sender: TObject);
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure OpenCursor(InfoQuery: Boolean); override;
    procedure ResetAggField(Field: TField); override;
    procedure SetBlobData(Field: TField; Buffer: TRecBuf; Value: TMemBlobData);
    procedure SetFiltered(Value: Boolean); override;
    procedure SetOnFilterRecord(const Value: TFilterRecordEvent); override;
    procedure SetRecNo(Value: Integer); override;
    procedure UpdateDetailMode(AutoRefresh: Boolean);
    procedure UpdateIndexDefs; override;
    procedure UpdateSortOrder; virtual;

    function GetPrefilteredList: TObjectList;
    procedure ViewDataEvent(MemRec: TMemoryRecordEh; Index: Integer; Action: TRecordsListNotification);
    procedure MTApplyUpdates(AMemTableData: TMemTableDataEh);
    function TreeViewNodeExpanding(Sender: TBaseTreeNodeEh): Boolean;
    procedure TreeViewNodeExpanded(Sender: TBaseTreeNodeEh);
    property AggregatesActive: Boolean read GetAggregatesActive write SetAggregatesActive default False;
    property DataFieldsCount: Integer read GetDataFieldsCount;
{$IFDEF CIL}
    property InstantBuffer: TRecordBuffer read GetInstantBuffer;
{$ELSE}
    property InstantBuffer: PChar read GetInstantBuffer;
{$ENDIF}
//    property InstantBuffer: PChar read GetInstantBuffer;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    function ApplyUpdates(MaxErrors: Integer): Integer; virtual;

    function BookmarkValid({$IFDEF CIL}const{$ENDIF} Bookmark: TBookmark): Boolean; override;
    function BookmarkToRecNo(Bookmark: TBookmark): Integer;
    function BookmarkStrToRecNo(Bookmark: TBookmarkStr): Integer;
    function RecNoToBookmarkStr(RecNo: Integer): TBookmarkStr;
    function CompareBookmarks({$IFDEF CIL}const{$ENDIF} Bookmark1, Bookmark2: TBookmark): Integer; override;
    function GetCurrentRecord(Buffer: {$IFDEF CIL}TRecordBuffer{$ELSE}PChar{$ENDIF}): Boolean; override;
    function GetFieldData(Field: TField; Buffer: {$IFDEF CIL}TRecordBuffer{$ELSE}Pointer{$ENDIF}): Boolean; override;
    function GetFieldData(Field: TField; Buffer: {$IFDEF CIL}TRecordBuffer{$ELSE}Pointer{$ENDIF}; NativeFormat: Boolean): Boolean; override;
    function GetFieldData(FieldNo: Integer; Buffer: {$IFDEF CIL}TRecordBuffer{$ELSE}Pointer{$ENDIF}): Boolean; overload; override;
    function GetFieldDataAsObject(Field: TField; var Value: TObject): Boolean; virtual;
{$IFDEF CIL}
    procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
{$ENDIF}
    function GotoRec(Rec: TMemoryRecordEh): Boolean;
    function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override;
    function FetchRecords(Count: Integer): Integer;
    function FindRec(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions): Integer;
    function InstantReadIndexOfBookmark(Bookmark: TBookmarkStr): Integer;
    function InstantReadRowCount: Integer;
    function IsSequenced: Boolean; override;
    function LoadFromDataSet(Source: TDataSet; RecordCount: Integer; Mode: TLoadMode; UseCachedUpdates: Boolean): 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;
    function SetTempRecBufForRecord(Rec: TMemoryRecordEh; TreeNode: TMemRecViewEh; RecNum: Integer): TRecBuf;
    function MoveRecord(FromIndex, ToIndex: Longint; TreeLevel: Integer; CheckOnly: Boolean): Boolean;
    function MoveRecords(BookmarkList: TStrings; ToRecNo: Longint; TreeLevel: Integer; CheckOnly: Boolean): Boolean;
    procedure CancelUpdates;
    procedure CopyStructure(Source: TDataSet);
    procedure CreateDataSet;
    procedure DriverStructChanged;
    procedure DestroyTable;
    procedure EmptyTable;
    procedure FetchParams;
    procedure InstantReadEnter(RowNum: Integer); overload;
    procedure InstantReadEnter(RecView: TMemRecViewEh; RowNum: Integer); overload;
    procedure InstantReadEnter(MemRec: TMemoryRecordEh; RowNum: Integer); overload;
    procedure InstantReadLeave;
    procedure MergeChangeLog;
    procedure RefreshRecord;
    procedure Resync(Mode: TResyncMode); override;
    procedure RevertRecord;
    procedure SetFieldDataAsObject(Field: TField; Value: TObject); virtual;
    procedure SetFilterText(const Value: string); override;
    procedure SortByFields(const SortByStr: string);

//    property KeyFields: String read GetKeyFields write SetKeyFields;
    property AutoIncrement: TAutoIncrementEh read GetAutoIncrement write SetAutoIncrement;
    property CachedUpdates: Boolean read GetCachedUpdates write SetCachedUpdates default False;
    property DataDriver: TDataDriverEh read FDataDriver write SetDataDriver;
    property DetailFields: String read FDetailFields write SetDetailFields;
    property ExternalMemData: TCustomMemTableEh read FExternalMemData write SetExternalMemData;
    property FetchAllOnOpen: Boolean read FFetchAllOnOpen write FFetchAllOnOpen default False;
    property FieldDefs stored FStoreDefs;
    property IndexDefs: TIndexDefs read GetIndexDefs write SetIndexDefs stored FStoreDefs;
    property InstantReadCurRow: Integer read GetInstantReadCurRowNum;
    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 ReadOnly: Boolean read FReadOnly write SetReadOnly default False;
    property Rec: TMemoryRecordEh read GetRec;
    property RecordsView: TRecordsViewEh read FRecordsView;
    property SortOrder: String read GetSortOrder write SetSortOrder;
    property StatusFilter: TUpdateStatusSet read GetStatusFilter write SetStatusFilter default [usUnmodified, usModified, usInserted];
    property StoreDefs: Boolean read FStoreDefs write FStoreDefs default False;
    property TreeList: TMemTableTreeListEh read FTreeList write FTreeList;
    property TreeNode: TMemRecViewEh read GetTreeNode;
    property TreeNodeChildCount: Integer read GetTreeNodeChildCount;
    property TreeNodeExpanded: Boolean read GetTreeNodeExpanded write SetTreeNodeExpanded;
    property TreeNodeHasChildren: Boolean read GetTreeNodeHasChildren write SetTreeNodeHasChildren;
    property TreeNodeLevel: Integer read GetTreeNodeLevel;
    property UpdateError: TUpdateErrorEh read GetUpdateError;

//    property OnUpdateRecord: TMTUpdateRecordEventEh read FOnUpdateRecord write FOnUpdateRecord;
//    property OnFetchRecord: TMTFetchRecordEventEh read FOnFetchRecord write FOnFetchRecord;
    property OnTreeNodeExpanding: TMTTreeNodeExpandingEventEh read FOnTreeNodeExpanding write FOnTreeNodeExpanding;
    property OnRecordsViewTreeNodeExpanding: TRecordsViewTreeNodeExpandingEventEh
      read FOnRecordsViewTreeNodeExpanding write FOnRecordsViewTreeNodeExpanding;
    property OnRecordsViewTreeNodeExpanded: TRecordsViewTreeNodeExpandedEventEh
      read FOnRecordsViewTreeNodeExpanded write FOnRecordsViewTreeNodeExpanded;
    property OnRecordsViewCheckMoveNode: TRecordsViewCheckMoveNodeEventEh
      read FOnRecordsViewCheckMoveNode write FOnRecordsViewCheckMoveNode;
    property OnGetFieldValue: TMemTableChangeFieldValueEventEh read FOnGetFieldValue write FOnGetFieldValue;
    property OnSetFieldValue: TMemTableChangeFieldValueEventEh read FOnSetFieldValue write FOnSetFieldValue;
  end;

{ TMemBlobStreamEh }

  TMemBlobStreamEh = class(TMemoryStream)
  private
    FField: TBlobField;
    FDataSet: TCustomMemTableEh;
//    FBuffer: PChar;
    FBuffer: TRecBuf;
    FFieldNo: Integer;
    FModified: Boolean;
    FData: Variant;
    FFieldData: Variant;
  protected
    procedure ReadBlobData;
{$IFDEF CIL}
    function Realloc(var NewCapacity: Longint): TBytes; override;
{$ELSE}
    function Realloc(var NewCapacity: Longint): Pointer; override;
{$ENDIF}
  public
    constructor Create(Field: TBlobField; Mode: TBlobStreamMode);
    destructor Destroy; override;
{$IFDEF CIL}
    function Write(const Buffer: array of Byte; Offset, Count: Longint): Longint; override;
{$ELSE}
    function Write(const Buffer; Count: Longint): Longint; override;
{$ENDIF}
    procedure Truncate;
  end;

{ TMemTableEh }

  TMemTableEh = class(TCustomMemTableEh)
  published
    property Active;
    property AggregatesActive;
    property AutoCalcFields;
    property AutoIncrement;
    property CachedUpdates;
    property DetailFields;
    property ExternalMemData;
    property FieldDefs;
    property Filter;
    property Filtered;
    property FetchAllOnOpen; //FetchAllOnOpen
    property IndexDefs;
//    property KeyFields;
    property MasterDetailSide;
    property MasterFields;
    property MasterSource;
    property Params;
//    property ProviderDataSet;
    property DataDriver;
    property ReadOnly;
    property SortOrder;
    property StoreDefs;
    property TreeList;
//    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 OnGetFieldValue;
    property OnSetFieldValue;
//    property OnUpdateRecord;
  end;

{ TMemTableDataFieldValueListEh }

  TMemTableDataFieldValueListEh = class(TInterfacedObject, IMemTableDataFieldValueListEh)
  private
    FValues: TStringList;
    FDataObsoleted: Boolean;
    FFieldName: String;
    FNotificator: TRecordsListNotificatorEh;
//    function GetMemTableData: TMemTableDataEh;
    function GetValues: TStrings;
    procedure SetFieldName(const Value: String);
//    procedure SetMemTableData(const Value: TMemTableDataEh);

    function GetDataObject: TComponent;
    procedure SetDataObject(const Value: TComponent);
  protected
    procedure MTDataEvent(MemRec: TMemoryRecordEh; Index: Integer; Action: TRecordsListNotification);
    procedure RecordListChanged; virtual;
    procedure RefreshValues;
  public
    constructor Create;
    destructor Destroy; override;
    property FieldName: String read FFieldName write SetFieldName;
//    property RecordsList: TRecordsListEh read GetRecordsList write SetRecordsList;
//    property MemTableData: TMemTableDataEh read GetMemTableData write SetMemTableData;
    property DataObject: TComponent read GetDataObject write SetDataObject;
    property Values: TStrings read GetValues;
  end;

{ TRefObjectField }

  TRefObjectField = class(TField)
  protected
    class procedure CheckTypeSize(Value: Integer); override;
    function GetAsVariant: Variant; override;
    function GetValue: TObject;
    procedure SetValue(const Value: TObject);
    procedure SetVarValue(const Value: Variant); override;
  public
    constructor Create(AOwner: TComponent); override;
    property Value: TObject read GetValue write SetValue;
  end;

{ TMTOrderByList }

  TMTOrderByList = class(TOrderByList)
  end;

  procedure AssignRecord(Source, Destinate: TDataSet);

//var
//  GlobalUseMemRec: Boolean;

implementation

uses Forms, DbConsts, Math,
{$IFDEF EH_LIB_6}
  SqlTimSt, FmtBcd,
{$ENDIF}
  TypInfo;

resourcestring
  SMemNoRecords = 'No data found';

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

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

  fkStoredFields = [fkData, fkInternalCalc];

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

type
  CharArray = array of Char;

procedure Error(const Msg: string);
begin
  DatabaseError(Msg);
end;

procedure ErrorFmt(const Msg: string; const Args: array of const);
begin
  DatabaseErrorFmt(Msg, Args);
end;

//{$DEBUGINFO OFF}
function VarEquals(const V1, V2: Variant): Boolean;
var i: Integer;
begin
  Result := not (VarIsArray(V1) xor VarIsArray(V2));
  if not Result then Exit;
  Result := False;
  try
    if VarIsArray(V1) and VarIsArray(V2) and
      (VarArrayDimCount(V1) = VarArrayDimCount(V2)) and
      (VarArrayLowBound(V1, 1) = VarArrayLowBound(V2, 1)) and
      (VarArrayHighBound(V1, 1) = VarArrayHighBound(V2, 1))
      then
      for i := VarArrayLowBound(V1, 1) to VarArrayHighBound(V1, 1) do
      begin
        Result := V1[i] = V2[i];