// *************************************************************************** } // // Delphi MVC Framework // // Copyright (c) 2010-2022 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; {$I dmvcframework.inc} interface uses System.Generics.Defaults, System.Generics.Collections, System.RTTI, FireDAC.DApt, Data.DB, FireDAC.Comp.Client, FireDAC.Stan.Def, FireDAC.Stan.Pool, FireDAC.Stan.Async, FireDAC.Stan.Param, System.SysUtils, MVCFramework, MVCFramework.Commons, MVCFramework.RQL.Parser, MVCFramework.Cache, MVCFramework.Serializer.Intf, MVCFramework.Serializer.Commons, System.SyncObjs; type EMVCActiveRecord = class(EMVCException) public constructor Create(const AMsg: string); reintroduce; { do not override!! } end; EMVCActiveRecordNotFound = class(EMVCActiveRecord) public procedure AfterConstruction; override; end; TMVCActiveRecordClass = class of TMVCActiveRecord; TMVCActiveRecord = class; TMVCActiveRecordFieldOption = (foPrimaryKey, { it's the primary key of the mapped table } foAutoGenerated, { not written, read - similar to readonly } foTransient, { not written, not read } foReadOnly, { not written, read } foWriteOnly); { written, not read } TMVCActiveRecordFieldOptions = set of TMVCActiveRecordFieldOption; TMVCEntityAction = (eaCreate, eaRetrieve, eaUpdate, eaDelete); TMVCEntityActions = set of TMVCEntityAction; TMVCActiveRecordLoadOption = (loIgnoreNotExistentFields); TMVCActiveRecordLoadOptions = set of TMVCActiveRecordLoadOption; TPartitionFieldNames = class(TList) end; TPartitionFieldValues = class(TList) end; TPartitionFieldTypes = class(TList) end; IMVCEntityProcessor = interface ['{E7CD11E6-9FF9-46D2-B7B0-DA5B38EAA14E}'] procedure GetEntities(const Context: TWebContext; const Renderer: TMVCRenderer; const entityname: string; var Handled: Boolean); procedure GetEntity(const Context: TWebContext; const Renderer: TMVCRenderer; const entityname: string; const id: Integer; var Handled: Boolean); procedure CreateEntity(const Context: TWebContext; const Renderer: TMVCRenderer; const entityname: string; var Handled: Boolean); procedure UpdateEntity(const Context: TWebContext; const Renderer: TMVCRenderer; const entityname: string; const id: Integer; var Handled: Boolean); procedure DeleteEntity(const Context: TWebContext; const Renderer: TMVCRenderer; const entityname: string; const id: Integer; var Handled: Boolean); end; TFieldInfo = class public // TableName: string; FieldName: string; FieldOptions: TMVCActiveRecordFieldOptions; DataTypeName: string; Writeable, Readable: Boolean; procedure EndUpdates; end; TFieldsMap = class(TObjectDictionary) private fWritableFieldsCount: Integer; fReadableFieldsCount: Integer; public constructor Create; procedure EndUpdates; property WritableFieldsCount: Integer read fWritableFieldsCount; property ReadableFieldsCount: Integer read fReadableFieldsCount; function GetInfoByFieldName(const FieldName: string): TFieldInfo; end; MVCActiveRecordCustomAttribute = class(TCustomAttribute) end; MVCTableAttribute = class(MVCActiveRecordCustomAttribute) public Name: string; RQLFilter: string; constructor Create(aName: string); overload; constructor Create(aName: string; aRQLFilter: String); overload; end; MVCPartitionAttribute = class(MVCActiveRecordCustomAttribute) public PartitionClause: String; constructor Create(const PartitionClause: String); end; MVCTableFieldAttribute = class(MVCActiveRecordCustomAttribute) public FieldName: string; FieldOptions: TMVCActiveRecordFieldOptions; SequenceName, DataTypeName: string; constructor Create(const aFieldName: string; const aFieldOptions: TMVCActiveRecordFieldOptions; const aSequenceName: string = ''; const aDataTypeName: string = ''); overload; constructor Create(aFieldName: string; const aDataTypeName: string = ''); overload; end; MVCPrimaryKeyAttribute = MVCTableFieldAttribute deprecated '(ERROR) Use MVCTableFieldAttribute'; MVCEntityActionsAttribute = class(MVCActiveRecordCustomAttribute) private EntityAllowedActions: TMVCEntityActions; public constructor Create(const aEntityAllowedActions: TMVCEntityActions); end; TMVCSQLGenerator = class; TPartitionInfo = class private class var PartitionInfoCache: TMVCThreadedObjectCache; private fRQLFilter: String; fSQLFilter: String; fFieldValues: TPartitionFieldValues; fFieldTypes: TPartitionFieldTypes; fFieldNames: TPartitionFieldNames; public property FieldNames: TPartitionFieldNames read fFieldNames; property FieldValues: TPartitionFieldValues read fFieldValues; property FieldTypes: TPartitionFieldTypes read fFieldTypes; property RQLFilter: String read fRQLFilter; property SQLFilter: String read fSQLFilter; constructor Create; destructor Destroy; override; class constructor Create; class destructor Destroy; procedure InitializeFilterStrings(const RQLCompiler: TRQLCompiler); class function BuildPartitionClause(const PartitionClause: String; const RQLCompilerClass: TRQLCompilerClass): TPartitionInfo; end; TMVCActiveRecordList = class(TObjectList) public constructor Create; virtual; end; TMVCActiveRecord = class private fChildren: TObjectList; fConn: TFDConnection; fSQLGenerator: TMVCSQLGenerator; fPrimaryKeyFieldName: string; fPrimaryKeyOptions: TMVCActiveRecordFieldOptions; fPrimaryKeySequenceName: string; fPrimaryKeyFieldType: TFieldType; fEntityAllowedActions: TMVCEntityActions; fRQL2SQL: TRQL2SQL; procedure MapTValueToParam(aValue: TValue; const aParam: TFDParam); function MapNullableTValueToParam(aValue: TValue; const aParam: TFDParam): Boolean; function GetPrimaryKeyIsAutogenerated: Boolean; procedure SetPrimaryKeyIsAutogenerated(const Value: Boolean); procedure SetTableName(const Value: string); function GetAttributes(const AttrName: string): TValue; procedure SetAttributes(const AttrName: string; const Value: TValue); protected fRTTIType: TRttiInstanceType; fProps: TArray; fObjAttributes: TArray; fPropsAttributes: TArray; fTableName: string; fDefaultRQLFilter: string; fMap: TFieldsMap; fPrimaryKey: TRTTIField; fBackendDriver: string; fMapping: TMVCFieldsMapping; fPartitionInfoInternal: TPartitionInfo; fPartitionClause: String; function GetPartitionInfo: TPartitionInfo; function GetBackEnd: string; function GetConnection: TFDConnection; procedure InitTableInfo; class function ExecQuery( const SQL: string; const Values: array of Variant; const Unidirectional: Boolean): TDataSet; overload; class function ExecQuery( const SQL: string; const Values: array of Variant; const Connection: TFDConnection; const Unidirectional: Boolean) : TDataSet; overload; class function ExecQuery(const SQL: string; const Values: array of Variant; const ValueTypes: array of TFieldType; const Unidirectional: Boolean) : TDataSet; overload; class function ExecQuery( const SQL: string; const Values: array of Variant; const ValueTypes: array of TFieldType; const Connection: TFDConnection; const Unidirectional: Boolean): TDataSet; overload; procedure FillPrimaryKey(const SequenceName: string); function ExecNonQuery(const SQL: string; RefreshAutoGenerated: Boolean = false): int64; overload; class function GetByPK(aActiveRecord: TMVCActiveRecord; const aValue: string; const aFieldType: TFieldType; const RaiseExceptionIfNotFound: Boolean): TMVCActiveRecord; overload; class function GetByPK(const aValue: string; const aFieldType: TFieldType; const RaiseExceptionIfNotFound: Boolean): T; overload; // load events /// /// Called everywhere before persist object into database /// procedure OnValidation(const EntityAction: TMVCEntityAction); virtual; /// /// Called just after load the object state from database /// procedure OnAfterLoad; virtual; /// /// Called before load the object state from database /// procedure OnBeforeLoad; virtual; /// /// Called before insert the object state to database /// procedure OnBeforeInsert; virtual; /// /// Called after insert the object state to database /// procedure OnAfterInsert; virtual; /// /// Called before update the object state to database /// procedure OnBeforeUpdate; virtual; /// /// Called after update the object state to database /// procedure OnAfterUpdate; virtual; /// /// Called before delete object from database /// procedure OnBeforeDelete; virtual; /// /// Called after delete object from database /// procedure OnAfterDelete; virtual; /// /// Called before insert or update the object to the database /// procedure OnBeforeInsertOrUpdate; virtual; /// /// Called before execute sql /// procedure OnBeforeExecuteSQL(var SQL: string); virtual; /// /// Called after insert or update the object to the database /// procedure OnAfterInsertOrUpdate; virtual; procedure MapObjectToParams(const Params: TFDParams; var Handled: Boolean); virtual; procedure MapDatasetToObject(const DataSet: TDataSet; const Options: TMVCActiveRecordLoadOptions; var Handled: Boolean); virtual; function GenerateSelectSQL: string; function SQLGenerator: TMVCSQLGenerator; function InternalCount(const RQL: string): int64; function InternalSelectRQL(const RQL: string; const MaxRecordCount: Integer) : TMVCActiveRecordList; public constructor Create(aLazyLoadConnection: Boolean); overload; { cannot be virtual! } constructor Create; overload; virtual; destructor Destroy; override; procedure EnsureConnection; procedure InvalidateConnection(const ReacquireAfterInvalidate: Boolean = false); /// /// Executes an Insert (pk is null) or an Update (pk is not null) /// procedure Store; function CheckAction(const aEntityAction: TMVCEntityAction; const aRaiseException: Boolean = True): Boolean; procedure Insert; function GetMapping: TMVCFieldsMapping; function LoadByPK(const id: int64): Boolean; overload; virtual; function LoadByPK(const id: string): Boolean; overload; virtual; function LoadByPK(const id: TGuid): Boolean; overload; virtual; function LoadByPK(const id: string; const aFieldType: TFieldType): Boolean; overload; virtual; procedure Update(const RaiseExceptionIfNotFound: Boolean = True); procedure Delete(const RaiseExceptionIfNotFound: Boolean = True); function TableInfo: string; procedure LoadByDataset(const aDataSet: TDataSet; const aOptions: TMVCActiveRecordLoadOptions = []); procedure SetPK(const aValue: TValue); procedure SetPropertyValue(const aProp: TRttiProperty; const aValue: TValue); function GetPK: TValue; function TryGetPKValue(var Value: TValue; out IsNullableType: Boolean): Boolean; function PKIsNullable(out PKValue: TValue): Boolean; function PKIsNull: Boolean; procedure AddChildren(const ChildObject: TObject); procedure RemoveChildren(const ChildObject: TObject); function GetPrimaryKeyFieldType: TFieldType; // dynamic access property Attributes[const AttrName: string]: TValue read GetAttributes write SetAttributes; [MVCDoNotSerialize] property TableName: string read fTableName write SetTableName; [MVCDoNotSerialize] property PrimaryKeyIsAutogenerated: Boolean read GetPrimaryKeyIsAutogenerated write SetPrimaryKeyIsAutogenerated; class function GetByPK(const aClass: TMVCActiveRecordClass; const aValue: int64; const RaiseExceptionIfNotFound: Boolean = True): TMVCActiveRecord; overload; class function GetByPK(const aClass: TMVCActiveRecordClass; const aValue: string; const RaiseExceptionIfNotFound: Boolean = True): TMVCActiveRecord; overload; class function GetByPK(const aClass: TMVCActiveRecordClass; const aValue: TGuid; const RaiseExceptionIfNotFound: Boolean = True): TMVCActiveRecord; overload; class function GetScalar(const SQL: string; const Params: array of Variant): Variant; class function Select(const aClass: TMVCActiveRecordClass; const SQL: string; const Params: array of Variant) : TMVCActiveRecordList; overload; class function Select(const aClass: TMVCActiveRecordClass; const SQL: string; const Params: array of Variant; const Connection: TFDConnection): TMVCActiveRecordList; overload; class function SelectRQL(const aClass: TMVCActiveRecordClass; const RQL: string; const MaxRecordCount: Integer) : TMVCActiveRecordList; overload; class function DeleteRQL(const aClass: TMVCActiveRecordClass; const RQL: string): int64; function SelectRQL(const RQL: string; const MaxRecordCount: Integer) : TMVCActiveRecordList; overload; class function Where(const aClass: TMVCActiveRecordClass; const SQLWhere: string; const Params: array of Variant) : TMVCActiveRecordList; overload; class function Where(const aClass: TMVCActiveRecordClass; const SQLWhere: string; const Params: array of Variant; const Connection: TFDConnection): TMVCActiveRecordList; overload; class function All(const aClass: TMVCActiveRecordClass): TObjectList; overload; class function DeleteAll(const aClass: TMVCActiveRecordClass): int64; overload; function Count(const RQL: string = ''): int64; overload; class function Count(const aClass: TMVCActiveRecordClass; const RQL: string = '') : int64; overload; class function SelectDataSet(const SQL: string; const Params: array of Variant; const Unidirectional: Boolean = False): TDataSet; overload; class function SelectDataSet(const SQL: string; const Params: array of Variant; const ParamTypes: array of TFieldType; const Unidirectional: Boolean = False): TDataSet; overload; class function CurrentConnection: TFDConnection; end; IMVCUnitOfWork = interface ['{68B55DD3-57F6-4CC0-A4DE-BFDE7C3AA287}'] procedure RegisterDelete(const Value: T); overload; procedure RegisterDelete(const Enumerable: TEnumerable); overload; procedure RegisterUpdate(const Value: T); procedure RegisterInsert(const Value: T); procedure UnregisterDelete(const Value: T); procedure UnregisterUpdate(const Value: T); procedure UnregisterInsert(const Value: T); end; TMVCItemApplyAction = reference to procedure(const Obj: T; const EntityAction: TMVCEntityAction; var Handled: Boolean); IMVCMultiExecutor = interface ['{C815246B-19CA-4F6C-AA67-8E491F809340}'] procedure Apply(const ItemApplyAction: TMVCItemApplyAction = nil); end; TMVCActiveRecordHelper = class helper for TMVCActiveRecord class function GetByPK(const aValue: int64; const RaiseExceptionIfNotFound: Boolean = True): T; overload; class function GetByPK(const aValue: string; const RaiseExceptionIfNotFound: Boolean = True): T; overload; class function GetByPK(const aValue: TGuid; const RaiseExceptionIfNotFound: Boolean = True): T; overload; class function Select(const SQL: string; const Params: array of Variant; const Options: TMVCActiveRecordLoadOptions = []): TObjectList; overload; class function Select(const SQL: string; const Params: array of Variant; const ParamTypes: array of TFieldType; const Options: TMVCActiveRecordLoadOptions = []) : TObjectList; overload; class function SelectOne(const SQL: string; const Params: array of Variant; const ParamTypes: array of TFieldType; const Options: TMVCActiveRecordLoadOptions = []; const RaiseExceptionIfNotFound: Boolean = True): T; overload; class function SelectOne(const SQL: string; const Params: array of Variant; const RaiseExceptionIfNotFound: Boolean = True): T; overload; class function SelectRQL(const RQL: string; const MaxRecordCount: Integer) : TObjectList; overload; class function SelectOneByRQL(const RQL: string; const RaiseExceptionIfNotFound: Boolean = True): T; overload; class function All: TObjectList; overload; class function Count(const RQL: string = ''): int64; overload; class function Where(const SQLWhere: string; const Params: array of Variant) : TObjectList; overload; /// /// Executes a SQL select using the SQLWhere parameter as where clause. This method is partitioning safe. /// Returns TObjectList. /// class function Where(const SQLWhere: string; const Params: array of Variant; const ParamTypes: array of TFieldType): TObjectList; overload; class function GetOneByWhere(const SQLWhere: string; const Params: array of Variant; const RaiseExceptionIfNotFound: Boolean = True): T; overload; class function GetOneByWhere(const SQLWhere: string; const Params: array of Variant; const ParamTypes: array of TFieldType; const RaiseExceptionIfNotFound: Boolean = True): T; overload; class function GetFirstByWhere(const SQLWhere: string; const Params: array of Variant; const RaiseExceptionIfNotFound: Boolean = True): T; overload; class function GetFirstByWhere(const SQLWhere: string; const Params: array of Variant; const ParamTypes: array of TFieldType; const RaiseExceptionIfNotFound: Boolean = True): T; overload; class function Merge(CurrentList, NewList: TObjectList): IMVCMultiExecutor; end; IMVCEntitiesRegistry = interface ['{BB227BEB-A74A-4637-8897-B13BA938C07B}'] procedure AddEntity(const aURLSegment: string; const aActiveRecordClass: TMVCActiveRecordClass); procedure AddEntityProcessor(const aURLSegment: string; const aEntityProcessor: IMVCEntityProcessor); function FindEntityClassByURLSegment(const aURLSegment: string; out aMVCActiveRecordClass: TMVCActiveRecordClass): Boolean; function FindProcessorByURLSegment(const aURLSegment: string; out aMVCEntityProcessor: IMVCEntityProcessor) : Boolean; function GetEntities: TArray; end; TMVCEntitiesRegistry = class(TInterfacedObject, IMVCEntitiesRegistry) private fEntitiesDict: TDictionary; fProcessorsDict: TDictionary; public constructor Create; virtual; destructor Destroy; override; protected procedure AddEntityProcessor(const aURLSegment: string; const aEntityProcessor: IMVCEntityProcessor); procedure AddEntity(const aURLSegment: string; const aActiveRecordClass: TMVCActiveRecordClass); function FindEntityClassByURLSegment(const aURLSegment: string; out aMVCActiveRecordClass: TMVCActiveRecordClass): Boolean; function FindProcessorByURLSegment(const aURLSegment: string; out aMVCEntityProcessor: IMVCEntityProcessor) : Boolean; function GetEntities: TArray; end; IMVCActiveRecordConnections = interface ['{7B87473C-1784-489F-A838-925E7DDD0DE2}'] procedure AddConnection(const aName: string; const aConnection: TFDConnection; const Owns: Boolean = false); procedure AddDefaultConnection(const aConnection: TFDConnection; const Owns: Boolean = false); overload; procedure AddDefaultConnection(const aConnectionDefName: String); overload; procedure RemoveConnection(const aName: string; const RaiseExceptionIfNotAvailable: Boolean = True); procedure RemoveDefaultConnection(const RaiseExceptionIfNotAvailable: Boolean = True); procedure SetCurrent(const aName: string); function GetCurrent(const RaiseExceptionIfNotAvailable: Boolean = True): TFDConnection; function GetCurrentBackend: string; procedure SetDefault; end; TMVCConnectionsRepository = class(TInterfacedObject, IMVCActiveRecordConnections) private type TConnHolder = class public Connection: TFDConnection; OwnsConnection: Boolean; destructor Destroy; override; end; var fMREW: TMultiReadExclusiveWriteSynchronizer; fConnectionsDict: TDictionary; fCurrentConnectionsByThread: TDictionary; function GetKeyName(const aName: string): string; public constructor Create; virtual; destructor Destroy; override; procedure AddConnection(const aName: string; const aConnection: TFDConnection; const aOwns: Boolean = false); procedure AddDefaultConnection(const aConnection: TFDConnection; const aOwns: Boolean = false); overload; procedure AddDefaultConnection(const aConnectionDefName: String); overload; procedure RemoveConnection(const aName: string; const RaiseExceptionIfNotAvailable: Boolean = True); procedure RemoveDefaultConnection(const RaiseExceptionIfNotAvailable: Boolean = True); procedure SetCurrent(const aName: string); function GetCurrent(const RaiseExceptionIfNotAvailable: Boolean = True): TFDConnection; function GetByName(const aName: string): TFDConnection; function GetCurrentBackend: string; procedure SetDefault; end; TMVCSQLGenerator = class abstract private fMapping: TMVCFieldsMapping; fDefaultSQLFilter: String; fDefaultRQLFilter: String; fCompiler: TRQLCompiler; fRQL2SQL: TRQL2SQL; protected fPartitionInfo: TPartitionInfo; function GetDefaultSQLFilter(const IncludeWhereClause: Boolean; const IncludeAndClauseBeforeFilter: Boolean = False): String; //inline; function MergeDefaultRQLFilter(const RQL: String): String; //inline; function MergeSQLFilter(const SQL1, SQL2: String): String; function GetRQLParser: TRQL2SQL; function GetCompiler: TRQLCompiler; function GetCompilerClass: TRQLCompilerClass; virtual; abstract; function GetMapping: TMVCFieldsMapping; function TableFieldsDelimited(const Map: TFieldsMap; const PKFieldName: string; const Delimiter: string): string; public constructor Create(Mapping: TMVCFieldsMapping; const DefaultRQLFilter: string; const PartitionInfo: TPartitionInfo); virtual; destructor Destroy; override; // capabilities function HasSequences: Boolean; virtual; function HasReturning: Boolean; virtual; // end-capabilities // abstract SQL generator methods function CreateSQLWhereByRQL(const RQL: string; const Mapping: TMVCFieldsMapping; const UseArtificialLimit: Boolean = True; const UseFilterOnly: Boolean = false; const MaxRecordCount: Int32 = TMVCConstants.MAX_RECORD_COUNT): string; function CreateSelectSQL(const TableName: string; const Map: TFieldsMap; const PKFieldName: string; const PKOptions: TMVCActiveRecordFieldOptions): string; virtual; function CreateInsertSQL(const TableName: string; const Map: TFieldsMap; const PKFieldName: string; const PKOptions: TMVCActiveRecordFieldOptions): string; virtual; abstract; // virtual methods with default implementation function CreateSelectByPKSQL(const TableName: string; const Map: TFieldsMap; const PKFieldName: string; const PKOptions: TMVCActiveRecordFieldOptions): string; virtual; function CreateDeleteSQL(const TableName: string; const Map: TFieldsMap; const PKFieldName: string; const PKOptions: TMVCActiveRecordFieldOptions): string; virtual; function CreateDeleteAllSQL(const TableName: string): string; virtual; function CreateSelectCount(const TableName: string): string; virtual; function CreateUpdateSQL(const TableName: string; const Map: TFieldsMap; const PKFieldName: string; const PKOptions: TMVCActiveRecordFieldOptions): string; virtual; function GetSequenceValueSQL(const PKFieldName: string; const SequenceName: string; const Step: Integer = 1): string; virtual; // Overwritten by descendant if the SQL syntaxt requires more than the simple table name // or if the table name contains spaces. function GetTableNameForSQL(const TableName: string): string; virtual; // Overwritten by descendant if the SQL syntaxt requires more than the simple field name // or if the field name contains spaces. function GetFieldNameForSQL(const FieldName: string): string; virtual; function GetParamNameForSQL(const FieldName: string): string; virtual; //helper methods class function RemoveInitialWhereKeyword(const SQLFilter: String): String; end; TMVCSQLGeneratorClass = class of TMVCSQLGenerator; TMVCSQLGeneratorRegistry = class sealed private class var cInstance: TMVCSQLGeneratorRegistry; class var cLock: TObject; fSQLGenerators: TDictionary; protected constructor Create; public destructor Destroy; override; class function Instance: TMVCSQLGeneratorRegistry; class destructor Destroy; class constructor Create; procedure RegisterSQLGenerator(const aBackend: string; const aRQLBackendClass: TMVCSQLGeneratorClass); procedure UnRegisterSQLGenerator(const aBackend: string); function GetSQLGenerator(const aBackend: string): TMVCSQLGeneratorClass; end; TMVCUnitOfWork = class(TInterfacedObject, IMVCUnitOfWork, IMVCMultiExecutor) private fListToDelete: TObjectList; fListToUpdate: TObjectList; fListToInsert: TObjectList; protected // multiexecutor procedure Apply(const ItemApplyAction: TMVCItemApplyAction = nil); // unitofwork procedure RegisterDelete(const Value: T); overload; procedure RegisterDelete(const Enumerable: TEnumerable); overload; procedure RegisterUpdate(const Value: T); procedure RegisterInsert(const Value: T); procedure UnregisterDelete(const Value: T); procedure UnregisterUpdate(const Value: T); procedure UnregisterInsert(const Value: T); // events procedure DoItemApplyAction(const Obj: TMVCActiveRecord; const EntityAction: TMVCEntityAction; const ItemApplyAction: TMVCItemApplyAction; var Handled: Boolean); class function KeyExistsInt(const NewList: TObjectList; const KeyValue: Integer; out Index: Integer): Boolean; class function KeyExistsInt64(const NewList: TObjectList; const KeyValue: int64; out Index: Integer): Boolean; class function KeyExistsString(const NewList: TObjectList; const KeyValue: String; out Index: Integer): Boolean; public constructor Create; virtual; destructor Destroy; override; end; function ActiveRecordConnectionsRegistry: IMVCActiveRecordConnections; function ActiveRecordMappingRegistry: IMVCEntitiesRegistry; function GetBackEndByConnection(aConnection: TFDConnection): string; implementation uses System.TypInfo, System.IOUtils, System.Classes, MVCFramework.DataSet.Utils, MVCFramework.Logger, MVCFramework.Nullables, MVCFramework.RTTI.Utils, FireDAC.Stan.Option, Data.FmtBcd, System.Variants; var gCtx: TRttiContext; gEntitiesRegistry: IMVCEntitiesRegistry; gConnections: IMVCActiveRecordConnections; gLock: TObject; function GetBackEndByConnection(aConnection: TFDConnection): string; begin case Ord(aConnection.RDBMSKind) of 0: Exit('unknown'); 1: Exit('oracle'); 2: Exit('mssql'); 3: Exit('msaccess'); 4: Exit('mysql'); 5: Exit('db2'); 6: Exit('sqlanywhere'); 7: Exit('advantage'); 8: Exit('interbase'); 9: Exit('firebird'); 10: Exit('sqlite'); 11: Exit('postgresql'); 12: Exit('nexusdb'); 13: Exit('dataSnap'); 14: Exit('informix'); 15: Exit('teradata'); 16: Exit('mongodb'); 17: Exit('other'); else raise EMVCActiveRecord.Create('Unknown RDBMS Kind'); end; end; function ActiveRecordConnectionsRegistry: IMVCActiveRecordConnections; begin if gConnections = nil then // double check here begin TMonitor.Enter(gLock); try if gConnections = nil then begin gConnections := TMVCConnectionsRepository.Create; end; finally TMonitor.Exit(gLock); end; end; Result := gConnections; end; function IntToNullableInt(const Value: Integer): NullableInt32; begin Result.SetValue(Value); end; { TConnectionsRepository } procedure TMVCConnectionsRepository.AddConnection(const aName: string; const aConnection: TFDConnection; const aOwns: Boolean = false); var lName: string; lConnKeyName: string; lConnHolder: TConnHolder; begin lName := aName.ToLower; lConnKeyName := GetKeyName(lName); { If the transaction is not started, initialize TxIsolation as ReadCommitted } if aConnection.Transaction = nil then begin { needed for Delphi 10.4 Sydney+ } aConnection.TxOptions.Isolation := TFDTxIsolation.xiReadCommitted; end; fMREW.BeginWrite; try lConnHolder := TConnHolder.Create; lConnHolder.Connection := aConnection; lConnHolder.OwnsConnection := aOwns; fConnectionsDict.Add(lConnKeyName, lConnHolder); // raise exception on duplicates if (lName = 'default') and (not fCurrentConnectionsByThread.ContainsKey(TThread.CurrentThread.ThreadID)) then begin fCurrentConnectionsByThread.AddOrSetValue(TThread.CurrentThread.ThreadID, lName); end; finally fMREW.EndWrite; end; end; procedure TMVCConnectionsRepository.AddDefaultConnection(const aConnection: TFDConnection; const aOwns: Boolean); begin AddConnection('default', aConnection, aOwns); end; procedure TMVCConnectionsRepository.AddDefaultConnection( const aConnectionDefName: String); var lConn: TFDConnection; begin lConn := TFDConnection.Create(nil); try lConn.ConnectionDefName := aConnectionDefName; AddDefaultConnection(lConn, True); except on E: Exception do begin lConn.Free; raise; end; end; end; constructor TMVCConnectionsRepository.Create; begin inherited; fMREW := TMultiReadExclusiveWriteSynchronizer.Create; fConnectionsDict := TDictionary.Create; fCurrentConnectionsByThread := TDictionary.Create; end; destructor TMVCConnectionsRepository.Destroy; begin fConnectionsDict.Free; fCurrentConnectionsByThread.Free; fMREW.Free; inherited; end; function TMVCConnectionsRepository.GetByName(const aName: string): TFDConnection; var lKeyName: string; lConnHolder: TConnHolder; begin {$IF not Defined(TokyoOrBetter)} Result := nil; {$ENDIF} lKeyName := GetKeyName(aName.ToLower); fMREW.BeginRead; try if not fConnectionsDict.TryGetValue(lKeyName, lConnHolder) then raise Exception.CreateFmt('Unknown connection %s', [aName]); Result := lConnHolder.Connection; finally fMREW.EndRead; end; end; function TMVCConnectionsRepository.GetCurrent(const RaiseExceptionIfNotAvailable: Boolean) : TFDConnection; var lName: string; begin {$IF not Defined(TokyoOrBetter)} Result := nil; {$ENDIF} fMREW.BeginRead; try if fCurrentConnectionsByThread.TryGetValue(TThread.CurrentThread.ThreadID, lName) then begin Result := GetByName(lName); end else begin if RaiseExceptionIfNotAvailable then raise EMVCActiveRecord.Create('No current connection for thread') else Result := nil; end; finally fMREW.EndRead; end; end; function TMVCConnectionsRepository.GetCurrentBackend: string; begin Result := GetBackEndByConnection(GetCurrent); end; function TMVCConnectionsRepository.GetKeyName(const aName: string): string; begin Result := Format('%10.10d::%s', [TThread.CurrentThread.ThreadID, aName]); end; procedure TMVCConnectionsRepository.RemoveConnection(const aName: string; const RaiseExceptionIfNotAvailable: Boolean = True); var lName: string; lKeyName: string; lConnHolder: TConnHolder; begin lName := aName.ToLower; lKeyName := GetKeyName(lName); fMREW.BeginWrite; try if not fConnectionsDict.TryGetValue(lKeyName, lConnHolder) then begin if RaiseExceptionIfNotAvailable then begin raise Exception.CreateFmt('Unknown connection %s', [aName]) end else begin Exit; end; end; fConnectionsDict.Remove(lKeyName); try FreeAndNil(lConnHolder); except on E: Exception do begin LogE('ActiveRecord: ' + E.ClassName + ' > ' + E.Message); raise; end; end; finally fMREW.EndWrite; end; end; procedure TMVCConnectionsRepository.RemoveDefaultConnection(const RaiseExceptionIfNotAvailable: Boolean = True); begin RemoveConnection('default', RaiseExceptionIfNotAvailable); end; procedure TMVCConnectionsRepository.SetCurrent(const aName: string); var lName: string; lKeyName: string; begin lName := aName.ToLower; lKeyName := GetKeyName(lName); fMREW.BeginWrite; try if not fConnectionsDict.ContainsKey(lKeyName) then raise Exception.CreateFmt('Unknown connection %s', [aName]); fCurrentConnectionsByThread.AddOrSetValue(TThread.CurrentThread.ThreadID, lName); finally fMREW.EndWrite; end; end; procedure TMVCConnectionsRepository.SetDefault; begin SetCurrent('default'); 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; { TableFieldAttribute } constructor MVCTableFieldAttribute.Create(aFieldName: string; const aDataTypeName: string = ''); begin Create(aFieldName, [], '', aDataTypeName); end; { TableAttribute } constructor MVCTableAttribute.Create(aName: string); begin Create(aName, ''); end; { TActiveRecord } destructor TMVCActiveRecord.Destroy; begin fChildren.Free; fMap.Free; fSQLGenerator.Free; fRQL2SQL.Free; fConn := nil; // do not free it!! inherited; end; procedure TMVCActiveRecord.EnsureConnection; begin GetConnection; end; function TMVCActiveRecord.ExecNonQuery(const SQL: string; RefreshAutoGenerated: Boolean = false): int64; var lQry: TFDQuery; lPar: TFDParam; lPair: TPair; lValue: TValue; lSQL: string; lHandled: Boolean; I: Integer; begin {TODO -oDanieleT -cGeneral : Why not a TFDCommand?} lQry := TFDQuery.Create(nil); try lQry.Connection := GetConnection; lSQL := SQL; OnBeforeExecuteSQL(lSQL); lQry.SQL.Text := lSQL; lHandled := false; // lQry.Prepare; MapObjectToParams(lQry.Params, lHandled); if not lHandled then begin {partitioning} for I := 0 to GetPartitionInfo.FieldNames.Count - 1 do begin lPar := lQry.FindParam(SQLGenerator.GetParamNameForSQL(GetPartitionInfo.FieldNames[I])); if lPar <> nil then begin if GetPartitionInfo.FieldTypes[I] = ftInteger then lValue := StrToInt(GetPartitionInfo.FieldValues[I]) else lValue := GetPartitionInfo.FieldValues[I]; //lPar.DataTypeName := fPartitionInfo.FieldValues[I]; MapTValueToParam(lValue, lPar); end end; {end-partitioning} for lPair in fMap do begin lPar := lQry.FindParam(SQLGenerator.GetParamNameForSQL(lPair.Value.FieldName)); if lPar <> nil then begin lValue := lPair.Key.GetValue(Self); lPar.DataTypeName := fMap.GetInfoByFieldName(lPair.Value.FieldName).DataTypeName; MapTValueToParam(lValue, lPar); end end; // check if it's the primary key lPar := lQry.FindParam(SQLGenerator.GetParamNameForSQL(fPrimaryKeyFieldName)); if lPar <> nil then begin if lPar.DataType = ftUnknown then begin { TODO -oDanieleT -cGeneral : Let's find a smarter way to do this if the engine cannot recognize parameter's datatype } lPar.DataType := GetPrimaryKeyFieldType; end; MapTValueToParam(fPrimaryKey.GetValue(Self), lPar); end; end; if RefreshAutoGenerated and (TMVCActiveRecordFieldOption.foAutoGenerated in fPrimaryKeyOptions) and fPrimaryKeySequenceName.IsEmpty then begin lValue := fPrimaryKey.GetValue(Self); lQry.Open; if (lValue.Kind = tkRecord) then begin MapDataSetFieldToNullableRTTIField(lValue, lQry.Fields[0], fPrimaryKey, Self); end else begin lValue := lQry.FieldByName(fPrimaryKeyFieldName).AsInteger; fPrimaryKey.SetValue(Self, lValue); end; end else begin lQry.ExecSQL(lSQL); end; Result := lQry.RowsAffected; finally lQry.Free; end; end; class function TMVCActiveRecord.ExecQuery(const SQL: string; const Values: array of Variant; const Connection: TFDConnection; const Unidirectional: Boolean): TDataSet; begin Result := ExecQuery(SQL, Values, [], Connection, Unidirectional); end; procedure TMVCActiveRecord.FillPrimaryKey(const SequenceName: string); var lDS: TDataSet; lSQL: string; begin if not SequenceName.IsEmpty then begin lSQL := SQLGenerator.GetSequenceValueSQL(fPrimaryKeyFieldName, SequenceName); if lSQL.IsEmpty then begin Exit; end; lDS := ExecQuery(lSQL, [], True); try MapDataSetFieldToRTTIField(lDS.Fields[0], fPrimaryKey, Self); finally lDS.Free; end; end; end; class function TMVCActiveRecord.ExecQuery(const SQL: string; const Values: array of Variant; const Unidirectional: Boolean) : TDataSet; begin Result := ExecQuery(SQL, Values, nil, Unidirectional); end; procedure TMVCActiveRecord.InitTableInfo; var lAttribute: TCustomAttribute; lRTTIField: TRTTIField; lFieldInfo: TFieldInfo; lPrimaryFieldTypeAsStr: string; begin fPartitionInfoInternal := nil; fEntityAllowedActions := [TMVCEntityAction.eaCreate, TMVCEntityAction.eaRetrieve, TMVCEntityAction.eaUpdate, TMVCEntityAction.eaDelete]; fTableName := ''; fPartitionClause := ''; fRTTIType := gCtx.GetType(Self.ClassInfo) as TRttiInstanceType; fObjAttributes := fRTTIType.GetAttributes; for lAttribute in fObjAttributes do begin if lAttribute is MVCTableAttribute then begin fTableName := MVCTableAttribute(lAttribute).Name; fDefaultRQLFilter := MVCTableAttribute(lAttribute).RQLFilter; Continue; end; if lAttribute is MVCEntityActionsAttribute then begin fEntityAllowedActions := MVCEntityActionsAttribute(lAttribute).EntityAllowedActions; end; if lAttribute is MVCPartitionAttribute then begin fPartitionClause := MVCPartitionAttribute(lAttribute).PartitionClause; Continue; end; end; if fTableName = '' then begin if [eaCreate, eaUpdate, eaDelete] * fEntityAllowedActions <> [] then begin raise Exception.Create('Cannot find TableNameAttribute'); end; end; fProps := fRTTIType.GetFields; for lRTTIField in fProps do begin fPropsAttributes := lRTTIField.GetAttributes; if Length(fPropsAttributes) = 0 then continue; for lAttribute in fPropsAttributes do begin if lAttribute is MVCTableFieldAttribute then begin if foPrimaryKey in MVCTableFieldAttribute(lAttribute).FieldOptions then begin fPrimaryKey := lRTTIField; lPrimaryFieldTypeAsStr := fPrimaryKey.FieldType.ToString.ToLower; if lPrimaryFieldTypeAsStr.EndsWith('int64') then begin fPrimaryKeyFieldType := ftLargeInt; end else if lPrimaryFieldTypeAsStr.EndsWith('integer') or lPrimaryFieldTypeAsStr.EndsWith('int32') then begin fPrimaryKeyFieldType := ftInteger; end else if lPrimaryFieldTypeAsStr.EndsWith('string') then begin fPrimaryKeyFieldType := ftString; end else if lPrimaryFieldTypeAsStr.EndsWith('guid') then begin fPrimaryKeyFieldType := ftGuid; end else begin raise EMVCActiveRecord.Create ('Allowed primary key types are: (Nullable)Integer, (Nullable)Int64, (Nullable)String, GUID - found: ' + lPrimaryFieldTypeAsStr); end; fPrimaryKeyFieldName := MVCTableFieldAttribute(lAttribute).FieldName; fPrimaryKeyOptions := MVCTableFieldAttribute(lAttribute).FieldOptions; fPrimaryKeySequenceName := MVCTableFieldAttribute(lAttribute).SequenceName; continue; end; lFieldInfo := TFieldInfo.Create; // lFieldInfo.TableName := fTableName; lFieldInfo.FieldName := MVCTableFieldAttribute(lAttribute).FieldName; lFieldInfo.FieldOptions := MVCTableFieldAttribute(lAttribute).FieldOptions; lFieldInfo.DataTypeName := MVCTableFieldAttribute(lAttribute).DataTypeName; fMap.Add(lRTTIField, lFieldInfo); // if not(foTransient in MVCTableFieldAttribute(lAttribute).FieldOptions) then // begin // lFieldInfo.FieldName := MVCTableFieldAttribute(lAttribute).FieldName; // fMapNonTransientFields.Add(lRTTIField, lFieldInfo); // end; // // if not MVCTableFieldAttribute(lAttribute).DataTypeName.IsEmpty then // begin // fMapFieldDataTypes.Add(MVCTableFieldAttribute(lAttribute).FieldName.ToUpper, // MVCTableFieldAttribute(lAttribute).DataTypeName); // end; end; end; end; fMap.EndUpdates; Assert(fMap.WritableFieldsCount + fMap.ReadableFieldsCount > 0, 'No fields defined [HINT] Use MVCTableField in private fields'); fPartitionInfoInternal := nil; end; procedure TMVCActiveRecord.Insert; var SQL: string; begin CheckAction(TMVCEntityAction.eaCreate); OnValidation(TMVCEntityAction.eaCreate); OnBeforeInsert; OnBeforeInsertOrUpdate; if fMap.WritableFieldsCount = 0 then begin raise EMVCActiveRecord.CreateFmt ('Cannot insert an entity if all fields are not writable or transient. Class [%s] mapped on table [%s]', [ClassName, fTableName]); end; if (foAutoGenerated in fPrimaryKeyOptions) then begin if not SQLGenerator.HasReturning then begin if not SQLGenerator.HasSequences then begin raise EMVCActiveRecord.Create ('Cannot use AutoGenerated primary keys if the engine doesn''t support returning clause nor sequences'); end else begin if fPrimaryKeySequenceName.IsEmpty then begin raise EMVCActiveRecord.Create('SequenceName is empty for entity ' + ClassName + ' but ' + GetBackEnd + ' requires it'); end; if foReadOnly in fPrimaryKeyOptions then begin raise EMVCActiveRecord.Create('Cannot define a read-only primary key when a sequence is used for the class ' + ClassName); end; FillPrimaryKey(fPrimaryKeySequenceName); end; end; end; SQL := SQLGenerator.CreateInsertSQL(fTableName, fMap, fPrimaryKeyFieldName, fPrimaryKeyOptions); ExecNonQuery(SQL, True); OnAfterInsert; OnAfterInsertOrUpdate; end; function TMVCActiveRecord.InternalCount(const RQL: string): int64; var lSQL: string; begin lSQL := Self.SQLGenerator.CreateSelectCount(fTableName); lSQL := lSQL + fSQLGenerator.CreateSQLWhereByRQL(RQL, GetMapping, false, True); Result := GetScalar(lSQL, []); end; function TMVCActiveRecord.InternalSelectRQL(const RQL: string; const MaxRecordCount: Integer) : TMVCActiveRecordList; var lSQL: string; begin lSQL := SQLGenerator.CreateSQLWhereByRQL(RQL, GetMapping, True, false, MaxRecordCount); LogD(Format('RQL [%s] => SQL [%s]', [RQL, lSQL])); Result := Where(TMVCActiveRecordClass(Self.ClassType), lSQL, []); end; constructor TMVCActiveRecord.Create(aLazyLoadConnection: Boolean); begin inherited Create; fConn := nil; SetLength(fMapping, 0); { TODO -oDanieleT -cGeneral : Consider lazyconnection } if not aLazyLoadConnection then begin GetConnection; end; fMap := TFieldsMap.Create; // fMapNonTransientFields := TFieldsMap.Create; // fMapFieldDataTypes := TDictionary.Create; InitTableInfo; end; function TMVCActiveRecord.GenerateSelectSQL: string; begin Result := SQLGenerator.CreateSelectSQL(fTableName, fMap, fPrimaryKeyFieldName, fPrimaryKeyOptions); end; function TMVCActiveRecord.GetAttributes(const AttrName: string): TValue; var lProperty: TRttiProperty; begin if not TRttiUtils.ExistsProperty(Self, AttrName, lProperty) then begin raise EMVCActiveRecord.CreateFmt('Attribute [%s] not found', [AttrName]); end; Result := lProperty.GetValue(Self); end; function TMVCActiveRecord.GetBackEnd: string; begin if fBackendDriver.IsEmpty then begin fBackendDriver := GetBackEndByConnection(GetConnection); end; Result := fBackendDriver; end; class function TMVCActiveRecord.GetByPK(aActiveRecord: TMVCActiveRecord; const aValue: string; const aFieldType: TFieldType; const RaiseExceptionIfNotFound: Boolean): TMVCActiveRecord; begin Result := aActiveRecord; try if not Result.LoadByPK(aValue, aFieldType) then begin if RaiseExceptionIfNotFound then raise EMVCActiveRecordNotFound.Create('No data found') else FreeAndNil(Result); end; except FreeAndNil(Result); raise; end; end; class function TMVCActiveRecord.GetByPK(const aValue: string; const aFieldType: TFieldType; const RaiseExceptionIfNotFound: Boolean): T; begin Result := T(GetByPK(T.Create, aValue, aFieldType, RaiseExceptionIfNotFound)); end; class function TMVCActiveRecord.GetByPK(const aClass: TMVCActiveRecordClass; const aValue: string; const RaiseExceptionIfNotFound: Boolean): TMVCActiveRecord; begin Result := GetByPK(aClass.Create, aValue, ftString, RaiseExceptionIfNotFound); end; class function TMVCActiveRecord.GetByPK(const aClass: TMVCActiveRecordClass; const aValue: int64; const RaiseExceptionIfNotFound: Boolean): TMVCActiveRecord; begin Result := GetByPK(aClass.Create, aValue.ToString, ftInteger, RaiseExceptionIfNotFound); end; class function TMVCActiveRecord.GetByPK(const aClass: TMVCActiveRecordClass; const aValue: TGuid; const RaiseExceptionIfNotFound: Boolean): TMVCActiveRecord; begin Result := GetByPK(aClass.Create, aValue.ToString, ftGuid, RaiseExceptionIfNotFound); end; class function TMVCActiveRecordHelper.GetByPK(const aValue: int64; const RaiseExceptionIfNotFound: Boolean = True): T; begin Result := GetByPK(aValue.ToString, ftInteger, RaiseExceptionIfNotFound); end; class function TMVCActiveRecordHelper.GetByPK(const aValue: string; const RaiseExceptionIfNotFound: Boolean): T; begin Result := GetByPK(aValue, ftString, RaiseExceptionIfNotFound); end; class function TMVCActiveRecordHelper.GetByPK(const aValue: TGuid; const RaiseExceptionIfNotFound: Boolean): T; begin Result := GetByPK(aValue.ToString, ftGuid, RaiseExceptionIfNotFound); end; class function TMVCActiveRecordHelper.GetFirstByWhere(const SQLWhere: string; const Params: array of Variant; const ParamTypes: array of TFieldType; const RaiseExceptionIfNotFound: Boolean): T; var lList: TObjectList; begin lList := Where(SQLWhere, Params, ParamTypes); try if lList.Count = 0 then begin if RaiseExceptionIfNotFound then raise EMVCActiveRecordNotFound.Create('Got 0 rows when at least 1 was expected'); Exit(nil); end; Result := lList.Extract(lList.First); finally lList.Free; end; end; class function TMVCActiveRecordHelper.GetFirstByWhere(const SQLWhere: string; const Params: array of Variant; const RaiseExceptionIfNotFound: Boolean): T; begin Result := GetFirstByWhere(SQLWhere, Params, [], RaiseExceptionIfNotFound); end; class function TMVCActiveRecordHelper.GetOneByWhere(const SQLWhere: string; const Params: array of Variant; const ParamTypes: array of TFieldType; const RaiseExceptionIfNotFound: Boolean): T; begin Result := GetFirstByWhere(SQLWhere, Params, ParamTypes, false); if Result = nil then begin if RaiseExceptionIfNotFound then raise EMVCActiveRecordNotFound.Create('Got 0 rows when exactly 1 was expected'); end; end; function TMVCActiveRecord.GetMapping: TMVCFieldsMapping; var lPair: TPair; i: Integer; begin { TODO -oDanieleT -cGeneral : Let share the mapping for instances of the same type } { TODO -oDanieleT -cGeneral : Add NameAs in the TFieldInfo because the user needs to use the property name he see } if Length(fMapping) = 0 then begin if not fPrimaryKeyFieldName.IsEmpty then begin SetLength(fMapping, fMap.Count + 1); fMapping[0].InstanceFieldName := fPrimaryKey.Name.Substring(1).ToLower; fMapping[0].DatabaseFieldName := fPrimaryKeyFieldName; i := 1; end else begin SetLength(fMapping, fMap.Count); i := 0; end; for lPair in fMap do begin fMapping[i].InstanceFieldName := lPair.Key.Name.Substring(1).ToLower; fMapping[i].DatabaseFieldName := lPair.Value.FieldName; Inc(i); end; end; Result := fMapping; end; class function TMVCActiveRecordHelper.GetOneByWhere(const SQLWhere: string; const Params: array of Variant; const RaiseExceptionIfNotFound: Boolean): T; begin Result := GetFirstByWhere(SQLWhere, Params, false); if Result = nil then begin if RaiseExceptionIfNotFound then raise EMVCActiveRecordNotFound.Create('Got 0 rows when exactly 1 was expected'); end; end; class function TMVCActiveRecordHelper.SelectOneByRQL(const RQL: string; const RaiseExceptionIfNotFound: Boolean): T; var lAR: TMVCActiveRecord; lSQL: string; begin lAR := T.Create; try lSQL := lAR.SQLGenerator.CreateSQLWhereByRQL(RQL, lAR.GetMapping).Trim; lSQL := TMVCSQLGenerator.RemoveInitialWhereKeyword(lSQL); Result := GetFirstByWhere(lSQL, [], RaiseExceptionIfNotFound); if Result = nil then begin if RaiseExceptionIfNotFound then raise EMVCActiveRecordNotFound.Create('Got 0 rows when exactly 1 was expected'); end; finally lAR.Free; end; end; function TMVCActiveRecord.GetPartitionInfo: TPartitionInfo; var lRQLCompilerClass: TRQLCompilerClass; begin if fPartitionInfoInternal = nil then begin lRQLCompilerClass := TRQLCompilerRegistry.Instance.GetCompiler(GetBackEnd); fPartitionInfoInternal := TPartitionInfo.BuildPartitionClause(fPartitionClause, lRQLCompilerClass); end; Result := fPartitionInfoInternal; end; function TMVCActiveRecord.GetPK: TValue; var lIsNullableType: Boolean; begin if not TryGetPKValue(Result, lIsNullableType) then begin if not lIsNullableType then begin raise EMVCActiveRecord.Create('Primary key not available'); end; end; end; function TMVCActiveRecord.PKIsNull: Boolean; var lValue: TValue; lIsNullableType: Boolean; begin if not PKIsNullable(lValue) then begin raise EMVCActiveRecord.Create('PK is not nullable'); end; Result := not TryGetPKValue(lValue, lIsNullableType); end; function TMVCActiveRecord.PKIsNullable(out PKValue: TValue): Boolean; var lValue: TValue; begin PKValue := TryGetPKValue(lValue, Result); end; function TMVCActiveRecord.GetPrimaryKeyFieldType: TFieldType; begin Result := fPrimaryKeyFieldType; end; function TMVCActiveRecord.GetPrimaryKeyIsAutogenerated: Boolean; begin Result := foAutoGenerated in fPrimaryKeyOptions; end; class function TMVCActiveRecord.GetScalar(const SQL: string; const Params: array of Variant): Variant; begin Result := CurrentConnection.ExecSQLScalar(SQL, Params); end; function TMVCActiveRecord.CheckAction(const aEntityAction: TMVCEntityAction; const aRaiseException: Boolean): Boolean; begin Result := aEntityAction in fEntityAllowedActions; if (not Result) and aRaiseException then raise EMVCActiveRecord.CreateFmt ('Action [%s] not allowed on entity [%s]. [HINT] Add the entity action in MVCEntityActions attribute.', [GetEnumName(TypeInfo(TMVCEntityAction), Ord(aEntityAction)), ClassName]); end; class function TMVCActiveRecord.Count(const aClass: TMVCActiveRecordClass; const RQL: string): int64; var lAR: TMVCActiveRecord; begin lAR := aClass.Create; try // Up to 10.1 Berlin, here the compiler try to call the Count introduced by the class helper // Instead of the Count() which exists in "TMVCActiveRecord" Result := lAR.InternalCount(RQL); finally lAR.Free; end; end; function TMVCActiveRecord.Count(const RQL: string = ''): int64; begin Result := InternalCount(RQL); end; class function TMVCActiveRecordHelper.Count(const RQL: string = ''): int64; begin Result := TMVCActiveRecord.Count(TMVCActiveRecordClass(T), RQL); end; class function TMVCActiveRecord.CurrentConnection: TFDConnection; begin Result := ActiveRecordConnectionsRegistry.GetCurrent; end; function TMVCActiveRecord.GetConnection: TFDConnection; begin if fConn = nil then begin fConn := ActiveRecordConnectionsRegistry.GetCurrent; end; Result := fConn; end; constructor TMVCActiveRecord.Create; begin Create(True); end; procedure TMVCActiveRecord.Delete(const RaiseExceptionIfNotFound: Boolean); var SQL: string; lAffectedRows: Int64; begin CheckAction(TMVCEntityAction.eaDelete); OnValidation(TMVCEntityAction.eaDelete); OnBeforeDelete; if not Assigned(fPrimaryKey) then raise Exception.CreateFmt('Cannot delete %s without a primary key', [ClassName]); SQL := SQLGenerator.CreateDeleteSQL(fTableName, fMap, fPrimaryKeyFieldName, fPrimaryKeyOptions); lAffectedRows := ExecNonQuery(SQL, false); if (lAffectedRows = 0) and RaiseExceptionIfNotFound then begin raise EMVCActiveRecordNotFound.CreateFmt('No record deleted for key [Entity: %s][PK: %s]', [ClassName, fPrimaryKeyFieldName]); end; OnAfterDelete; end; class function TMVCActiveRecord.DeleteAll(const aClass: TMVCActiveRecordClass): int64; var lAR: TMVCActiveRecord; begin lAR := aClass.Create; try Result := lAR.ExecNonQuery( lAR.SQLGenerator.CreateDeleteAllSQL(lAR.fTableName) + lAR.SQLGenerator.GetDefaultSQLFilter(True) ); finally lAR.Free; end; end; class function TMVCActiveRecord.DeleteRQL(const aClass: TMVCActiveRecordClass; const RQL: string): int64; var lAR: TMVCActiveRecord; begin lAR := aClass.Create(True); try Result := lAR.ExecNonQuery(lAR.SQLGenerator.CreateDeleteAllSQL(lAR.fTableName) + lAR.SQLGenerator.CreateSQLWhereByRQL(RQL, lAR.GetMapping, false)); finally lAR.Free; end; end; procedure TMVCActiveRecord.MapDatasetToObject(const DataSet: TDataSet; const Options: TMVCActiveRecordLoadOptions; var Handled: Boolean); begin // do nothing end; procedure TMVCActiveRecord.MapObjectToParams(const Params: TFDParams; var Handled: Boolean); begin // do nothing end; function TMVCActiveRecord.MapNullableTValueToParam(aValue: TValue; const aParam: TFDParam): Boolean; begin Assert(aValue.Kind = tkRecord); Result := false; if aValue.IsType(TypeInfo(NullableString)) then begin if not aValue.AsType().HasValue then begin aParam.DataType := ftString; aParam.Clear; Exit(True); end else begin aValue := aValue.AsType().Value; Result := True; end; end else if aValue.IsType(TypeInfo(NullableInt32)) then begin if not aValue.AsType().HasValue then begin aParam.DataType := ftInteger; aParam.Clear; Exit(True); end else begin aValue := aValue.AsType().Value; Result := True; end; end else if aValue.IsType(TypeInfo(NullableTDate)) then begin if not aValue.AsType().HasValue then begin aParam.DataType := ftDate; aParam.Clear; Exit(True); end else begin aValue := TValue.From(aValue.AsType().Value); Result := True; end; end else if aValue.IsType(TypeInfo(NullableTTime)) then begin if not aValue.AsType().HasValue then begin aParam.DataType := ftTime; aParam.Clear; Exit(True); end else begin aValue := TValue.From(aValue.AsType().Value); Result := True; end; end else if aValue.IsType(TypeInfo(NullableTDateTime)) then begin if not aValue.AsType().HasValue then begin aParam.DataType := ftDateTime; aParam.Clear; Exit(True); end else begin aValue := TValue.From(aValue.AsType().Value); Result := True; end; end else if aValue.IsType(TypeInfo(NullableUInt32)) then begin if not aValue.AsType().HasValue then begin aParam.DataType := ftInteger; aParam.Clear; Exit(True); end else begin aValue := aValue.AsType().Value; Result := True; end; end else if aValue.IsType(TypeInfo(NullableInt64)) then begin if not aValue.AsType().HasValue then begin aParam.DataType := ftLargeInt; aParam.Clear; Exit(True); end else begin aValue := aValue.AsType().Value; Result := True; end; end else if aValue.IsType(TypeInfo(NullableInt16)) then begin if not aValue.AsType().HasValue then begin aParam.DataType := ftInteger; aParam.Clear; Exit(True); end else begin aValue := aValue.AsType().Value; Result := True; end; end else if aValue.IsType(TypeInfo(NullableUInt64)) then begin if not aValue.AsType().HasValue then begin aParam.DataType := ftLargeInt; aParam.Clear; Exit(True); end else begin aValue := aValue.AsType().Value; Result := True; end; end else if aValue.IsType(TypeInfo(NullableUInt16)) then begin if not aValue.AsType().HasValue then begin aParam.DataType := ftInteger; aParam.Clear; Exit(True); end else begin aValue := aValue.AsType().Value; Result := True; end; end else if aValue.IsType(TypeInfo(NullableBoolean)) then begin if not aValue.AsType().HasValue then begin aParam.DataType := ftBoolean; aParam.Clear; Exit(True); end else begin aValue := TValue.From(aValue.AsType().Value); Result := True; end; end else if aValue.IsType(TypeInfo(NullableSingle)) then begin if not aValue.AsType().HasValue then begin aParam.DataType := TFieldType.ftSingle; aParam.Clear; Exit(True); end else begin aValue := aValue.AsType().Value; Result := True; end; end else if aValue.IsType(TypeInfo(NullableDouble)) then begin if not aValue.AsType().HasValue then begin aParam.DataType := TFieldType.ftFloat; aParam.Clear; Exit(True); end else begin aValue := aValue.AsType().Value; Result := True; end; end else if aValue.IsType(TypeInfo(NullableCurrency)) then begin if not aValue.AsType().HasValue then begin aParam.DataType := TFieldType.ftCurrency; aParam.Clear; Exit(True); end else begin aValue := aValue.AsType().Value; Result := True; end; end else if aValue.IsType(TypeInfo(NullableTGUID)) then begin if not aValue.AsType().HasValue then begin aParam.DataType := TFieldType.ftCurrency; aParam.Clear; Exit(True); end else begin aValue := TValue.From(aValue.AsType().Value); Result := True; end; end; if Result then begin MapTValueToParam(aValue, aParam); end; end; procedure TMVCActiveRecord.MapTValueToParam(aValue: TValue; const aParam: TFDParam); const MAX_STRING_PARAM_LENGTH = 1000; { Arbitrary value } var lStream: TStream; lName: string; begin {$IFDEF NEXTGEN} lName := aValue.TypeInfo.NameFld.ToString; {$ELSE} lName := string(aValue.TypeInfo.Name); {$ENDIF} if (lName.StartsWith('Nullable', True) and (aValue.TypeInfo.Kind = tkRecord)) then begin if MapNullableTValueToParam(aValue, aParam) then begin Exit; end; end; case aValue.TypeInfo.Kind of tkUString: begin case aParam.DataType of ftUnknown, ftWideString: begin if aValue.AsString.Length > MAX_STRING_PARAM_LENGTH then begin aParam.AsWideMemo := aValue.AsString; end else begin aParam.AsWideString := aValue.AsString; end; end; ftString: begin if aValue.AsString.Length > MAX_STRING_PARAM_LENGTH then begin aParam.AsMemo := AnsiString(aValue.AsString); end else begin aParam.AsString := aValue.AsString; end; end; ftWideMemo: begin aParam.AsWideMemo := aValue.AsString; end; ftMemo: begin aParam.AsMemo := AnsiString(aValue.AsString); end; else begin raise EMVCActiveRecord.CreateFmt('Invalid parameter type for (tkUString) [%s]', [lName]); end; end; end; tkString: begin case aParam.DataType of ftUnknown, ftWideString: begin if aValue.AsString.Length > MAX_STRING_PARAM_LENGTH then begin aParam.AsWideMemo := aValue.AsString; end else begin aParam.AsWideString := aValue.AsString; end; end; ftString: begin if aValue.AsString.Length > MAX_STRING_PARAM_LENGTH then begin aParam.AsMemo := AnsiString(aValue.AsString); end else begin aParam.AsString := aValue.AsString; end; end; ftWideMemo: begin aParam.AsWideMemo := aValue.AsString; end; ftMemo: begin aParam.AsMemo := AnsiString(aValue.AsString); end; else begin raise EMVCActiveRecord.CreateFmt('Invalid parameter type for (tkString) [%s]', [lName]); end; end; end; {$IF Defined(SeattleOrBetter)} tkWideString: begin if aValue.AsString.Length > MAX_STRING_PARAM_LENGTH then begin aParam.AsWideMemo := aValue.AsString; end else begin aParam.AsWideString := aValue.AsString; end end; {$ENDIF} tkInt64: begin aParam.AsLargeInt := aValue.AsInt64; end; tkInteger: begin aParam.AsInteger := aValue.AsInteger; end; tkEnumeration: begin if aValue.TypeInfo = TypeInfo(System.Boolean) then begin aParam.AsBoolean := aValue.AsBoolean; end else begin aParam.AsInteger := Ord(aValue.AsInteger); end; end; tkFloat: begin if lName = 'TDate' then begin aParam.AsDate := Trunc(aValue.AsExtended); end else if lName = 'TDateTime' then begin aParam.AsDateTime := aValue.AsExtended; end else if lName = 'TTime' then begin aParam.AsTime := aValue.AsExtended; end else if lName = 'Currency' then begin aParam.AsCurrency := aValue.AsCurrency; end else begin aParam.AsFloat := aValue.AsExtended; end; end; tkClass: begin if (aValue.AsObject <> nil) and (not aValue.IsInstanceOf(TStream)) then raise EMVCActiveRecord.CreateFmt('Unsupported reference type for param %s: %s', [aParam.Name, aValue.AsObject.ClassName]); { .$IF Defined(SeattleOrBetter) } // lStream := aValue.AsType(); { .$ELSE } lStream := aValue.AsType(); { .$ENDIF } if Assigned(lStream) then begin lStream.Position := 0; aParam.LoadFromStream(lStream, ftBlob); end else begin aParam.DataType := TFieldType.ftBlob; aParam.Clear; end; end; tkRecord: begin if aValue.IsType(TypeInfo(TGUID)) then begin aParam.AsGuid := aValue.AsType; end else if aValue.IsType(TypeInfo(NullableTGUID)) then begin if aValue.AsType.HasValue then aParam.AsGuid := aValue.AsType.Value else aParam.Clear(); end else begin raise Exception.CreateFmt('Unsupported Record TypeKind (%d) for param %s', [Ord(aValue.TypeInfo.Kind), aParam.Name]); end; end; else raise Exception.CreateFmt('Unsupported TypeKind (%d) for param %s', [Ord(aValue.TypeInfo.Kind), aParam.Name]); end; end; procedure TMVCActiveRecord.LoadByDataset(const aDataSet: TDataSet; const aOptions: TMVCActiveRecordLoadOptions); var lItem: TPair; lField: TField; lHandled: Boolean; begin CheckAction(TMVCEntityAction.eaRetrieve); OnBeforeLoad; lHandled := false; MapDatasetToObject(aDataSet, aOptions, lHandled); if not lHandled then begin for lItem in fMap do begin if not lItem.Value.Readable then begin continue; end; lField := aDataSet.FindField(lItem.Value.FieldName); if lField = nil then begin if TMVCActiveRecordLoadOption.loIgnoreNotExistentFields in aOptions then continue else raise EMVCActiveRecord.CreateFmt ('Field [%s] not found in dataset. [HINT] If you dont need it, use loIgnoreNotExistentFields', [lItem.Value.FieldName]); end; MapDataSetFieldToRTTIField(lField, lItem.Key, Self); end; if not fPrimaryKeyFieldName.IsEmpty then begin MapDataSetFieldToRTTIField(aDataSet.FieldByName(fPrimaryKeyFieldName), fPrimaryKey, Self); end; end; OnAfterLoad; end; function TMVCActiveRecord.LoadByPK(const id: string; const aFieldType: TFieldType): Boolean; var SQL: string; lDataSet: TDataSet; begin CheckAction(TMVCEntityAction.eaRetrieve); SQL := SQLGenerator.CreateSelectByPKSQL(fTableName, fMap, fPrimaryKeyFieldName, fPrimaryKeyOptions); lDataSet := ExecQuery(SQL, [id], [aFieldType], GetConnection, True); try Result := not lDataSet.Eof; if Result then begin LoadByDataset(lDataSet); end; finally lDataSet.Free; end; end; function TMVCActiveRecord.LoadByPK(const id: string): Boolean; begin Result := LoadByPK(id, ftString); end; function TMVCActiveRecord.LoadByPK(const id: int64): Boolean; begin Result := LoadByPK(id.ToString, ftInteger); end; function TMVCActiveRecord.LoadByPK(const id: TGuid): Boolean; begin Result := LoadByPK(id.ToString, ftGuid); end; procedure TMVCActiveRecord.OnAfterDelete; begin // do nothing end; procedure TMVCActiveRecord.OnAfterInsert; begin // do nothing end; procedure TMVCActiveRecord.OnAfterInsertOrUpdate; begin // do nothing end; procedure TMVCActiveRecord.OnAfterLoad; begin // do nothing end; procedure TMVCActiveRecord.OnAfterUpdate; begin // do nothing end; procedure TMVCActiveRecord.OnBeforeDelete; begin // do nothing end; procedure TMVCActiveRecord.OnBeforeExecuteSQL(var SQL: string); 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(const EntityAction: TMVCEntityAction); begin // do nothing end; procedure TMVCActiveRecord.RemoveChildren(const ChildObject: TObject); begin if fChildren <> nil then begin fChildren.Extract(ChildObject); end; end; procedure TMVCActiveRecord.InvalidateConnection(const ReacquireAfterInvalidate: Boolean = false); begin FreeAndNil(fConn); if ReacquireAfterInvalidate then begin EnsureConnection; end; end; class function TMVCActiveRecord.Select(const aClass: TMVCActiveRecordClass; const SQL: string; const Params: array of Variant): TMVCActiveRecordList; 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): TMVCActiveRecordList; var lDataSet: TDataSet; lAR: TMVCActiveRecord; begin Result := TMVCActiveRecordList.Create; try lDataSet := ExecQuery(SQL, Params, Connection, True); try while not lDataSet.Eof do begin lAR := aClass.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; const ParamTypes: array of TFieldType; const Unidirectional: Boolean): TDataSet; begin Result := TMVCActiveRecord.ExecQuery(SQL, Params, ParamTypes, Unidirectional); end; class function TMVCActiveRecordHelper.Select(const SQL: string; const Params: array of Variant; const Options: TMVCActiveRecordLoadOptions): TObjectList; begin Result := Select(SQL, Params, [], Options); end; class function TMVCActiveRecord.SelectDataSet(const SQL: string; const Params: array of Variant; const Unidirectional: Boolean) : TDataSet; begin {TODO -odanielet -cGeneral : gestire unidirectional} Result := TMVCActiveRecord.ExecQuery(SQL, Params, Unidirectional); end; function TMVCActiveRecord.SelectRQL(const RQL: string; const MaxRecordCount: Integer) : TMVCActiveRecordList; begin Result := InternalSelectRQL(RQL, MaxRecordCount); end; class function TMVCActiveRecordHelper.Select(const SQL: string; const Params: array of Variant; const ParamTypes: array of TFieldType; const Options: TMVCActiveRecordLoadOptions) : TObjectList; var lDataSet: TDataSet; lAR: TMVCActiveRecord; lHandled: Boolean; begin Result := TObjectList.Create(True); try lDataSet := ExecQuery(SQL, Params, ParamTypes, False); try while not lDataSet.Eof do begin lAR := T.Create; Result.Add(lAR); lAR.LoadByDataset(lDataSet, Options); lDataSet.Next; end; finally lDataSet.Free; end; except Result.Free; raise; end; end; class function TMVCActiveRecordHelper.SelectOne(const SQL: string; const Params: array of Variant; const RaiseExceptionIfNotFound: Boolean): T; begin Result := SelectOne(SQL, Params, [], [], RaiseExceptionIfNotFound); end; class function TMVCActiveRecordHelper.SelectOne(const SQL: string; const Params: array of Variant; const ParamTypes: array of TFieldType; const Options: TMVCActiveRecordLoadOptions; const RaiseExceptionIfNotFound: Boolean): T; var lDataSet: TDataSet; lAR: TMVCActiveRecord; lHandled: Boolean; lList: TObjectList; begin Result := nil; lList := Select(SQL, Params, ParamTypes, Options); try if (lList.Count = 0) then begin if RaiseExceptionIfNotFound then raise EMVCActiveRecordNotFound.Create('Got 0 rows when exactly 1 was expected') else Exit(nil); end; if lList.Count > 1 then begin raise EMVCActiveRecordNotFound.CreateFmt('Got %d rows when exactly 1 was expected', [lList.Count]); end; Result := lList.Extract(lList.First); finally lList.Free; end; end; class function TMVCActiveRecordHelper.SelectRQL(const RQL: string; const MaxRecordCount: Integer) : TObjectList; var lAR: TMVCActiveRecord; lSQL: string; begin lAR := T.Create; try lSQL := lAR.SQLGenerator.CreateSQLWhereByRQL(RQL, lAR.GetMapping, MaxRecordCount > -1, False, MaxRecordCount).Trim; lSQL := TMVCSQLGenerator.RemoveInitialWhereKeyword(lSQL); Result := Where(lSQL, []); finally lAR.Free; end; end; class function TMVCActiveRecordHelper.Where(const SQLWhere: string; const Params: array of Variant; const ParamTypes: array of TFieldType): TObjectList; var lAR: TMVCActiveRecord; lFilter: string; begin lAR := T.Create; try lFilter := lAR.SQLGenerator.GetDefaultSQLFilter(True); if SQLWhere.Trim.IsEmpty() or SQLWhere.Trim.StartsWith('/*limit*/') or SQLWhere.Trim.StartsWith('/*sort*/') then begin Result := Select(lAR.GenerateSelectSQL + lFilter + SQLWhere, Params, ParamTypes) end else begin if lFilter.IsEmpty then Result := Select(lAR.GenerateSelectSQL + ' WHERE ' + SQLWhere, Params, ParamTypes) else begin Result := Select(lAR.GenerateSelectSQL + lFilter + ' AND ' + SQLWhere, Params, ParamTypes); end; end; finally lAR.Free; end; end; class function TMVCActiveRecord.SelectRQL(const aClass: TMVCActiveRecordClass; const RQL: string; const MaxRecordCount: Integer): TMVCActiveRecordList; var lAR: TMVCActiveRecord; begin lAR := aClass.Create(True); try Result := lAR.InternalSelectRQL(RQL, MaxRecordCount); finally lAR.Free; end; end; procedure TMVCActiveRecord.SetAttributes(const AttrName: string; const Value: TValue); var lProperty: TRttiProperty; begin if not TRttiUtils.ExistsProperty(Self, AttrName, lProperty) then begin raise EMVCActiveRecord.CreateFmt('Attribute [%s] not found', [AttrName]); end; SetPropertyValue(lProperty, Value); end; procedure TMVCActiveRecord.SetPropertyValue(const aProp: TRttiProperty; const aValue: TValue); var lCurrValue: TValue; lNullableString: NullableString; lNullableUInt32: NullableUInt32; lNullableUInt64: NullableUInt64; lNullableInt64: NullableInt64; lNullableBoolean: NullableBoolean; lNullableTDateTime: NullableTDateTime; lNullableTDate: NullableTDate; lNullableTTime: NullableTTime; begin if aProp.GetValue(Self).Kind = tkRecord then begin lCurrValue := aProp.GetValue(Self); if lCurrValue.IsType then begin if aValue.IsType() then begin lCurrValue := aValue; end else begin lCurrValue := TValue.From(IntToNullableInt(aValue.AsInteger)); end end else if lCurrValue.IsType then begin if aValue.IsType() then begin lCurrValue := aValue; end else begin lNullableInt64 := aValue.AsInt64; lCurrValue := TValue.From(lNullableInt64); end; end else if lCurrValue.IsType then begin if aValue.IsType() then begin lCurrValue := aValue; end else begin lNullableString := aValue.AsString; lCurrValue := TValue.From(lNullableString); end; end else if lCurrValue.IsType then begin if aValue.IsType() then begin lCurrValue := aValue; end else begin lNullableUInt32 := aValue.AsInteger; lCurrValue.From(lNullableUInt32); end; end else if lCurrValue.IsType then begin if aValue.IsType() then begin lCurrValue := aValue; end else begin lNullableUInt64 := aValue.AsUInt64; lCurrValue.From(lNullableUInt64); end; end else if lCurrValue.IsType then begin if aValue.IsType() then begin lCurrValue := aValue; end else begin lNullableBoolean := aValue.AsBoolean; lCurrValue.From(lNullableBoolean); end; end else if lCurrValue.IsType then begin if aValue.IsType() then begin lCurrValue := aValue; end else begin {$IF Defined(TOKYOORBETTER)} lNullableTDateTime := TDateTime(aValue.AsExtended); {$ELSE} lNullableTDateTime := aValue.AsExtended; {$ENDIF} lCurrValue.From(lNullableTDateTime); end; end else if lCurrValue.IsType then begin if aValue.IsType() then begin lCurrValue := aValue; end else begin {$IF Defined(TOKYOORBETTER)} lNullableTDate := TDate(aValue.AsExtended); {$ELSE} lNullableTDate := aValue.AsExtended; {$ENDIF} lCurrValue.From(lNullableTDate); end; end else if lCurrValue.IsType then begin if aValue.IsType() then begin lCurrValue := aValue; end else begin {$IF Defined(TOKYOORBETTER)} lNullableTTime := TTime(aValue.AsExtended); {$ELSE} lNullableTTime := aValue.AsExtended; {$ENDIF} lCurrValue.From(lNullableTTime); end; end else begin raise EMVCActiveRecord.Create('Invalid data type for dynamic property access'); end; aProp.SetValue(Self, lCurrValue); end else begin aProp.SetValue(Self, aValue) end; end; procedure TMVCActiveRecord.SetPK(const aValue: TValue); var lPKValue: TValue; begin if fPrimaryKeyFieldName.IsEmpty then begin raise Exception.Create('No primary key defined'); end; if fPrimaryKey.GetValue(Self).Kind = tkRecord then begin lPKValue := fPrimaryKey.GetValue(Self); if lPKValue.IsType and aValue.IsType() then begin if aValue.IsType then begin lPKValue := TValue.From(IntToNullableInt(aValue.AsInteger)); end; end else if lPKValue.IsType and aValue.IsType() then begin if aValue.AsType().HasValue then begin lPKValue := aValue; end else begin lPKValue.AsType().Clear; end; end else if lPKValue.IsType and aValue.IsType() then begin if aValue.AsType().HasValue then begin lPKValue := aValue; end else begin lPKValue.AsType().Clear; end; end else if lPKValue.IsType and aValue.IsType() then begin if aValue.AsType().HasValue then begin lPKValue := aValue; end else begin lPKValue.AsType().Clear; end; end else if lPKValue.IsType and aValue.IsType() then begin if aValue.AsType().HasValue then begin lPKValue := aValue; end else begin lPKValue.AsType().Clear; end; end else begin raise EMVCActiveRecord.Create ('Invalid type for primary key [HINT] Double check if TypeInfo(PK) is equal to TypeInfo(Value)'); end; fPrimaryKey.SetValue(Self, lPKValue); end else begin fPrimaryKey.SetValue(Self, aValue) end; end; procedure TMVCActiveRecord.SetPrimaryKeyIsAutogenerated(const Value: Boolean); begin if Value then begin Include(fPrimaryKeyOptions, foAutoGenerated); end else begin Exclude(fPrimaryKeyOptions, foAutoGenerated); end; end; procedure TMVCActiveRecord.SetTableName(const Value: string); begin fTableName := Value; end; function TMVCActiveRecord.SQLGenerator: TMVCSQLGenerator; begin if not Assigned(fSQLGenerator) then begin GetConnection.Connected := True; fSQLGenerator := TMVCSQLGeneratorRegistry.Instance.GetSQLGenerator(GetBackEnd) .Create(GetMapping, fDefaultRQLFilter, GetPartitionInfo); end; Result := fSQLGenerator; end; procedure TMVCActiveRecord.Store; var lValue: TValue; lRes: Boolean; lIsNullableType: Boolean; begin lRes := TryGetPKValue(lValue, lIsNullableType); if not lIsNullableType then begin raise EMVCActiveRecord.Create ('Store can be used only with nullable PKs [HINT] Use NullableInt64 as PK'); end; if lRes then begin Update; end else begin Insert; end; end; function TMVCActiveRecord.TableInfo: string; var KeyValue: TPair; begin Result := 'Table Name: ' + fTableName; for KeyValue in fMap do Result := Result + sLineBreak + #9 + KeyValue.Key.Name + ' = ' + KeyValue.Value.FieldName; end; function TMVCActiveRecord.TryGetPKValue(var Value: TValue; out IsNullableType: Boolean): Boolean; begin IsNullableType := false; if fPrimaryKeyFieldName.IsEmpty then raise Exception.Create('No primary key defined'); Value := fPrimaryKey.GetValue(Self); if Value.Kind = tkRecord then begin if Value.IsType() then begin Result := Value.AsType().HasValue; if Result then Value := Value.AsType().Value; end else if Value.IsType() then begin Result := Value.AsType().HasValue; if Result then Value := Value.AsType().Value; end else if Value.IsType() then begin Result := Value.AsType().HasValue; if Result then Value := Value.AsType().Value; end else if Value.IsType() then begin Result := Value.AsType().HasValue; if Result then Value := Value.AsType().Value; end else if Value.IsType() then begin Result := Value.AsType().HasValue; if Result then Value := Value.AsType().Value; end else if Value.IsType() then begin Result := Value.AsType().HasValue; if Result then Value := Value.AsType().Value; end else if Value.IsType() then begin Result := Value.AsType().HasValue; if Result then Value := Value.AsType().Value; end else raise EMVCActiveRecord.Create ('Invalid primary key type [HINT: Use Int64, String, NullableInt64 or NullableString, so that Store method is available too.]'); IsNullableType := True; end else begin Result := not Value.IsEmpty; end; end; procedure TMVCActiveRecord.Update(const RaiseExceptionIfNotFound: Boolean = True); var SQL: string; lAffectedRows: Int64; begin CheckAction(TMVCEntityAction.eaUpdate); OnValidation(TMVCEntityAction.eaUpdate); OnBeforeUpdate; OnBeforeInsertOrUpdate; if fMap.WritableFieldsCount = 0 then begin raise EMVCActiveRecord.CreateFmt ('Cannot update an entity if all fields are transient. Class [%s] mapped on table [%s]', [ClassName, fTableName]); end; SQL := SQLGenerator.CreateUpdateSQL(fTableName, fMap, fPrimaryKeyFieldName, fPrimaryKeyOptions); lAffectedRows := ExecNonQuery(SQL, false); if (lAffectedRows = 0) and RaiseExceptionIfNotFound then begin raise EMVCActiveRecordNotFound.CreateFmt('No record updated for key [Entity: %s][PK: %s]', [ClassName, fPrimaryKeyFieldName]); end; OnAfterUpdate; OnAfterInsertOrUpdate; end; procedure TMVCActiveRecord.AddChildren(const ChildObject: TObject); begin if fChildren = nil then begin fChildren := TObjectList.Create(True); end; if not(fChildren.Contains(ChildObject)) and (not(ChildObject = Self)) then begin fChildren.Add(ChildObject); end; end; class function TMVCActiveRecord.All(const aClass: TMVCActiveRecordClass) : TObjectList; var lAR: TMVCActiveRecord; begin lAR := aClass.Create; try Result := Select(aClass, lAR.GenerateSelectSQL, []); finally lAR.Free; end; end; class function TMVCActiveRecordHelper.All: TObjectList; var lAR: TMVCActiveRecord; begin lAR := T.Create; try Result := Select(lAR.GenerateSelectSQL, []); finally lAR.Free; end; end; class function TMVCActiveRecord.Where(const aClass: TMVCActiveRecordClass; const SQLWhere: string; const Params: array of Variant): TMVCActiveRecordList; 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): TMVCActiveRecordList; var lAR: TMVCActiveRecord; begin lAR := aClass.Create; try Result := Select(aClass, lAR.GenerateSelectSQL + SQLWhere, Params, Connection); finally lAR.Free; end; end; class function TMVCActiveRecordHelper.Where(const SQLWhere: string; const Params: array of Variant): TObjectList; begin Result := Where(SQLWhere, Params, []); end; class function TMVCActiveRecordHelper.Merge(CurrentList, NewList: TObjectList) : IMVCMultiExecutor; var i: Integer; lFoundAtIndex: Integer; lCurrPKValue: Integer; lPKValue: TValue; lUnitOfWork: IMVCUnitOfWork; lPKType: TFieldType; lNeedsToBeUpdated: Boolean; begin lUnitOfWork := TMVCUnitOfWork.Create; lUnitOfWork.RegisterDelete(CurrentList); if NewList.Count > 0 then begin lPKType := NewList[0].GetPrimaryKeyFieldType; for i := 0 to NewList.Count - 1 do begin if NewList[i].PKIsNull then begin lUnitOfWork.RegisterInsert(NewList[i]); continue; end; case lPKType of ftString: begin lNeedsToBeUpdated := TMVCUnitOfWork.KeyExistsString(CurrentList, NewList[i].GetPK.AsString, lFoundAtIndex); end; ftInteger: begin lNeedsToBeUpdated := TMVCUnitOfWork.KeyExistsInt(CurrentList, NewList[i].GetPK.AsInteger, lFoundAtIndex); end; ftLargeInt: begin lNeedsToBeUpdated := TMVCUnitOfWork.KeyExistsInt64(CurrentList, NewList[i].GetPK.AsInt64, lFoundAtIndex); end; else raise EMVCActiveRecord.Create('Invalid primary key type'); end; if lNeedsToBeUpdated then lUnitOfWork.RegisterUpdate(NewList[i]) else lUnitOfWork.RegisterInsert(NewList[i]); end; end; Result := lUnitOfWork as IMVCMultiExecutor; end; { TMVCEntitiesRegistry } procedure TMVCEntitiesRegistry.AddEntity(const aURLSegment: string; const aActiveRecordClass: TMVCActiveRecordClass); begin fEntitiesDict.AddOrSetValue(aURLSegment.ToLower, aActiveRecordClass); end; procedure TMVCEntitiesRegistry.AddEntityProcessor(const aURLSegment: string; const aEntityProcessor: IMVCEntityProcessor); begin fProcessorsDict.Add(aURLSegment, aEntityProcessor); end; constructor TMVCEntitiesRegistry.Create; begin inherited; fEntitiesDict := TDictionary.Create; fProcessorsDict := TDictionary.Create; end; destructor TMVCEntitiesRegistry.Destroy; begin fEntitiesDict.Free; fProcessorsDict.Free; inherited; end; function TMVCEntitiesRegistry.FindEntityClassByURLSegment(const aURLSegment: string; out aMVCActiveRecordClass: TMVCActiveRecordClass): Boolean; begin Result := fEntitiesDict.TryGetValue(aURLSegment.ToLower, aMVCActiveRecordClass); end; function TMVCEntitiesRegistry.FindProcessorByURLSegment(const aURLSegment: string; out aMVCEntityProcessor: IMVCEntityProcessor): Boolean; begin Result := fProcessorsDict.TryGetValue(aURLSegment.ToLower, aMVCEntityProcessor); end; function TMVCEntitiesRegistry.GetEntities: TArray; begin Result := fEntitiesDict.Keys.ToArray; end; { EMVCActiveRecord } constructor EMVCActiveRecord.Create(const AMsg: string); begin inherited Create(http_status.BadRequest, AMsg); end; { EntityActionsAttribute } constructor MVCEntityActionsAttribute.Create(const aEntityAllowedActions: TMVCEntityActions); begin inherited Create; EntityAllowedActions := aEntityAllowedActions; end; { TMVCActiveRecordList } constructor TMVCActiveRecordList.Create; begin inherited Create(True); end; { TMVCSQLGeneratorRegistry } constructor TMVCSQLGeneratorRegistry.Create; begin inherited; fSQLGenerators := TDictionary.Create; end; class constructor TMVCSQLGeneratorRegistry.Create; begin cLock := TObject.Create; end; class destructor TMVCSQLGeneratorRegistry.Destroy; begin cLock.Free; cInstance.Free; end; destructor TMVCSQLGeneratorRegistry.Destroy; begin fSQLGenerators.Free; inherited; end; function TMVCSQLGeneratorRegistry.GetSQLGenerator(const aBackend: string): TMVCSQLGeneratorClass; begin if not fSQLGenerators.TryGetValue(aBackend, Result) then begin raise ERQLCompilerNotFound.CreateFmt('SQLGenerator not found for "%s"', [aBackend]); end; end; class function TMVCSQLGeneratorRegistry.Instance: TMVCSQLGeneratorRegistry; begin if not Assigned(cInstance) then begin TMonitor.Enter(cLock); try if not Assigned(cInstance) then begin cInstance := TMVCSQLGeneratorRegistry.Create; end; finally TMonitor.Exit(cLock); end; end; Result := cInstance; end; procedure TMVCSQLGeneratorRegistry.RegisterSQLGenerator(const aBackend: string; const aRQLBackendClass: TMVCSQLGeneratorClass); begin fSQLGenerators.AddOrSetValue(aBackend, aRQLBackendClass); end; procedure TMVCSQLGeneratorRegistry.UnRegisterSQLGenerator(const aBackend: string); begin fSQLGenerators.Remove(aBackend); end; { TMVCSQLGenerator } constructor TMVCSQLGenerator.Create(Mapping: TMVCFieldsMapping; const DefaultRQLFilter: string; const PartitionInfo: TPartitionInfo); begin inherited Create; fMapping := Mapping; fDefaultRQLFilter := DefaultRQLFilter; fPartitionInfo := PartitionInfo; GetCompiler; if not fDefaultRQLFilter.IsEmpty then begin GetRQLParser.Execute(fDefaultRQLFilter,fDefaultSQLFilter, GetCompiler, False, True); fDefaultSQLFilter := TMVCSQLGenerator.RemoveInitialWhereKeyword(fDefaultSQLFilter); end; end; function TMVCSQLGenerator.GetMapping: TMVCFieldsMapping; begin Result := fMapping; end; function TMVCSQLGenerator.GetParamNameForSQL(const FieldName: string): string; begin Result := fCompiler.GetParamNameForSQL(FieldName); end; function TMVCSQLGenerator.CreateDeleteAllSQL(const TableName: string): string; begin Result := 'DELETE FROM ' + GetTableNameForSQL(TableName); end; function TMVCSQLGenerator.CreateDeleteSQL(const TableName: string; const Map: TFieldsMap; const PKFieldName: string; const PKOptions: TMVCActiveRecordFieldOptions): string; begin Result := CreateDeleteAllSQL(TableName) + ' WHERE ' + GetFieldNameForSQL(PKFieldName) + '=:' + GetParamNameForSQL(PKFieldName); end; function TMVCSQLGenerator.CreateSelectByPKSQL(const TableName: string; const Map: TFieldsMap; const PKFieldName: string; const PKOptions: TMVCActiveRecordFieldOptions): string; begin if PKFieldName.IsEmpty then begin raise EMVCActiveRecord.Create('No primary key provided. [HINT] Define a primary key field adding foPrimaryKey in field options.'); end; Result := CreateSelectSQL(TableName, Map, PKFieldName, PKOptions) + ' WHERE ' + GetFieldNameForSQL(PKFieldName) + '= :' + GetParamNameForSQL(PKFieldName) + GetDefaultSQLFilter(False, True); end; function TMVCSQLGenerator.CreateSelectCount(const TableName: string): string; begin {do not add SQLFilter here!} Result := 'SELECT count(*) FROM ' + GetTableNameForSQL(TableName); end; function TMVCSQLGenerator.CreateSelectSQL(const TableName: string; const Map: TFieldsMap; const PKFieldName: string; const PKOptions: TMVCActiveRecordFieldOptions): string; begin Result := 'SELECT ' + TableFieldsDelimited(Map, PKFieldName, ',') + ' FROM ' + GetTableNameForSQL(TableName); end; function TMVCSQLGenerator.CreateSQLWhereByRQL(const RQL: string; const Mapping: TMVCFieldsMapping; const UseArtificialLimit, UseFilterOnly: Boolean; const MaxRecordCount: Int32): string; begin GetRQLParser.Execute(MergeDefaultRQLFilter(RQL), Result, GetCompiler, UseArtificialLimit, UseFilterOnly, MaxRecordCount); end; function TMVCSQLGenerator.CreateUpdateSQL(const TableName: string; const Map: TFieldsMap; const PKFieldName: string; const PKOptions: TMVCActiveRecordFieldOptions): string; var lPair: TPair; I: Integer; begin Result := 'UPDATE ' + GetTableNameForSQL(TableName) + ' SET '; for lPair in Map do begin if lPair.Value.Writeable then begin Result := Result + GetFieldNameForSQL(lPair.Value.FieldName) + ' = :' + GetParamNameForSQL(lPair.Value.FieldName) + ','; end; end; {partition} for I := 0 to fPartitionInfo.FieldNames.Count - 1 do begin Result := Result + GetFieldNameForSQL(fPartitionInfo.FieldNames[I]) + ' = :' + GetParamNameForSQL(fPartitionInfo.FieldNames[I]) + ','; end; {end-partitioning} Result[Length(Result)] := ' '; if not PKFieldName.IsEmpty then begin Result := Result + ' where ' + GetFieldNameForSQL(PKFieldName) + '= :' + GetParamNameForSQL(PKFieldName); end; end; destructor TMVCSQLGenerator.Destroy; begin fCompiler.Free; fRQL2SQL.Free; inherited; end; function TMVCSQLGenerator.GetCompiler: TRQLCompiler; begin if fCompiler = nil then begin fCompiler := GetCompilerClass.Create(fMapping); end; Result := fCompiler; end; function TMVCSQLGenerator.GetDefaultSQLFilter(const IncludeWhereClause: Boolean; const IncludeAndClauseBeforeFilter: Boolean): String; begin Result := MergeSQLFilter(fPartitionInfo.SQLFilter, fDefaultSQLFilter); if not Result.IsEmpty then begin if IncludeWhereClause then begin Result := ' WHERE ' + Result; end else begin if IncludeAndClauseBeforeFilter then Result := ' and ' + Result; end; end; end; function TMVCSQLGenerator.GetFieldNameForSQL(const FieldName: string): string; begin Result := fCompiler.GetFieldNameForSQL(FieldName); end; function TMVCSQLGenerator.GetRQLParser: TRQL2SQL; begin if fRQL2SQL = nil then begin fRQL2SQL := TRQL2SQL.Create; end; Result := fRQL2SQL; end; function TMVCSQLGenerator.GetSequenceValueSQL(const PKFieldName: string; const SequenceName: string; const Step: Integer = 1): string; begin Result := ''; end; function TMVCSQLGenerator.GetTableNameForSQL(const TableName: string): string; begin Result := fCompiler.GetTableNameForSQL(TableName); end; function TMVCSQLGenerator.HasReturning: Boolean; begin Result := True; end; function TMVCSQLGenerator.HasSequences: Boolean; begin Result := True; end; function TMVCSQLGenerator.MergeDefaultRQLFilter(const RQL: String): String; var lRQLFilterPart, lRQLSortingAndLimitPart: String; lSemicolonPos: Integer; begin lRQLFilterPart := RQL; lRQLSortingAndLimitPart := ''; lSemicolonPos := RQL.IndexOf(';'); if lSemicolonPos > -1 then begin lRQLFilterPart := RQL.Substring(0, lSemicolonPos); lRQLSortingAndLimitPart := RQL.Substring(lSemicolonPos + 1, 1000); end; {this is not the best solution, but it works...} if lRQLFilterPart.Contains('sort') or lRQLFilterPart.Contains('limit') then begin lRQLSortingAndLimitPart := lRQLFilterPart; lRQLFilterPart := ''; end; if (not fDefaultRQLFilter.IsEmpty) or (not fPartitionInfo.RQLFilter.IsEmpty) then begin Result := 'and('; if not fDefaultRQLFilter.IsEmpty then begin Result := Result + fDefaultRQLFilter; end; if not fPartitionInfo.RQLFilter.IsEmpty then begin Result := Result + ',' + fPartitionInfo.RQLFilter; end; if not lRQLFilterPart.IsEmpty then begin Result := Result + ',' + lRQLFilterPart; end; Result := Result + ')'; end else begin Exit(RQL); end; if not lRQLSortingAndLimitPart.IsEmpty then begin Result := Result + ';' + lRQLSortingAndLimitPart; end; // // var Pieces := RQL.Split([';']); // if Pieces[0].Trim.Length > 0 then // begin // Result := 'and('+fDefaultRQLFilter + ',' + Pieces[0] + ');' + string.Join(';', Pieces, 1, Length(Pieces)-1); // end // else // begin // Result := fDefaultRQLFilter + ';' + string.Join(';', Pieces, 1, Length(Pieces)-1); // end; // end // // // // if not fDefaultRQLFilter.IsEmpty then // begin // if RQL.Contains(';') then // begin // var Pieces := RQL.Split([';']); // if Pieces[0].Trim.Length > 0 then // begin // Result := 'and('+fDefaultRQLFilter + ',' + Pieces[0] + ');' + string.Join(';', Pieces, 1, Length(Pieces)-1); // end // else // begin // Result := fDefaultRQLFilter + ';' + string.Join(';', Pieces, 1, Length(Pieces)-1); // end; // end // else // begin // if RQL.IsEmpty then // begin // Result := fDefaultRQLFilter // end // else // begin // Result := MergeRQL(Result, fPartitionInfo.RQLFilter); // end; // //Result := 'and('+fDefaultRQLFilter + ',' + RQL + ')'; // end; // end // else // begin // Result := RQL; // end; // Result := MergeRQL(Result, fPartitionInfo.RQLFilter); end; function TMVCSQLGenerator.MergeSQLFilter(const SQL1, SQL2: String): String; begin if SQL1 + SQL2 = '' then begin Exit(''); end; if SQL1.IsEmpty and (not SQL2.IsEmpty) then begin Exit(SQL2); end; if SQL2.IsEmpty and (not SQL1.IsEmpty) then begin Exit(SQL1); end; Result := '((' + SQL1 + ') and (' + SQL2 + '))'; end; class function TMVCSQLGenerator.RemoveInitialWhereKeyword( const SQLFilter: String): String; begin Result := SQLFilter.TrimLeft; if Result.StartsWith('where', true) then begin Result := Result.Remove(0, 5); end; end; function TMVCSQLGenerator.TableFieldsDelimited(const Map: TFieldsMap; const PKFieldName: string; const Delimiter: string): string; var lPair: TPair; begin for lPair in Map do begin // if not lPair.Value.FieldName.IsEmpty then if lPair.Value.Readable then begin Result := Result + GetFieldNameForSQL(lPair.Value.FieldName) + Delimiter; end; end; Result := Copy(Result, 1, Length(Result) - Length(Delimiter)); if not PKFieldName.IsEmpty then begin if not Result.IsEmpty then begin Result := GetFieldNameForSQL(PKFieldName) + ', ' + Result end else begin Result := GetFieldNameForSQL(PKFieldName) end; end; end; { TMVCConnectionsRepository.TConnHolder } destructor TMVCConnectionsRepository.TConnHolder.Destroy; begin if OwnsConnection then begin if Connection.Connected then Connection.Connected := false; FreeAndNil(Connection); end; inherited; end; constructor MVCTableFieldAttribute.Create(const aFieldName: string; const aFieldOptions: TMVCActiveRecordFieldOptions; const aSequenceName: string; const aDataTypeName: string); begin inherited Create; FieldName := aFieldName; FieldOptions := aFieldOptions; SequenceName := aSequenceName; DataTypeName := aDataTypeName; end; { EMVCActiveRecordNotFound } procedure EMVCActiveRecordNotFound.AfterConstruction; begin inherited; fHttpErrorCode := http_status.NotFound; end; class function TMVCActiveRecord.ExecQuery( const SQL: string; const Values: array of Variant; const ValueTypes: array of TFieldType; const Connection: TFDConnection; const Unidirectional: Boolean): TDataSet; var lQry: TFDQuery; begin lQry := TFDQuery.Create(nil); try lQry.FetchOptions.Unidirectional := Unidirectional; // True; lQry.UpdateOptions.ReadOnly := True; if Connection = nil then begin lQry.Connection := ActiveRecordConnectionsRegistry.GetCurrent; end else begin lQry.Connection := Connection; end; lQry.SQL.Text := SQL; // lQry.Prepare; if Length(ValueTypes) = 0 then begin lQry.Open(SQL, Values); end else begin lQry.Open(SQL, Values, ValueTypes); end; Result := lQry; except lQry.Free; raise; end; end; class function TMVCActiveRecord.ExecQuery(const SQL: string; const Values: array of Variant; const ValueTypes: array of TFieldType; const Unidirectional: Boolean): TDataSet; begin Result := ExecQuery(SQL, Values, ValueTypes, nil, Unidirectional); end; { TFieldsMap } constructor TFieldsMap.Create; begin inherited Create([doOwnsValues]); fWritableFieldsCount := -1; fReadableFieldsCount := -1; end; procedure TFieldsMap.EndUpdates; var lPair: TPair; begin fWritableFieldsCount := 0; fReadableFieldsCount := 0; for lPair in Self do begin lPair.Value.EndUpdates; // if not(foTransient in lPair.Value.FieldOptions) then if lPair.Value.Writeable then begin Inc(fWritableFieldsCount); end; if lPair.Value.Readable then begin Inc(fReadableFieldsCount); end; end; end; function TFieldsMap.GetInfoByFieldName(const FieldName: string): TFieldInfo; var lPair: TPair; begin for lPair in Self do begin if SameText(FieldName, lPair.Value.FieldName) then begin Result := Items[lPair.Key]; Exit; end; end; raise EMVCActiveRecord.CreateFmt('FieldName [%s] not found in table', [FieldName]); end; { TFieldInfo } procedure TFieldInfo.EndUpdates; begin if FieldName.IsEmpty then begin Writeable := false; Readable := false; end else begin // Writeable := (not (foReadOnly in FieldOptions)) and (not((foAutoGenerated in FieldOptions) or (foTransient in FieldOptions))); Writeable := ((FieldOptions * [foReadOnly, foTransient, foAutoGenerated]) = []); // Readable := (not (foWriteOnly in FieldOptions)) and (not(foTransient in FieldOptions)); Readable := (FieldOptions * [foWriteOnly, foTransient]) = []; end; end; { TMVCUnitOfWork } procedure TMVCUnitOfWork.Apply(const ItemApplyAction: TMVCItemApplyAction); var i: Integer; lHandled: Boolean; begin for i := 0 to fListToInsert.Count - 1 do begin lHandled := false; DoItemApplyAction(fListToInsert[i], eaCreate, ItemApplyAction, lHandled); if not lHandled then begin fListToInsert[i].Insert; end; end; for i := 0 to fListToUpdate.Count - 1 do begin lHandled := false; DoItemApplyAction(fListToUpdate[i], eaUpdate, ItemApplyAction, lHandled); if not lHandled then begin fListToUpdate[i].Update(True); end; end; for i := 0 to fListToDelete.Count - 1 do begin lHandled := false; DoItemApplyAction(fListToDelete[i], eaDelete, ItemApplyAction, lHandled); if not lHandled then begin fListToDelete[i].Delete(True); end; end; end; constructor TMVCUnitOfWork.Create; begin inherited; fListToDelete := TObjectList.Create(false); fListToUpdate := TObjectList.Create(false); fListToInsert := TObjectList.Create(false); end; destructor TMVCUnitOfWork.Destroy; begin fListToDelete.Free; fListToUpdate.Free; fListToInsert.Free; inherited; end; procedure TMVCUnitOfWork.DoItemApplyAction(const Obj: TMVCActiveRecord; const EntityAction: TMVCEntityAction; const ItemApplyAction: TMVCItemApplyAction; var Handled: Boolean); begin if Assigned(ItemApplyAction) then begin ItemApplyAction(Obj, EntityAction, Handled); end; end; class function TMVCUnitOfWork.KeyExistsInt(const NewList: TObjectList; const KeyValue: Integer; out Index: Integer): Boolean; var i: Integer; begin Result := false; for i := 0 to NewList.Count - 1 do begin if NewList[i].GetPK.AsInteger = KeyValue then begin Index := i; Exit(True); end; end; end; class function TMVCUnitOfWork.KeyExistsInt64(const NewList: TObjectList; const KeyValue: int64; out Index: Integer): Boolean; var i: Integer; begin Result := false; for i := 0 to NewList.Count - 1 do begin if (not NewList[i].PKIsNull) and (NewList[i].GetPK.AsInt64 = KeyValue) then begin Index := i; Exit(True); end; end; end; class function TMVCUnitOfWork.KeyExistsString(const NewList: TObjectList; const KeyValue: String; out Index: Integer): Boolean; var i: Integer; begin Result := false; for i := 0 to NewList.Count - 1 do begin if NewList[i].GetPK.AsString = KeyValue then begin Index := i; Exit(True); end; end; end; procedure TMVCUnitOfWork.RegisterDelete(const Value: T); begin fListToDelete.Add(Value); end; procedure TMVCUnitOfWork.RegisterDelete(const Enumerable: TEnumerable); begin fListToDelete.AddRange(Enumerable); end; procedure TMVCUnitOfWork.RegisterInsert(const Value: T); begin fListToInsert.Add(Value); end; procedure TMVCUnitOfWork.RegisterUpdate(const Value: T); var lCurrPKValue: Integer; lFoundAtIndex: Integer; begin fListToUpdate.Add(Value); lCurrPKValue := Value.GetPK.AsInteger; if KeyExistsInt(fListToDelete, lCurrPKValue, lFoundAtIndex) then begin fListToDelete.Delete(lFoundAtIndex); end; end; procedure TMVCUnitOfWork.UnregisterDelete(const Value: T); begin fListToDelete.Remove(Value); end; procedure TMVCUnitOfWork.UnregisterInsert(const Value: T); begin fListToInsert.Remove(Value); end; procedure TMVCUnitOfWork.UnregisterUpdate(const Value: T); begin fListToUpdate.Remove(Value); end; constructor MVCTableAttribute.Create(aName, aRQLFilter: String); begin inherited Create; Name := aName; RQLFilter := aRQLFilter; end; { MVCPartitionAttribute } constructor MVCPartitionAttribute.Create(const PartitionClause: String); begin inherited Create; Self.PartitionClause := PartitionClause; end; { TPartitionInfo } constructor TPartitionInfo.Create; begin inherited; fFieldNames := TPartitionFieldNames.Create; fFieldValues := TPartitionFieldValues.Create; fFieldTypes := TPartitionFieldTypes.Create; end; destructor TPartitionInfo.Destroy; begin fFieldNames.Free; fFieldValues.Free; fFieldTypes.Free; inherited; end; class destructor TPartitionInfo.Destroy; begin PartitionInfoCache.Free; end; procedure TPartitionInfo.InitializeFilterStrings( const RQLCompiler: TRQLCompiler); var lFieldCount, I: Integer; lRQL2SQL: TRQL2SQL; begin fRQLFilter := ''; lFieldCount := FieldNames.Count; if lFieldCount > 0 then begin for I := 0 to lFieldCount - 1 do begin case FieldTypes[I] of ftString: begin fRQLFilter := fRQLFilter + 'eq(' + FieldNames[i] + ',' + FieldValues[i].QuotedString('"') + '),'; end; ftInteger: begin fRQLFilter := fRQLFilter + 'eq(' + FieldNames[i] + ',' + FieldValues[i] + '),'; end; else raise ERQLException.CreateFmt('DataType for field [%s] not supported in partition clause', [fFieldNames[I]]); end; end; fRQLFilter := fRQLFilter.Remove(fRQLFilter.Length - 1,1); if lFieldCount > 1 then begin fRQLFilter := 'and(' + fRQLFilter + ')'; end; end; lRQL2SQL := TRQL2SQL.Create; try lRQL2SQL.Execute(fRQLFilter, fSQLFilter, RQLCompiler, False, True) finally lRQL2SQL.Free; end; fSQLFilter := TMVCSQLGenerator.RemoveInitialWhereKeyword(fSQLFilter); end; class function TPartitionInfo.BuildPartitionClause( const PartitionClause: String; const RQLCompilerClass: TRQLCompilerClass): TPartitionInfo; var lPieces, lItems: TArray; lPiece: String; lRQLCompiler: TRQLCompiler; begin { Needs to parse [MVCPartition('rating=(integer)4;classname=(string)persona')] } if not PartitionInfoCache.TryGetValue(PartitionClause + '|' + RQLCompilerClass.ClassName, Result) then begin lRQLCompiler := RQLCompilerClass.Create(nil); try Result := TPartitionInfo.Create; try lPieces := PartitionClause.Split([';']); for lPiece in lPieces do begin lItems := lPiece.Split(['=','(',')'], TStringSplitOptions.ExcludeEmpty); if Length(lItems)<>3 then begin raise EMVCActiveRecord.Create('Invalid partitioning clause: ' + lPiece + '. [HINT] Paritioning must be in the form: "[fieldname1=(integer|string)value1]"'); end; Result.FieldNames.Add(lItems[0]); if lItems[1]='integer' then Result.FieldTypes.Add(ftInteger) else if lItems[1]='string' then begin Result.FieldTypes.Add(ftString) end else begin raise EMVCActiveRecord.Create('Unknown data type in partitioning: ' + lItems[1] + '. [HINT] data type can be "integer" or "string"'); end; Result.FieldValues.Add(lItems[2]); end; except Result.Free; raise; end; Result.InitializeFilterStrings(lRQLCompiler); PartitionInfoCache.Add(PartitionClause + '|' + RQLCompilerClass.ClassName, Result); finally lRQLCompiler.Free; end; end; end; class constructor TPartitionInfo.Create; begin PartitionInfoCache := TMVCThreadedObjectCache.Create; end; initialization gLock := TObject.Create; gCtx := TRttiContext.Create; gCtx.FindType(''); finalization gCtx.Free; gLock.Free; end.