memtabledataeh.pas

增加了条件求和功能

  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;
  public
    constructor Create;
    destructor Destroy; override;
    property RecordsList: TRecordsListEh read FRecordsList write SetRecordsList;
    property OnDataEvent: TRecordsListNotificatorDataEventEh read FOnDataEvent write FOnDataEvent;
  end;

  {TRecordsListEh}

  TRecordsListEh = class(TComponent)
  private
    FCachedUpdates: Boolean;
    FDeltaList: TList;
    FItemClass: TMemoryRecordEhClass;
    FNewRecId: TRecIdEh;
    FNotificators: TList;
//    FRecValCount: Integer;
    FRecList: TList;
    FMemTableData: TMemTableDataEh;
//    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);
    procedure ReadData(Reader: TReader);
    procedure WriteData(Writer: TWriter);
    function IsEmpty: Boolean;
    function GetDataStruct: TMTDataStructEh;
    function GetRecsCount: Integer;
    function GeRecValCount: Integer;
  protected
    function NewRecId: TRecIdEh;
    procedure AddNotificator(RecordsList: TRecordsListNotificatorEh);
    procedure InitRecord(RecValues: PRecValues);
    procedure Notify(MemRec: TMemoryRecordEh; Index: Integer; Action: TRecordsListNotification); reintroduce; virtual;
    procedure RemoveNotificator(RecordsList: TRecordsListNotificatorEh);
    procedure Delete(Index: Integer);
    procedure DefineProperties(Filer: TFiler); override;
  public
    constructor Create(AMemTableData: TMemTableDataEh); reintroduce;
    destructor Destroy; override;

    function AddRecord(Rec: TMemoryRecordEh): Integer;
    function FetchRecord(Rec: TMemoryRecordEh): Integer;
    function NewRecord: TMemoryRecordEh;
    function IndexOf(Item: Pointer): Integer;
    function HasCachedChanges: Boolean;
    procedure MergeChangeLog;
    procedure RevertRecord(Index: Integer);
    procedure CancelUpdates;
    procedure Move(CurIndex, NewIndex: Integer);
    procedure RefreshRecord(Index: Integer; RecValues: TRecDataValues);
    procedure Clear;
    procedure DeleteRecord(Index: Integer);
    procedure InsertRecord(Index: Integer; Rec: TMemoryRecordEh);
    procedure QuickSort(L, R: Integer; Compare: TCompareRecords);
    procedure PersistDeleteRecord(Index: Integer);
    procedure SortData(SortList: TList; Compare: TCompareRecords);
    property MemTableData: TMemTableDataEh read FMemTableData;
    property DataStruct: TMTDataStructEh read GetDataStruct;
    property CachedUpdates: Boolean read FCachedUpdates write SetCachedUpdates;
    property Rec[Index: Integer]: TMemoryRecordEh read GetRec write SetRec; default;
    property RecValCount: Integer read GeRecValCount;// write SetRecValCount;
    property RecValues[RecNo: Integer]: TRecDataValues read GetRecValues write SetRecValues;
    property Value[RecNo, ValNo: Integer]: Variant read GetValue write SetValue;
    property RecsCount: Integer read GetRecsCount;
    property DeltaList: TList read FDeltaList;
  end;

{ TMTAggregateEh }

  TMTAggregatesEh = class;

  TMTAggregateEh = class(TCollectionItem)
  private
    FExpression: string;
    FActive: Boolean;
    FDataSet: TDataSet;
    FValue: Variant;
    FInUse: Boolean;
    FDataType: TFieldType;
    FAggrExpr: TDataSetExprParserEh;
    procedure SetActive(Value: Boolean);
    procedure SetExpression(const Text: string);
  public
    constructor Create(Aggregates: TMTAggregatesEh; ADataSet: TDataSet); reintroduce; overload;
//    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure Recalc;
    procedure Reset;
    function GetDisplayName: string; override;
    function Value: Variant;
    function Aggregates: TMTAggregatesEh;
    property DataSet: TDataSet read FDataSet;
    property DataType: TFieldType read FDataType;
  published
    property Active: Boolean read FActive write SetActive default False;
    property Expression: string read FExpression write SetExpression;
  end;

{ TMTAggregatesEh }

  TMTAggregatesEh = class(TCollection)
  private
    FOwner: TPersistent;
    FActive: Boolean;
    function GetItem(Index: Integer): TMTAggregateEh;
    procedure SetItem(Index: Integer; Value: TMTAggregateEh);
    procedure SetActive(const Value: Boolean);
  protected
    function GetOwner: TPersistent; override;
  public
    constructor Create(Owner: TPersistent);
    function Add: TMTAggregateEh;
    function DataSet: TDataSet;
    procedure Clear;
    procedure Reset;
    procedure Recalc;
    property Items[Index: Integer]: TMTAggregateEh read GetItem write SetItem; default;
    property Active: Boolean read FActive write SetActive;
  end;

{ TRecordsViewEh }
  TRecordsViewFilterEventEh = function (RecValues: PRecValues): Boolean of object;

  TRecordsViewEh = class(TPersistent)
  private
    FCachedUpdates: Boolean;
    FCachedUpdatesLockCount: Integer;
    FCatchChanged: Boolean;
    FFilteredRecsList: TList;
//    FRecordsList: TRecordsListEh;
    FMemTableData: TMemTableDataEh;
    FRLNotificator: TRecordsListNotificatorEh;
    FAggregates: TMTAggregatesEh;
    FOnFilterRecord: TRecordsViewFilterEventEh;
    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
    FDisableFilterCount: Integer;
    FDataSet: TDataSet;
    function FilterRecord(MemRec: TMemoryRecordEh; Index: Integer): Boolean; virtual;
    procedure Notify(MemRec: TMemoryRecordEh; Index: Integer; Action: TRecordsListNotification); virtual;
    procedure RLDataEvent(MemRec: TMemoryRecordEh; Index: Integer; Action: TRecordsListNotification);
  public
    constructor Create(ADataSet: TDataSet);
    destructor Destroy; override;
    function FetchRecord(Rec: TMemoryRecordEh): Boolean;
    function AddRecord(Rec: TMemoryRecordEh): Integer;
    function FindRecId(RecId: TRecIdEh): Integer;
    function NewRecord: TMemoryRecordEh;
    function CalcAggrFieldFunc(FieldName, AggrFuncName: String): Variant;
    procedure CancelUpdates;
    procedure DeleteRecord(Index: Integer);
    procedure InsertRecord(Index: Integer; Rec: TMemoryRecordEh);
    procedure LockCachedUpdates;
    procedure MergeChangeLog;
    procedure RevertRecord(Index: Integer);
    procedure RefreshFilteredRecsList;
    procedure RefreshRecord(Index: Integer; RecValues: TRecDataValues);
    procedure UnlockCachedUpdates;
    procedure InstantDisableFilter;
    procedure InstantEnableFilter;
    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;

    property MemTableData: TMemTableDataEh read FMemTableData;
    property Aggregates: TMTAggregatesEh read FAggregates;
    property CatchChanged: Boolean read FCatchChanged write FCatchChanged;
    property OnFilterRecord: TRecordsViewFilterEventEh read FOnFilterRecord write FOnFilterRecord;
  end;


const
  StringDataFieldsToFields: array[TStringDataFieldTypesEh] of TFieldType =
    (ftString, ftFixedChar, ftWideString);
  NumericDataFieldsToFields: array[TNumericDataFieldTypesEh] of TFieldType =
    (ftSmallint, ftInteger, ftWord, ftFloat, ftCurrency, ftBCD, ftAutoInc,
     ftLargeint
{$IFDEF EH_LIB_6}
     ,ftFMTBcd
{$ENDIF}
     );
  DateTimeDataFieldsToFields: array[TDateTimeDataFieldTypesEh] of TFieldType =
    (ftDate, ftTime, ftDateTime
{$IFDEF EH_LIB_6}
     ,ftTimeStamp
{$ENDIF}
     );

var
  DefaultDataFieldClasses: array[TFieldType] of TMTDataFieldClassEh = (
    nil,                        { ftUnknown }
    TMTStringDataFieldEh,       { ftString }
    TMTNumericDataFieldEh,      { ftSmallint }
    TMTNumericDataFieldEh,      { ftInteger }
    TMTNumericDataFieldEh,      { ftWord }
    TMTBooleanDataFieldEh,      { ftBoolean }
    TMTNumericDataFieldEh,      { ftFloat }
    TMTNumericDataFieldEh,      { ftCurrency }
    TMTNumericDataFieldEh,      { ftBCD }
    TMTDateTimeDataFieldEh,     { ftDate }
    TMTDateTimeDataFieldEh,     { ftTime }
    TMTDateTimeDataFieldEh,     { ftDateTime }
    nil{TBytesField},           { ftBytes }
    nil{TVarBytesField},        { ftVarBytes }
    TMTNumericDataFieldEh,      { ftAutoInc }
    TMTBlobDataFieldEh,         { ftBlob }
    TMTBlobDataFieldEh,         { ftMemo }
    TMTBlobDataFieldEh,         { ftGraphic }
    TMTBlobDataFieldEh,         { ftFmtMemo }
    TMTBlobDataFieldEh,         { ftParadoxOle }
    TMTBlobDataFieldEh,         { ftDBaseOle }
    TMTBlobDataFieldEh,         { ftTypedBinary }
    nil,                        { ftCursor }
    TMTStringDataFieldEh,       { ftFixedChar }
    TMTStringDataFieldEh,       { ftWideString }
    TMTNumericDataFieldEh,      { ftLargeInt }
    nil{TADTField},             { ftADT }
    nil{TArrayField},           { ftArray }
    nil{TReferenceField},       { ftReference }
    nil{TDataSetField},         { ftDataSet }
    TMTBlobDataFieldEh,         { ftOraBlob }
    TMTBlobDataFieldEh,         { ftOraClob }
    nil{TVariantField},         { ftVariant }
    nil{TInterfaceField},       { ftInterface }
    nil{TIDispatchField},       { ftIDispatch }
    TMTStringDataFieldEh        { ftGuid }
{$IFDEF EH_LIB_6}
    ,TMTDateTimeDataFieldEh     { ftTimeStamp }
    ,TMTNumericDataFieldEh      { ftFMTBCD }
{$ENDIF}
    );

function CalcAggregateValue(Aggregate: TMTAggregateEh; DataSet: TDataSet; Records: TRecordsViewEh): Variant;

implementation

uses DBConsts
{$IFDEF EH_LIB_6}
  ,DateUtils
{$ENDIF}
 ;


type
{$IFNDEF EH_LIB_6}
  PWordBool     = ^WordBool;
{$ENDIF}

  TDataSetCrack = class(TDataSet);

function PrepareExpr(Expr: String): String;
var
  i: Integer;
begin
  Result := '';
  for i := 1 to Length(Expr) do
  begin
    if Expr[i] <> ' ' then
      Result := Result + Expr[i];
  end;
  Result := AnsiUpperCase(Result);
end;

function CalcAggregateValue(Aggregate: TMTAggregateEh; DataSet: TDataSet; Records: TRecordsViewEh): Variant;
var
  AggrExpStr: String;
  FuncName: String;
  FieldName: String;
begin
  Result := Null;
  FieldName := '';
  FuncName := '';
  AggrExpStr := PrepareExpr(Aggregate.Expression);

  //Function
  if Copy(AggrExpStr,1,Length('COUNT(')) = 'COUNT(' then
  begin
    FuncName := 'COUNT';
    AggrExpStr := Copy(AggrExpStr, Length('COUNT(')+1, Length(AggrExpStr));
  end else if Copy(AggrExpStr,1,Length('SUM(')) = 'SUM(' then
  begin
    FuncName := 'SUM';
    AggrExpStr := Copy(AggrExpStr, Length('SUM(')+1, Length(AggrExpStr));
  end else if Copy(AggrExpStr,1,Length('MIN(')) = 'MIN(' then
  begin
    FuncName := 'MIN';
    AggrExpStr := Copy(AggrExpStr, Length('MIN(')+1, Length(AggrExpStr));
  end else if Copy(AggrExpStr,1,Length('MAX(')) = 'MAX(' then
  begin
    FuncName := 'MAX';
    AggrExpStr := Copy(AggrExpStr, Length('MAX(')+1, Length(AggrExpStr));
  end else if Copy(AggrExpStr,1,Length('AVG(')) = 'AVG(' then
  begin
    FuncName := 'AVG';
    AggrExpStr := Copy(AggrExpStr, Length('AVG(')+1, Length(AggrExpStr));
  end;

  //Field
  if (Length(AggrExpStr) > 0) and (AggrExpStr[Length(AggrExpStr)] = ')') then
    FieldName := Copy(AggrExpStr, 1, Length(AggrExpStr)-1);

  Result := Records.CalcAggrFieldFunc(FieldName, FuncName);
end;

{ TMemTableDataEh }

function TMemTableDataEh.BeginRestruct: TMTDataStructEh;
begin
  if FRestructMode then
    raise Exception.Create('MemTableData already in RestructMode.');
  FNewDataStruct.Assign(FDataStruct);
  FRestructMode := True;
  Result := FNewDataStruct;
end;

procedure TMemTableDataEh.CancelRestruct;
begin
  FRestructMode := False;
  FNewDataStruct.Clear;
end;

procedure TMemTableDataEh.CheckInactive;
begin

end;

procedure TMemTableDataEh.CommitRestruct;
begin
  FRestructMode := False;
  Restruct;
end;

constructor TMemTableDataEh.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FDataStruct := TMTDataStructEh.Create(Self);
  FDataStruct.Name := 'DataStruct';
  FNewDataStruct := TMTDataStructEh.Create(Self);
  FRecordsList := TRecordsListEh.Create(Self);
  FRecordsList.Name := 'RecordsList';
end;

destructor TMemTableDataEh.Destroy;
begin
  FDataStruct.Free;
  FNewDataStruct.Free;
  FRecordsList.Free;
  inherited Destroy;
end;

procedure TMemTableDataEh.DestroyTable;
begin
  RecordsList.Clear;
  DataStruct.Clear;
//  FRec
end;

procedure TMemTableDataEh.AncestorNotFound(Reader: TReader;
  const ComponentName: string; ComponentClass: TPersistentClass;
  var Component: TComponent);
begin
  if (ComponentName = 'DataStruct') and (Reader.Root <> nil) then
    Component := FDataStruct
  else if (ComponentName = 'RecordsList') and (Reader.Root <> nil) then
    Component := FRecordsList;
end;

procedure TMemTableDataEh.CreateComponent(Reader: TReader;
  ComponentClass: TComponentClass; var Component: TComponent);
begin
  if ComponentClass.InheritsFrom(TMTDataStructEh) then
    Component := FDataStruct
  else if ComponentClass.InheritsFrom(TRecordsListEh) then
    Component := FRecordsList;
end;

procedure TMemTableDataEh.ReadState(Reader: TReader);
var
  OldOnCreateComponent: TCreateComponentEvent;
  OldOnAncestorNotFound: TAncestorNotFoundEvent;
begin
  DestroyTable; //Clear before read

  OldOnCreateComponent := Reader.OnCreateComponent;
  OldOnAncestorNotFound := Reader.OnAncestorNotFound;
  Reader.OnCreateComponent := CreateComponent;
  Reader.OnAncestorNotFound := AncestorNotFound;

  try
    inherited ReadState(Reader);
  finally
    Reader.OnCreateComponent := OldOnCreateComponent;
    Reader.OnAncestorNotFound := OldOnAncestorNotFound;
  end;
end;

procedure TMemTableDataEh.GetChildren(Proc: TGetChildProc; Root: TComponent);
begin
  Proc(DataStruct);
  Proc(RecordsList);
end;

procedure TMemTableDataEh.Restruct;

  function FieldId(AFieldId: Longint): TMTDataFieldEh;
  var