delphimvcframework/sources/MVCFramework.ActiveRecord.pas

// *************************************************************************** }
//
// Delphi MVC Framework
//
// Copyright (c) 2010-2018 Daniele Teti and the DMVCFramework Team
//
// https://github.com/danieleteti/delphimvcframework
//
// ***************************************************************************
//
// Licensed under the Apache License, Version 2.0 (the "License");
// you may not use this file except in compliance with the License.
// You may obtain a copy of the License at
//
// http://www.apache.org/licenses/LICENSE-2.0
//
// Unless required by applicable law or agreed to in writing, software
// distributed under the License is distributed on an "AS IS" BASIS,
// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
// See the License for the specific language governing permissions and
// limitations under the License.
//
// ***************************************************************************

unit MVCFramework.ActiveRecord;

interface

uses
  System.Generics.Defaults,
  System.Generics.Collections,
  System.RTTI,
  FireDAC.Comp.Client,
  FireDAC.DApt,
  FireDAC.Stan.Param,
  Data.DB,
  MVCFramework.Commons,
  MVCFramework.RQL.Parser;

type
  EMVCActiveRecord = class(EMVCException)
  public
    constructor Create(const AMsg: string); reintroduce; { do not override!! }
  end;

  TMVCActiveRecordClass = class of TMVCActiveRecord;
  TDelphiARFieldOption = (foAutoGenerated);
  TDelphiARFieldOptions = set of TDelphiARFieldOption;

  DelphiARBaseAttribute = class(TCustomAttribute)

  end;

  TableAttribute = class(DelphiARBaseAttribute)
    Name: string;
    constructor Create(AName: string);
  end;

  TableFieldAttribute = class(DelphiARBaseAttribute)
  public
    FieldName: string;
    constructor Create(aFieldName: string);
  end;

  PrimaryKeyAttribute = class(DelphiARBaseAttribute)
  public
    FieldName: string;
    FieldOptions: TDelphiARFieldOptions;
    constructor Create(const aFieldName: string; const aFieldOptions: TDelphiARFieldOptions); overload;
    constructor Create(const aFieldName: string); overload;
  end;

  TMVCActiveRecord = class
  private
    fConn: TFDConnection;
    fPrimaryKeyFieldName: string;
    fPrimaryKeyOptions: TDelphiARFieldOptions;
    function TableFieldsDelimited(const Delimiter: string = ','): string;
    function MapColumnToTValue(const aFieldName: string; const aField: TField): TValue;
    procedure MapTValueToParam(const aValue: TValue; const aParam: TFDParam);
  protected
    fRTTIType: TRttiType;
    fProps: TArray<TRttiField>;
    fObjAttributes: TArray<TCustomAttribute>;
    fPropsAttributes: TArray<TCustomAttribute>;
    fTableName: string;
    fMap: TDictionary<TRttiField, string>;
    fPrimaryKey: TRttiField;
    function Connection: TFDConnection;
    procedure InitTableInfo;
    function CreateInsertSQL: string; virtual;
    function CreateSelectByPKSQL(aPrimaryKey: int64): string; virtual;
    function CreateSelectSQL: string; virtual;
    function CreateUpdateSQL: string; virtual;
    function CreateDeleteSQL: string; virtual;
    function GetWhereByPrimaryKey: string; virtual;
    class function ExecQuery(const SQL: string; const Values: array of Variant): TDataSet; overload;
    class function ExecQuery(const SQL: string; const Values: array of Variant; const Connection: TFDConnection): TDataSet; overload;
    function ExecNonQuery(const SQL: string; RefreshAutoGenerated: boolean = false): int64; overload;
    // load events
    /// <summary>
    /// Called everywhere before persist object into database
    /// </summary>
    procedure OnValidation; virtual;

    /// <summary>
    /// Called just after load the object state from database
    /// </summary>
    procedure OnAfterLoad; virtual;

    /// <summary>
    /// Called before load the object state from database
    /// </summary>
    procedure OnBeforeLoad; virtual;

    /// <summary>
    /// Called before insert the object state to database
    /// </summary>

    procedure OnBeforeInsert; virtual;
    /// <summary>
    /// Called before update the object state to database
    /// </summary>

    procedure OnBeforeUpdate; virtual;

    /// <summary>
    /// Called before delete object from database
    /// </summary>
    procedure OnBeforeDelete; virtual;

    /// <summary>
    /// Called before insert or update the object to the database
    /// </summary>
    procedure OnBeforeInsertOrUpdate; virtual;

  public
    constructor Create(aLazyLoadConnection: boolean); overload;
    constructor Create; overload; virtual;
    destructor Destroy; override;
    procedure Insert;
    function GetMapping: TMVCFieldsMapping;
    function LoadByPK(ID: int64): boolean;
    procedure Update;
    procedure Delete;
    function TableInfo: string;
    procedure LoadByDataset(const aDataSet: TDataSet);
    procedure SetPK(const aValue: TValue);
    function GetPK: TValue;
    class function GetByPrimaryKey<T: TMVCActiveRecord, constructor>(const aValue: int64): T; overload;
    class function GetByPrimaryKey(const aClass: TMVCActiveRecordClass; const aValue: int64): TMVCActiveRecord; overload;
    class function Select<T: TMVCActiveRecord, constructor>(const SQL: string; const Params: array of Variant): TObjectList<T>; overload;
    class function Select(const aClass: TMVCActiveRecordClass; const SQL: string; const Params: array of Variant)
      : TObjectList<TMVCActiveRecord>; overload;
    class function Select(const aClass: TMVCActiveRecordClass; const SQL: string; const Params: array of Variant;
      const Connection: TFDConnection)
      : TObjectList<TMVCActiveRecord>; overload;
    class function SelectRQL(const aClass: TMVCActiveRecordClass;
      const RQL: string; const Mapping: TMVCFieldsMapping): TObjectList<TMVCActiveRecord>; overload;
    class function Where<T: TMVCActiveRecord, constructor>(const SQLWhere: string; const Params: array of Variant): TObjectList<T>;
      overload;
    class function Where(const aClass: TMVCActiveRecordClass; const SQLWhere: string; const Params: array of Variant)
      : TObjectList<TMVCActiveRecord>; overload;
    class function Where(const aClass: TMVCActiveRecordClass; const SQLWhere: string; const Params: array of Variant;
      const Connection: TFDConnection)
      : TObjectList<TMVCActiveRecord>; overload;
    class function All<T: TMVCActiveRecord, constructor>: TObjectList<T>; overload;
    class function All(const aClass: TMVCActiveRecordClass): TObjectList<TMVCActiveRecord>; overload;
    class function SelectDataSet(const SQL: string; const Params: array of Variant): TDataSet;
  end;

  IMVCEntitiesRegistry = interface
    ['{BB227BEB-A74A-4637-8897-B13BA938C07B}']
    procedure AddEntity(const aURLSegment: string; const aActiveRecordClass: TMVCActiveRecordClass);
    function GetByURLSegment(const aURLSegment: string): TMVCActiveRecordClass;
  end;

  TMVCEntitiesRegistry = class(TInterfacedObject, IMVCEntitiesRegistry)
  private
    fEntitiesDict: TDictionary<string, TMVCActiveRecordClass>;
  public
    constructor Create; virtual;
    destructor Destroy; override;
  protected
    procedure AddEntity(const aURLSegment: string; const aActiveRecordClass: TMVCActiveRecordClass);
    function GetByURLSegment(const aURLSegment: string): TMVCActiveRecordClass;
  end;

  IMVCActiveRecordConnections = interface
    ['{7B87473C-1784-489F-A838-925E7DDD0DE2}']
    procedure AddConnection(const AName: string; const aConnection: TFDConnection);
    procedure RemoveConnection(const AName: string);
    procedure SetCurrent(const AName: string);
    function GetCurrent: TFDConnection;
  end;

  TMVCConnectionsRepository = class(TInterfacedObject, IMVCActiveRecordConnections)
  private
    fConnectionsDict: TDictionary<string, TFDConnection>;
    fCurrent: TFDConnection;
    fCurrentName: string;
  public
    constructor Create; virtual;
    destructor Destroy; override;
    procedure AddConnection(const AName: string; const aConnection: TFDConnection);
    procedure RemoveConnection(const AName: string);
    procedure SetCurrent(const AName: string);
    function GetCurrent: TFDConnection;
    function GetByName(const AName: string): TFDConnection;
  end;

function ActiveRecordConnectionsRegistry: IMVCActiveRecordConnections;

function ActiveRecordMappingRegistry: IMVCEntitiesRegistry;

implementation

uses
  SysUtils,
  TypInfo,
  MVCFramework.DataSet.Utils,
  MVCFramework.Logger,

  FireDAC.Stan.Option,
  System.IOUtils,
  System.Classes;

threadvar gCtx: TRttiContext;
threadvar gCtxInitialized: boolean;
threadvar gConnections: IMVCActiveRecordConnections;

var
  gEntitiesRegistry: IMVCEntitiesRegistry;
  gLock: TObject;

function ActiveRecordConnectionsRegistry: IMVCActiveRecordConnections;
begin
  if not Assigned(gConnections) then
  begin
    gConnections := TMVCConnectionsRepository.Create;
  end;
  Result := gConnections;
end;

{ TConnectionsRepository }

{ TConnectionsRepository }

procedure TMVCConnectionsRepository.AddConnection(const AName: string; const aConnection: TFDConnection);
var
  lName: string;
begin
  lName := AName.ToLower;
  fConnectionsDict.AddOrSetValue(lName, aConnection);
  if (lName = 'default') and ((fCurrentName = 'default') or (fCurrentName.IsEmpty)) then
  begin
    fCurrentName := lName;
    fCurrent := aConnection;
  end;
end;

constructor TMVCConnectionsRepository.Create;
begin
  inherited;
  fConnectionsDict := TDictionary<string, TFDConnection>.Create;
end;

destructor TMVCConnectionsRepository.Destroy;
begin
  fConnectionsDict.Free;
  inherited;
end;

function TMVCConnectionsRepository.GetByName(const AName: string): TFDConnection;
begin
  if not fConnectionsDict.TryGetValue(AName.ToLower, Result) then
    raise Exception.CreateFmt('Unknown connection %s', [AName]);
end;

function TMVCConnectionsRepository.GetCurrent: TFDConnection;
begin
  Assert(Assigned(fCurrent), 'Current connection not set');
  Result := fCurrent;
end;

procedure TMVCConnectionsRepository.RemoveConnection(const AName: string);
var
  lName: string;
  lConn: TFDConnection;
begin
  lName := AName.ToLower;
  if not fConnectionsDict.TryGetValue(lName, lConn) then
    raise Exception.CreateFmt('Unknown connection %s', [AName]);
  fConnectionsDict.Remove(lName);
  try
    FreeAndNil(lConn);
  except
    on E: Exception do
    begin
      LogE('ActiveRecord: ' + E.ClassName + ' > ' + E.Message);
      raise;
    end;
  end;
end;

procedure TMVCConnectionsRepository.SetCurrent(const AName: string);
var
  lName: string;
begin
  lName := AName.ToLower;
  if not fConnectionsDict.TryGetValue(lName, fCurrent) then
    raise Exception.CreateFmt('Unknown connection %s', [AName]);
  fCurrentName := lName;
end;

function ActiveRecordMappingRegistry: IMVCEntitiesRegistry;
begin
  if gEntitiesRegistry = nil then
  begin
    TMonitor.Enter(gLock);
    try
      if gEntitiesRegistry = nil then
      begin
        gEntitiesRegistry := TMVCEntitiesRegistry.Create;
      end;
    finally
      TMonitor.Exit(gLock);
    end;
  end;
  Result := gEntitiesRegistry;
end;

function GetRTTIContext: TRttiContext; inline;
begin
  if not gCtxInitialized then
  begin
    gCtx := TRttiContext.Create;
  end;
  Result := gCtx;
end;

{ TableFieldAttribute }

constructor TableFieldAttribute.Create(aFieldName: string);
begin
  inherited Create;
  FieldName := aFieldName;
end;

{ TableAttribute }

constructor TableAttribute.Create(AName: string);
begin
  inherited Create;
  name := AName;
end;

{ TActiveRecord }

destructor TMVCActiveRecord.Destroy;
begin
  fMap.Free;
  fConn := nil;
  inherited;
end;

function TMVCActiveRecord.ExecNonQuery(const SQL: string; RefreshAutoGenerated: boolean = false): int64;
var
  lQry: TFDQuery;
  lPar: TFDParam;
  lPair: TPair<TRttiField, string>;
  lValue: TValue;
begin
  lQry := TFDQuery.Create(nil);
  try
    lQry.Connection := fConn;
    lQry.SQL.Text := SQL;
    lQry.Prepare;
    for lPair in fMap do
    begin
      lPar := lQry.FindParam(lPair.value);
      if lPar <> nil then
      begin
        lValue := lPair.Key.GetValue(Self);
        MapTValueToParam(lValue, lPar);
      end
      else
      begin
        // check if it's the primary key
        lPar := lQry.FindParam(fPrimaryKeyFieldName);
        if lPar <> nil then
        begin
          MapTValueToParam(fPrimaryKey.GetValue(Self), lPar);
        end
      end;
    end;

    if RefreshAutoGenerated and (foAutoGenerated in fPrimaryKeyOptions) then
    begin
      lQry.Open;
      fPrimaryKey.SetValue(Self, lQry.FieldByName(fPrimaryKeyFieldName).AsInteger);
      OnAfterLoad;
    end
    else
    begin
      lQry.ExecSQL(SQL);
    end;

    Result := lQry.RowsAffected;
  except
    lQry.Free;
    raise;
  end;
end;

class function TMVCActiveRecord.ExecQuery(const SQL: string;
  const Values: array of Variant; const Connection: TFDConnection): TDataSet;
var
  lQry: TFDQuery;
begin
  lQry := TFDQuery.Create(nil);
  try
    lQry.FetchOptions.Unidirectional := True;
    if Connection = nil then
    begin
      lQry.Connection := ActiveRecordConnectionsRegistry.GetCurrent;
    end
    else
    begin
      lQry.Connection := Connection;
    end;
    lQry.SQL.Text := SQL;
    lQry.Prepare;
    lQry.Open(SQL, Values);
    Result := lQry;
  except
    lQry.Free;
    raise;
  end;
end;

class function TMVCActiveRecord.ExecQuery(const SQL: string; const Values: array of Variant): TDataSet;
begin
  Result := ExecQuery(SQL, Values, nil);
end;

function TMVCActiveRecord.GetWhereByPrimaryKey: string;
begin
  Result := ' ' + fPrimaryKeyFieldName + '= :' + fPrimaryKeyFieldName;
end;

procedure TMVCActiveRecord.InitTableInfo;
var
  obj_attr: TCustomAttribute;
  prop: TRttiField;
  prop_attr: TCustomAttribute;
begin
  fTableName := '';
  fRTTIType := GetRTTIContext.GetType(Self.ClassInfo);
  fObjAttributes := fRTTIType.GetAttributes;
  for obj_attr in fObjAttributes do
    if obj_attr is TableAttribute then
    begin
      fTableName := TableAttribute(obj_attr).Name;
      Break;
    end;

  if fTableName = '' then
    raise Exception.Create('Cannot find TableNameAttribute');

  fProps := fRTTIType.GetFields;
  for prop in fProps do
  begin
    fPropsAttributes := prop.GetAttributes;
    if Length(fPropsAttributes) = 0 then
      Continue;
    for prop_attr in fPropsAttributes do
    begin
      if prop_attr is TableFieldAttribute then
      begin
        fMap.Add(prop, { fTableName + '.' + } TableFieldAttribute(prop_attr).FieldName);
      end
      else if prop_attr is PrimaryKeyAttribute then
      begin
        fPrimaryKey := prop;
        fPrimaryKeyFieldName := PrimaryKeyAttribute(prop_attr).FieldName;
        fPrimaryKeyOptions := PrimaryKeyAttribute(prop_attr).FieldOptions;
      end;
    end;
  end;
end;

procedure TMVCActiveRecord.Insert;
var
  SQL: string;
begin
  OnValidation;
  OnBeforeInsert;
  OnBeforeInsertOrUpdate;
  SQL := CreateInsertSQL;
  ExecNonQuery(SQL, True);
end;

constructor TMVCActiveRecord.Create(aLazyLoadConnection: boolean);
begin
  inherited Create;
  fConn := nil;
  if not aLazyLoadConnection then
  begin
    Connection;
  end;
  fMap := TDictionary<TRttiField, string>.Create;
  InitTableInfo;
end;

function TMVCActiveRecord.CreateUpdateSQL: string;
var
  keyvalue: TPair<TRttiField, string>;
begin
  Result := 'UPDATE ' + fTableName + ' SET ';
  for keyvalue in fMap do
  begin
    Result := Result + keyvalue.value + ' = :' + keyvalue.value + ',';
  end;
  Result[Length(Result)] := ' ';
  if Assigned(fPrimaryKey) then
  begin
    Result := Result + ' where ' + GetWhereByPrimaryKey;
  end;
end;

class function TMVCActiveRecord.GetByPrimaryKey(const aClass: TMVCActiveRecordClass; const aValue: int64): TMVCActiveRecord;
begin
  Result := aClass.Create;
  Result.LoadByPK(aValue);
end;

class function TMVCActiveRecord.GetByPrimaryKey<T>(const aValue: int64): T;
var
  lActiveRecord: TMVCActiveRecord;
begin
  Result := T.Create;
  lActiveRecord := TMVCActiveRecord(Result);
  lActiveRecord.LoadByPK(aValue);
end;

function TMVCActiveRecord.GetMapping: TMVCFieldsMapping;
var
  lPair: TPair<TRttiField, string>;
  i: Integer;
begin
  if not fPrimaryKeyFieldName.IsEmpty then
    SetLength(Result, fMap.Count + 1)
  else
    SetLength(Result, fMap.Count);

  i := 0;
  for lPair in fMap do
  begin
    Result[i].InstanceFieldName := lPair.Key.Name.Substring(1).ToLower;
    Result[i].DatabaseFieldName := lPair.value;
    inc(i);
  end;

  if not fPrimaryKeyFieldName.IsEmpty then
  begin
    Result[i].InstanceFieldName := fPrimaryKey.Name.Substring(1).ToLower;
    Result[i].DatabaseFieldName := fPrimaryKeyFieldName;
  end;
end;

function TMVCActiveRecord.GetPK: TValue;
begin
  if fPrimaryKeyFieldName.IsEmpty then
    raise Exception.Create('No primary key defined');
  Result := fPrimaryKey.GetValue(Self);
end;

function TMVCActiveRecord.Connection: TFDConnection;
begin
  if fConn = nil then
  begin
    fConn := ActiveRecordConnectionsRegistry.GetCurrent;
  end;
  Result := fConn;
end;

constructor TMVCActiveRecord.Create;
begin
  Create(false);
end;

function TMVCActiveRecord.CreateDeleteSQL: string;
begin
  Result := 'DELETE FROM ' + fTableName + ' WHERE ' + GetWhereByPrimaryKey;
end;

function TMVCActiveRecord.CreateInsertSQL: string;
var
  keyvalue: TPair<TRttiField, string>;
  lSB: TStringBuilder;
begin
  lSB := TStringBuilder.Create;
  try
    lSB.Append('INSERT INTO ' + fTableName + '(');
    for keyvalue in fMap do
      lSB.Append(keyvalue.value + ',');
    lSB.Remove(lSB.Length - 1, 1);
    lSB.Append(') values (');
    for keyvalue in fMap do
    begin
      lSB.Append(':' + keyvalue.value + ',');
    end;
    lSB.Remove(lSB.Length - 1, 1);
    lSB.Append(')');

    if foAutoGenerated in fPrimaryKeyOptions then
    begin
      lSB.Append(' RETURNING ' + fPrimaryKeyFieldName);
    end;
    Result := lSB.ToString;
  finally
    lSB.Free;
  end;
end;

function TMVCActiveRecord.CreateSelectByPKSQL(aPrimaryKey: int64): string;
begin
  Result := CreateSelectSQL + ' WHERE ' + fPrimaryKeyFieldName + ' = :' + fPrimaryKeyFieldName;
end;

function TMVCActiveRecord.CreateSelectSQL: string;
begin
  Result := 'SELECT ' + TableFieldsDelimited + ' FROM ' + fTableName;
end;

procedure TMVCActiveRecord.Delete;
var
  SQL: string;
begin
  if not Assigned(fPrimaryKey) then
    raise Exception.CreateFmt('Cannot delete %s without a primary key', [ClassName]);
  SQL := CreateDeleteSQL;
  ExecNonQuery(SQL, false);
end;

function TMVCActiveRecord.MapColumnToTValue(const aFieldName: string; const aField: TField): TValue;
var
  lMS: TMemoryStream;
begin
  case aField.DataType of
    ftString, ftWideString:
      begin
        Result := aField.AsString;
      end;
    ftLargeint:
      begin
        Result := aField.AsLargeInt;
      end;
    ftInteger, ftSmallint:
      begin
        Result := aField.AsInteger;
      end;
    ftLongWord, ftWord:
      begin
        Result := aField.AsLongWord;
      end;
    ftDate:
      begin
        Result := Trunc(aField.AsDateTime);
      end;
    ftDateTime:
      begin
        Result := aField.AsDateTime;
      end;
    ftBoolean:
      begin
        Result := aField.AsBoolean;
      end;
    ftMemo, ftWideMemo:
      begin
        Result := aField.AsString;
      end;
    ftBlob:
      begin
        lMS := TMemoryStream.Create;
        try
          TBlobField(aField).SaveToStream(lMS);
          lMS.Position := 0;
          Result := lMS;
        except
          lMS.Free;
          raise;
        end;
      end;
  else
    raise Exception.CreateFmt('Unsupported FieldType (%d) for field %s', [Ord(aField.DataType), aFieldName]);
  end;
end;

procedure TMVCActiveRecord.MapTValueToParam(const aValue: TValue; const aParam: TFDParam);
var
  lStream: TStream;
begin
  case aParam.DataType of
    ftString:
      begin
        aParam.AsString := aValue.AsString;
      end;
    ftWideString:
      begin
        aParam.AsWideString := aValue.AsString;
      end;
    ftLargeint:
      begin
        aParam.AsLargeInt := aValue.AsInt64;
      end;
    ftSmallint:
      begin
        aParam.AsSmallInt := aValue.AsInteger;
      end;
    ftInteger:
      begin
        aParam.AsInteger := aValue.AsInteger;
      end;
    ftLongWord:
      begin
        aParam.AsLongWord := aValue.AsInteger;
      end;
    ftWord:
      begin
        aParam.AsWord := aValue.AsInteger;
      end;
    ftDate:
      begin
        aParam.AsDate := Trunc(aValue.AsExtended);
      end;
    ftDateTime:
      begin
        aParam.AsDateTime := aValue.AsExtended;
      end;
    ftBoolean:
      begin
        aParam.AsBoolean := aValue.AsBoolean;
      end;
    ftMemo:
      begin
        aParam.AsMemo := AnsiString(aValue.AsString);
      end;
    ftWideMemo:
      begin
        aParam.AsWideMemo := aValue.AsString;
      end;
    ftBlob:
      begin
        lStream := aValue.AsType<TStream>(false);
        if Assigned(lStream) then
        begin
          lStream.Position := 0;
          aParam.LoadFromStream(lStream, ftBlob);
        end
        else
        begin
          aParam.Clear;
        end;
      end;
  else
    raise Exception.CreateFmt('Unsupported FieldType (%d) for param %s', [Ord(aValue.Kind), aParam.Name]);
  end;
end;

procedure TMVCActiveRecord.LoadByDataset(const aDataSet: TDataSet);
var
  lItem: TPair<TRttiField, string>;
  lValue: TValue;
  lDestField: TValue;
  lStream: TStream;
begin
  OnBeforeLoad;
  for lItem in fMap do
  begin
    lValue := MapColumnToTValue(lItem.value, aDataSet.FieldByName(lItem.value));
    if not lValue.IsObject then
    begin
      lItem.Key.SetValue(Self, lValue);
    end
    else
    begin
      lDestField := lItem.Key.GetValue(Self);
      if lDestField.IsEmpty then
        raise EMVCActiveRecord.CreateFmt('Target field (%s) is nil', [lItem.value]);
      if lDestField.IsObject and lDestField.IsType<TStream> then
      begin
        lStream := lDestField.AsType<TStream>;
        lStream.Position := 0;
        lStream.CopyFrom(lValue.AsType<TStream>, 0);
        lStream.Position := 0;
      end;
    end;
  end;
  if not fPrimaryKeyFieldName.IsEmpty then
  begin
    lValue := MapColumnToTValue(fPrimaryKeyFieldName, aDataSet.FieldByName(fPrimaryKeyFieldName));
    fPrimaryKey.SetValue(Self, lValue);
  end;
  OnAfterLoad;
end;

function TMVCActiveRecord.LoadByPK(ID: int64): boolean;
var
  SQL: string;
  lDataSet: TDataSet;
begin
  SQL := CreateSelectByPKSQL(ID);
  lDataSet := ExecQuery(SQL, [ID]);
  try
    Result := not lDataSet.Eof;
    if Result then
    begin
      LoadByDataset(lDataSet);
    end;
  finally
    lDataSet.Free;
  end;
end;

procedure TMVCActiveRecord.OnAfterLoad;
begin
  // do nothing
end;

procedure TMVCActiveRecord.OnBeforeDelete;
begin
  // do nothing
end;

procedure TMVCActiveRecord.OnBeforeInsert;
begin
  // do nothing
end;

procedure TMVCActiveRecord.OnBeforeInsertOrUpdate;
begin
  // do nothing
end;

procedure TMVCActiveRecord.OnBeforeLoad;
begin
  // do nothing
end;

procedure TMVCActiveRecord.OnBeforeUpdate;
begin
  // do nothing
end;

procedure TMVCActiveRecord.OnValidation;
begin
  // do nothing
end;

class function TMVCActiveRecord.Select(const aClass: TMVCActiveRecordClass; const SQL: string; const Params: array of Variant)
  : TObjectList<TMVCActiveRecord>;
begin
  Result := Select(aClass, SQL, Params, nil);
end;

class function TMVCActiveRecord.Select(const aClass: TMVCActiveRecordClass;
  const SQL: string; const Params: array of Variant;
  const Connection: TFDConnection): TObjectList<TMVCActiveRecord>;
var
  lDataSet: TDataSet;
  lAR: TMVCActiveRecord;
begin
  Result := TObjectList<TMVCActiveRecord>.Create(True);
  try
    lDataSet := ExecQuery(SQL, Params, Connection);
    try
      while not lDataSet.Eof do
      begin
        lAR := aClass.Create;
        Result.Add(lAR);
        lAR.LoadByDataset(lDataSet);
        lDataSet.Next;
      end;
      // lDataSet.First;
      // TFile.WriteAllText('output.json', lDataSet.AsJSONArray);
    finally
      lDataSet.Free;
    end;
  except
    Result.Free;
    raise;
  end;

end;

class function TMVCActiveRecord.Select<T>(const SQL: string; const Params: array of Variant): TObjectList<T>;
var
  lDataSet: TDataSet;
  lAR: TMVCActiveRecord;
begin
  Result := TObjectList<T>.Create(True);
  try
    lDataSet := ExecQuery(SQL, Params);
    try
      while not lDataSet.Eof do
      begin
        lAR := T.Create;
        Result.Add(lAR);
        lAR.LoadByDataset(lDataSet);
        lDataSet.Next;
      end;
    finally
      lDataSet.Free;
    end;
  except
    Result.Free;
    raise;
  end;
end;

class function TMVCActiveRecord.SelectDataSet(const SQL: string; const Params: array of Variant): TDataSet;
begin
  Result := TMVCActiveRecord.ExecQuery(SQL, Params);
end;

class function TMVCActiveRecord.SelectRQL(const aClass: TMVCActiveRecordClass;
  const RQL: string; const Mapping: TMVCFieldsMapping): TObjectList<TMVCActiveRecord>;
var
  lRQL: TRQL2SQL;
  lSQL: string;
begin
  lRQL := TRQL2SQL.Create;
  try
    { TODO -oDanieleT -cGeneral : Let the backend be inferred by the current connection... }
    lRQL.Execute(RQL, lSQL, Mapping, cbFirebird);
    LogD(Format('RQL [%s] => SQL [%s]', [RQL, lSQL]));
    Result := Where(aClass, lSQL, []);
  finally
    lRQL.Free;
  end;
end;

procedure TMVCActiveRecord.SetPK(const aValue: TValue);
begin
  if fPrimaryKeyFieldName.IsEmpty then
    raise Exception.Create('No primary key defined');
  fPrimaryKey.SetValue(Self, aValue);
end;

function TMVCActiveRecord.TableFieldsDelimited(const Delimiter: string): string;
var
  lPair: TPair<TRttiField, string>;
begin
  for lPair in fMap do
  begin
    Result := Result + lPair.value + Delimiter;
  end;
  Result := Copy(Result, 1, Length(Result) - Length(Delimiter));
  if not fPrimaryKeyFieldName.IsEmpty then
  begin
    Result := fPrimaryKeyFieldName + ',' + Result;
  end;
end;

function TMVCActiveRecord.TableInfo: string;
var
  keyvalue: TPair<TRttiField, string>;
begin
  Result := 'Table Name: ' + fTableName;
  for keyvalue in fMap do
    Result := Result + sLineBreak + #9 + keyvalue.Key.Name + ' = ' + keyvalue.value;
end;

procedure TMVCActiveRecord.Update;
var
  SQL: string;
begin
  OnValidation;
  OnBeforeUpdate;
  OnBeforeInsertOrUpdate;
  SQL := CreateUpdateSQL;
  ExecNonQuery(SQL, false);
end;

class function TMVCActiveRecord.All(const aClass: TMVCActiveRecordClass): TObjectList<TMVCActiveRecord>;
var
  lAR: TMVCActiveRecord;
begin
  lAR := aClass.Create;
  try
    Result := Select(aClass, lAR.CreateSelectSQL, []);
  finally
    lAR.Free;
  end;
end;

class function TMVCActiveRecord.All<T>: TObjectList<T>;
var
  lAR: TMVCActiveRecord;
begin
  lAR := T.Create;
  try
    Result := Select<T>(lAR.CreateSelectSQL, []);
  finally
    lAR.Free;
  end;
end;

class function TMVCActiveRecord.Where(const aClass: TMVCActiveRecordClass; const SQLWhere: string;
  const Params: array of Variant): TObjectList<TMVCActiveRecord>;
begin
  Result := Where(aClass, SQLWhere, Params, nil)
end;

class function TMVCActiveRecord.Where(const aClass: TMVCActiveRecordClass;
  const SQLWhere: string; const Params: array of Variant;
  const Connection: TFDConnection): TObjectList<TMVCActiveRecord>;
var
  lAR: TMVCActiveRecord;
begin
  lAR := aClass.Create;
  try
    Result := Select(aClass, lAR.CreateSelectSQL + SQLWhere, Params, Connection);
  finally
    lAR.Free;
  end;
end;

class function TMVCActiveRecord.Where<T>(const SQLWhere: string; const Params: array of Variant): TObjectList<T>;
var
  lAR: TMVCActiveRecord;
begin
  lAR := T.Create;
  try
    if not SQLWhere.Trim.IsEmpty then
    begin
      Result := Select<T>(lAR.CreateSelectSQL + ' WHERE ' + SQLWhere, Params);
    end
    else
    begin
      Result := Select<T>(lAR.CreateSelectSQL, Params);
    end;
  finally
    lAR.Free;
  end;
end;
{ PrimaryKeyAttribute }

constructor PrimaryKeyAttribute.Create(const aFieldName: string);
begin
  Create(aFieldName, []);
end;

constructor PrimaryKeyAttribute.Create(const aFieldName: string; const aFieldOptions: TDelphiARFieldOptions);
begin
  inherited Create;
  FieldName := aFieldName;
  FieldOptions := aFieldOptions;
end;

{ TMVCEntitiesRegistry }

procedure TMVCEntitiesRegistry.AddEntity(const aURLSegment: string; const aActiveRecordClass: TMVCActiveRecordClass);
begin
  fEntitiesDict.AddOrSetValue(aURLSegment.ToLower, aActiveRecordClass);
end;

constructor TMVCEntitiesRegistry.Create;
begin
  inherited;
  fEntitiesDict := TDictionary<string, TMVCActiveRecordClass>.Create;
end;

destructor TMVCEntitiesRegistry.Destroy;
begin
  fEntitiesDict.Free;
  inherited;
end;

function TMVCEntitiesRegistry.GetByURLSegment(const aURLSegment: string): TMVCActiveRecordClass;
begin
  if not fEntitiesDict.TryGetValue(aURLSegment.ToLower, Result) then
  begin
    raise Exception.CreateFmt('Cannot find URLSegment %s', [aURLSegment]);
  end;
end;

{ EMVCActiveRecord }

constructor EMVCActiveRecord.Create(const AMsg: string);
begin
  inherited Create(http_status.BadRequest, AMsg);
end;

initialization

gLock := TObject.Create;

finalization

gLock.Free;

end.