unit Aurelius.Bind.Dataset;

{$I Aurelius.inc}

interface

uses
  Generics.Collections, SysUtils, Classes, DB,
  Aurelius.Bind.BaseDataset,
  Aurelius.Criteria.Base,
  Aurelius.Engine.ObjectManager,
  Aurelius.Mapping.Explorer,
  Aurelius.Mapping.Optimization;

type
  TRecordCountMode = Aurelius.Bind.BaseDataset.TRecordCountMode;
  TAureliusEntityField = Aurelius.Bind.BaseDataset.TAureliusEntityField;

  TCriteriaSource = class(TObjectSource)
  strict private
    FSourceCriteria: TCriteria;
    FBaseCriteria: TCriteria;
    FRemainingRows: integer;
    FCurrentFirstRow: integer;
    FPageSize: integer;
    function GetCriteriaCount(Criteria: TCriteria): Integer;
  public
    constructor Create(ACriteria: TCriteria; APageSize: Integer);
    destructor Destroy; override;
  public
    function FetchMore(AList: IObjectList): Boolean; override;
    function Fetching: Boolean; override;
    function ObjectClass: TClass; override;
    function CanRetrieveRecordCount: Boolean; override;
    function RetrieveRecordCount: Integer; override;
  end;

  TCursorSource = class(TObjectSource)
  strict private
    FCursor: ICriteriaCursor;
  public
    constructor Create(ACursor: ICriteriaCursor);
  public
    function FetchMore(AList: IObjectList): Boolean; override;
    function Fetching: Boolean; override;
    function ObjectClass: TClass; override;
  end;

  TFieldInclusion = (Entity, Dataset);
  TFieldInclusions = set of TFieldInclusion;

  TCustomAureliusDataset = class(TBaseAureliusDataset)
  strict private
    const DefaultFieldInclusions = [TFieldInclusion.Entity, TFieldInclusion.Dataset];
  strict private
    FIntExplorer: TMappingExplorer;
    FIntManager: TObjectManager;
    FParentManager: boolean;
    FFieldInclusions: TFieldInclusions;
    FForceWideTypes: Boolean;
    procedure AddFieldDefsFromClass(const APrefix: string; AClass: TClass; ADepth: Integer);
    procedure InitFieldDefsFromClass(AClass: TClass);
    function FindPropInfoByName(Clazz: TClass; APropName: string): TRttiOptimization;
  strict private
    procedure SetManager(const Value: TObjectManager);
    function GetManager: TObjectManager;
    procedure SetParentManager(const Value: boolean);
  protected
    function GetExplorer: TMappingExplorer; virtual;
    procedure InternalObjectRemove(Obj: TObject); override;
    procedure InternalObjectInsert(Obj: TObject); override;
    procedure InternalObjectUpdate(Obj: TObject); override;
    procedure InternalObjectRefresh(Obj: TObject); override;
    function InternalCreateObject(AClass: TClass): TObject; override;
    procedure ClearInternalList; override;
    procedure InitializeFieldDefinitions; override;
    procedure UpdateObjectClassFromParent(Parent: TBaseAureliusDataset; Field: TField); override;
    function GetPropValue(APropName: string; Obj: TObject): ValueType; override;
    procedure SetPropValue(APropName: string; Obj: TObject; Value: ValueType); override;
  protected
    property Explorer: TMappingExplorer read GetExplorer write FIntExplorer;
  public
    constructor Create(AOwner: TComponent); override;
    property Manager: TObjectManager read GetManager write SetManager;
    property ParentManager: boolean read FParentManager write SetParentManager default True;
    property FieldInclusions: TFieldInclusions read FFieldInclusions write FFieldInclusions default DefaultFieldInclusions;
    property ForceWideTypes: Boolean read FForceWideTypes write FForceWideTypes default False;
    property InternalList;
  public
    procedure SetSourceCursor(Cursor: ICriteriaCursor);
    procedure SetSourceCriteria(Criteria: TCriteria); overload;
    procedure SetSourceCriteria(Criteria: TCriteria; PageSize: integer); overload;
  end;

  TAureliusDataset = class(TCustomAureliusDataset)
  published
    property DatasetField;
    property FieldDefs;
    property FieldInclusions;

    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 OnNewRecord;
    property OnPostError;
    property OnFilterRecord;

    property OnCreateObject;
    property OnObjectInsert;
    property OnObjectUpdate;
    property OnObjectRemove;
    property OnObjectRefresh;
    property CreateSelfField;
    property IncludeUnmappedObjects;
    property SubpropsDepth;
    property SyncSubprops;
    property RecordCountMode;
  end;

implementation

uses
  Rtti, Variants, TypInfo,
  Bcl.Rtti.Utils,
  Aurelius.Bind.Exceptions,
  Aurelius.Criteria.Projections,
  Aurelius.Global.Config,
  Aurelius.Mapping.Metadata;

type
  TInternalCriteria = class(TCriteria)
  end;

{ TCustomAureliusDataset }

procedure TCustomAureliusDataset.AddFieldDefsFromClass(const APrefix: string;
  AClass: TClass; ADepth: Integer);
var
  O: TRttiOptimization;
  DataType: TFieldType;
  C: TColumn;
  Len: integer;
  FieldDef: TFieldDef;
  A: TAssociation;
begin
  for O in Explorer.GetClassVisibleMembers(AClass, True) do
  begin
    if O.RealType.IsInstance then
    begin
      // Associations
      A := Explorer.FindAssociationByPropertyName(AClass, O.MemberName);
      if (A = nil) and not IncludeUnmappedObjects then
        Continue;

      if not Explorer.IsObjectList(O.RealType.AsInstance.MetaclassType) then
      begin
        if TFieldInclusion.Entity in FieldInclusions then
        begin
          FieldDef := FieldDefs.AddFieldDef;
          FieldDef.Name := APrefix + O.MemberName;
          FieldDef.DataType := ftVariant;
          FieldDef.Required := (A <> nil) and A.Required and (ADepth = 0);

          if (O.MemberRef is TRttiProperty) and not TRttiProperty(O.MemberRef).IsWritable then
            FieldDef.Attributes := FieldDef.Attributes + [TFieldAttribute.faReadonly];
        end;

        if ADepth < SubpropsDepth then
          AddFieldDefsFromClass(APrefix + O.MemberName + '.', O.RealType.AsInstance.MetaclassType, ADepth + 1);
      end else
      begin
        if TFieldInclusion.Dataset in FieldInclusions then
        begin
          FieldDef := FieldDefs.AddFieldDef;
          FieldDef.Name := APrefix + O.MemberName;
          FieldDef.DataType := ftDataSet;
          FieldDef.Required := false;
          FieldDef.Attributes := FieldDef.Attributes + [TFieldAttribute.faReadonly];
        end;
      end;
    end
    else
    begin
      // Assume one column for each member, for scalar (non-object) types.
      // If this ever changes (multiple columns per scalar property) review this
      C := Explorer.FindColumnByPropertyName(AClass, O.MemberName);
      if C <> nil then
        Len := C.Length
      else
        Len := 0;
      DataType := Explorer.ResolveColumnTypeForDataset(O.RealType, Len, C);

      // Len is used to determine string or memo
      if (Len = 0) and (DataType in [ftString, ftWideString]) then
        Len := TGlobalConfigs.GetInstance.DefaultStringColWidth;

      // Check if we need to force string type to wide string types
      if ForceWideTypes then
        case DataType of
          ftString: DataType := ftWideString;
          ftMemo: DataType := ftWideMemo;
          ftFixedChar: DataType := ftFixedWideChar;
        end;

      // Force guid fields to be size of 38 (required by Guid fields)
      if DataType = ftGuid then
        Len := 38;

      FieldDef := FieldDefs.AddFieldDef;
      FieldDef.Name := APrefix + O.MemberName;
      FieldDef.DataType := DataType;

      // Only set length for field types that need size. This avoids problems, for example, with enumerated types
      // enumerated field type will always be integer here (due to call to RttiTypeToFieldType above. But if the enumerated
      // is mapped in model as a string field, then Len will be not zero here (although datatype is ftInteger).
      // So we must keep Size 0 for integer fields otherwise an error will be raised by the dataset
      if not (FieldDef.DataType in ftFixedSizeTypes) then
        FieldDef.Size := Len;

      if C <> nil then
        FieldDef.Required := TColumnProp.Required in C.Properties
      else
        FieldDef.Required := not (O.IsNullable or (DataType in [ftMemo, ftBlob, ftWideMemo]));
      FieldDef.Required := FieldDef.Required and (ADepth = 0);

      // Make read-only properties to become read-only fields. Except dynamic properties which are always writeable
      if not O.IsDynamic and (O.MemberRef is TRttiProperty) and not TRttiProperty(O.MemberRef).IsWritable then
        FieldDef.Attributes := FieldDef.Attributes + [TFieldAttribute.faReadonly];

      if (C <> nil) and (TColumnProp.NoUpdate in C.Properties) then
        FieldDef.Attributes := FieldDef.Attributes + [TFieldAttribute.faReadonly];
    end;
  end;
end;

procedure TCustomAureliusDataset.ClearInternalList;
begin
  // if the list contain TCriteriaResult objects, then
  // destroy those objects since they are not being managed anywhere

  // Extra check for FInternalList
  if not Assigned(FInternalList) then
    Exit;

  if (FInternalList.Count > 0) and (FInternalList[0] is TCriteriaResult) then
    FInternalList.OwnsObjects := true;
  try
    FInternalList.Clear;
  finally
    FInternalList.OwnsObjects := false;
  end;
end;

constructor TCustomAureliusDataset.Create(AOwner: TComponent);
begin
  inherited;
  FParentManager := True;
  FFieldInclusions := DefaultFieldInclusions;
end;

function TCustomAureliusDataset.FindPropInfoByName(Clazz: TClass;
  APropName: string): TRttiOptimization;
var
  O: TRttiOptimization;
begin
  for O in Explorer.GetClassVisibleMembers(Clazz, False) do
    if SameText(O.MemberName, APropName) then
      Exit(O);
  Result := nil;
end;

function TCustomAureliusDataset.GetExplorer: TMappingExplorer;
begin
  if Manager <> nil then
    Result := Manager.Explorer
  else
  if FIntExplorer <> nil then
    Result := FIntExplorer
  else
    Result := TMappingExplorer.Default;
end;

function TCustomAureliusDataset.GetManager: TObjectManager;
begin
  if ParentManager and (DatasetField <> nil) and (DatasetField.DataSet is TCustomAureliusDataset) then
    Result := TCustomAureliusDataset(DatasetField.Dataset).Manager
  else
    Result := FIntManager;
end;

function TCustomAureliusDataset.GetPropValue(APropName: string;
  Obj: TObject): ValueType;
var
  Value: TValue;
  O: TRttiOptimization;
  Prop, SubProp: string;
  CriteriaResult: TCriteriaResult;
begin
  if Obj = nil then Exit(Null);
  SplitProp(APropName, Prop, SubProp);

  // Special treatment for TCriteriaResult objects
  if Obj is TCriteriaResult then
  begin
    CriteriaResult := TCriteriaResult(Obj);
    if CriteriaResult.HasProp(Prop) and (SubProp = '') then
      Exit(CriteriaResult.Values[Prop])
    else
      Exit(Null);
  end;

  O := FindPropInfoByName(Obj.ClassType, Prop);
  if O = nil then Exit(Null);

  Value := Explorer.GetMemberValueLoaded(Obj, O);
  if O.RealType.IsInstance then
  begin
    if SubProp = '' then
      Result := ObjectToVariant(Value.AsObject)
    else
      Result := GetPropValue(SubProp, Value.AsObject);
  end
  else
  begin
    if SubProp = '' then
    begin
      if O.IsNullable and Value.IsEmpty then
        Result := Null
      else
      if IsEnumeration(Value.TypeInfo) then
        Result := Value.AsOrdinal
      else
        Result := Explorer.ValueToVariant(Value, O)
    end
    else
      if O.IsNullable and Value.IsEmpty then
        Result := Null
      else
      if IsEnumeration(Value.TypeInfo) and SameText(SubProp, EnumNameSufix) then
        Result := GetEnumName(Value.TypeInfo, Value.AsOrdinal)
      else
        Result := Null;
  end;
end;

procedure TCustomAureliusDataset.InitFieldDefsFromClass(AClass: TClass);
begin
  if AClass = nil then
  begin
    FieldDefs.Clear;
    Exit;
  end;

  AddFieldDefsFromClass('', AClass, 0);
end;

procedure TCustomAureliusDataset.InitializeFieldDefinitions;
begin
  InitFieldDefsFromClass(Self.ObjectClass);
end;

function TCustomAureliusDataset.InternalCreateObject(AClass: TClass): TObject;
begin
  Result := Explorer.ObjectFactory.CreateInstance(AClass);
end;

procedure TCustomAureliusDataset.InternalObjectInsert(Obj: TObject);
begin
  if Manager <> nil then
    Manager.Save(Obj);
end;

procedure TCustomAureliusDataset.InternalObjectRefresh(Obj: TObject);
begin
  if Manager <> nil then
    Manager.Refresh(Obj);
end;

procedure TCustomAureliusDataset.InternalObjectRemove(Obj: TObject);
begin
  if Manager <> nil then
    Manager.Remove(Obj);
end;

procedure TCustomAureliusDataset.InternalObjectUpdate(Obj: TObject);
begin
  if Manager <> nil then
  begin
    if Manager.Explorer.HasIdValue(Obj) then
    begin
      Manager.Update(Obj);
      Manager.Flush(Obj);
    end
    else
      Manager.Save(Obj);
  end;
end;

procedure TCustomAureliusDataset.SetManager(const Value: TObjectManager);
begin
  CheckInactive;
  FParentManager := false;
  FIntManager := Value;
end;

procedure TCustomAureliusDataset.SetParentManager(const Value: boolean);
begin
  if FParentManager <> Value then
    FParentManager := Value;
end;

procedure TCustomAureliusDataset.SetPropValue(APropName: string; Obj: TObject;
  Value: ValueType);
var
  MemberValue: TValue;
  O: TRttiOptimization;
  Prop, SubProp: string;
  CriteriaResult: TCriteriaResult;
begin
  if Obj = nil then
    raise ECannotSetProperty.Create(APropName);
  SplitProp(APropName, Prop, SubProp);

  // Special treatment for TCriteriaResult objects
  if Obj is TCriteriaResult then
  begin
    CriteriaResult := TCriteriaResult(Obj);
    if CriteriaResult.HasProp(Prop) and (SubProp = '') then
    begin
      CriteriaResult.Values[Prop] := Value;
      Exit;
    end
    else
      raise ECannotSetProperty.Create(APropName);
  end;

  O := FindPropInfoByName(Obj.ClassType, Prop);
  if O = nil then
    raise ECannotSetProperty.Create(APropName);

  if SubProp = '' then
  begin
    if O.RealType.IsInstance then
      MemberValue := TValue.From<TObject>(VariantToObject(Value))
    else
    begin
      if O.IsNullable and VarIsNull(Value) then
        MemberValue := TValue.Empty
      else
      if IsEnumeration(O.RealType.Handle) then
        MemberValue := TValue.FromOrdinal(O.RealType.Handle, Value)
      else
        MemberValue := Explorer.VariantToValue(Value, O);
    end;
    Explorer.SetMemberValue(Obj, O, MemberValue);
  end else
  begin
    if O.RealType.IsInstance then
    begin
      MemberValue := Explorer.GetMemberValueLoaded(Obj, O);
      SetPropValue(SubProp, MemberValue.AsObject, Value);
    end else
    begin
      if IsEnumeration(O.RealType.Handle) and SameText(SubProp, EnumNameSufix) then
      begin
        if O.IsNullable and VarIsNull(Value) then
          MemberValue := TValue.Empty
        else
          MemberValue := TValue.FromOrdinal(O.RealType.Handle, GetEnumValue(O.RealType.Handle, Value));
        Explorer.SetMemberValue(Obj, O, MemberValue);
      end
      else
        raise ECannotSetProperty.Create(APropName);
    end;
  end;
end;

procedure TCustomAureliusDataset.SetSourceCriteria(Criteria: TCriteria);
begin
  SetSourceCriteria(Criteria, 0);
end;

procedure TCustomAureliusDataset.SetSourceCriteria(Criteria: TCriteria;
  PageSize: integer);
begin
  SetSource(TCriteriaSource.Create(Criteria, PageSize));
end;

procedure TCustomAureliusDataset.SetSourceCursor(Cursor: ICriteriaCursor);
begin
  SetSource(TCursorSource.Create(Cursor));
end;

procedure TCustomAureliusDataset.UpdateObjectClassFromParent(
  Parent: TBaseAureliusDataset; Field: TField);
var
  O: TRttiOptimization;
  ListClass: TClass;
begin
  if Parent.ObjectClass <> nil then
  begin
    O := FindPropInfoByName(Parent.ObjectClass, Field.FieldName);
    if O <> nil then
    begin
      ListClass := O.MemberClass;
      ObjectClass := TRttiUtils.GetInstance.GetSurroundedClass(ListClass);
    end else
      ObjectClass := TObject;
  end;
end;

{ TCursorSource }

constructor TCursorSource.Create(ACursor: ICriteriaCursor);
begin
  FCursor := ACursor;
end;

function TCursorSource.Fetching: Boolean;
begin
  Result := FCursor <> nil;
end;

function TCursorSource.FetchMore(AList: IObjectList): Boolean;
begin
  Result := False;
  if FCursor <> nil then
  begin
    // Fetch using cursor
    Result := FCursor.Next;
    if Result then
      AList.Add(FCursor.Fetch)
    else
      FCursor := nil;
  end
end;

function TCursorSource.ObjectClass: TClass;
begin
  Result := FCursor.ResultClass;
end;

{ TCriteriaSource }

function TCriteriaSource.CanRetrieveRecordCount: Boolean;
begin
  Result := True;
end;

constructor TCriteriaSource.Create(ACriteria: TCriteria; APageSize: Integer);
begin
  FSourceCriteria := ACriteria;
  FRemainingRows := TInternalCriteria(FSourceCriteria).MaxRows;
  if FRemainingRows <= 0 then
    FRemainingRows := MaxInt;
  FCurrentFirstRow := TInternalCriteria(FSourceCriteria).FirstRow;
  FPageSize := APageSize;
  FBaseCriteria := FSourceCriteria.Clone;
end;

destructor TCriteriaSource.Destroy;
begin
  FreeAndNil(FSourceCriteria);
  FreeAndNil(FBaseCriteria);
  inherited;
end;

function TCriteriaSource.Fetching: Boolean;
begin
  Result := FSourceCriteria <> nil;
end;

function TCriteriaSource.FetchMore(AList: IObjectList): Boolean;
var
  LocalCursor: ICriteriaCursor;
  RowsToRead: integer;
  RowsRetrieved: integer;
begin
  Result := False;

  // Fetch using paging
  FSourceCriteria.Skip(FCurrentFirstRow);
  RowsToRead := MaxInt;
  if FPageSize > 0 then // if pagesize not specified, then retrieve all records
  begin
    if FPageSize > FRemainingRows then
      RowsToRead := FRemainingRows
    else
      RowsToRead := FPageSize;
    FSourceCriteria.Take(RowsToRead);
  end;

  RowsRetrieved := 0;
  LocalCursor := TInternalCriteria(FSourceCriteria).OpenAndKeep;
  while LocalCursor.Next do
  begin
    AList.Add(LocalCursor.Fetch);
    Result := True;
    Dec(FRemainingRows);
    Inc(FCurrentFirstRow);
    Inc(RowsRetrieved);
  end;

  // Whenever we don't need more records, destroy the source criteria so we disable fetching records
  if (not Result) or (FPageSize <= 0) or (FRemainingRows = 0) or (RowsRetrieved < RowsToRead) then
  begin
    FreeAndNil(FSourceCriteria);
    FreeAndNil(FBaseCriteria);
  end;
end;

function TCriteriaSource.GetCriteriaCount(Criteria: TCriteria): Integer;
var
  CriteriaCount: TCriteria;
  CountResult: TCriteriaResult;
begin
  CriteriaCount := Criteria.Clone;
  try
    CriteriaCount.AutoDestroy := False;
    CriteriaCount.OrderItems.Clear;
    CriteriaCount.SetProjections(TProjections.Sql<Int64>('Count(*)'));
    CountResult := CriteriaCount.UniqueValue;
    try
      Result := CountResult.Values[0];
    finally
      CountResult.Free;
    end;
  finally
    CriteriaCount.Free;
  end;
end;

function TCriteriaSource.ObjectClass: TClass;
begin
  Result := FSourceCriteria.ResultClass;
end;

function TCriteriaSource.RetrieveRecordCount: Integer;
begin
  Result := GetCriteriaCount(FBaseCriteria);
end;

end.
