// *************************************************************************** } // // Delphi MVC Framework // // Copyright (c) 2010-2024 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.SysUtils, 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, MVCFramework, MVCFramework.Commons, MVCFramework.RQL.Parser, MVCFramework.Cache, MVCFramework.Serializer.Intf, MVCFramework.Serializer.Commons, System.SyncObjs, System.TypInfo; type EMVCActiveRecord = class(EMVCException) public constructor Create(const AMsg: string); reintroduce; { do not override!! } end; EMVCActiveRecordNotFound = class(EMVCActiveRecord) public procedure AfterConstruction; override; end; EMVCActiveRecordVersionedItemNotFound = class(EMVCActiveRecordNotFound) end; TMVCActiveRecordClass = class of TMVCActiveRecord; TMVCActiveRecord = class; TMVCActiveRecordFieldOption = ( /// /// It's the primary key of the mapped table } /// foPrimaryKey, /// /// Not written, read - similar to readonly - is updated after insert and update /// foAutoGenerated, /// /// shortcut for --> Insertable := False; Updatable := False; Selectable := True; /// foReadOnly, /// /// used for versioning, only one field with foVersion is allowed in class /// foVersion, /// /// not included in SQL SELECT commands /// foDoNotSelect, /// /// not included in SQL INSERT commands /// foDoNotInsert, /// /// not included in SQL UPDATE commands /// foDoNotUpdate ); 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 FieldName: string; FieldOptions: TMVCActiveRecordFieldOptions; DataTypeName: string; Selectable, Insertable, Updatable, IsVersion: Boolean; procedure EndUpdates; end; TSQLQueryWithName = record Name: String; SQLText: String; BackEnd: String; //TMVCActiveRecordBackEnd end; TRQLQueryWithName = record Name: String; RQLText: String; 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; MVCNamedSQLQueryAttribute = class(MVCActiveRecordCustomAttribute) public Name: string; SQLQuery: String; Backend: String; //TMVCActiveRecordBackEnd constructor Create(aName: string; aSQLSelect: String); overload; constructor Create(aName: string; aSQLSelect: String; aBackEnd: String); overload; end; MVCNamedRQLQueryAttribute = class(MVCActiveRecordCustomAttribute) public Name: string; RQLQuery: String; constructor Create(aName: string; aRQL: 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; TMVCTableMap = class private fVersionRTTIField: TRttiField; fVersionFieldName: String; public fPartitionInfoInternal: TPartitionInfo; fEntityAllowedActions: TMVCEntityActions; fTableName: String; fIsVersioned: Boolean; fPartitionClause: String; fRTTIType: TRttiInstanceType; fObjAttributes: TArray; fDefaultRQLFilter: string; fMap: TFieldsMap; fPrimaryKey: TRTTIField; fMapping: TMVCFieldsMapping; fPropsAttributes: TArray; fProps: TArray; fPrimaryKeyFieldName: string; fPrimaryKeyOptions: TMVCActiveRecordFieldOptions; fPrimaryKeySequenceName: string; fPrimaryKeyFieldType: TFieldType; fNamedSQLQueries: TArray; fNamedRQLQueries: TArray; public constructor Create; destructor Destroy; override; function VersionValueAsInt64For(AR: TMVCActiveRecord): Int64; //inline; end; TMVCActiveRecord = class private fChildren: TObjectList; fConn: TFDConnection; fSQLGenerator: TMVCSQLGenerator; 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); function GetAttributes(const AttrName: string): TValue; procedure SetAttributes(const AttrName: string; const Value: TValue); function GetTableName: string; procedure AdvanceVersioning(const TableMap: TMVCTableMap; const ARInstance: TMVCActiveRecord); procedure SetInitialObjVersion(const TableMap: TMVCTableMap; const ARInstance: TMVCActiveRecord); protected fBackendDriver: string; fTableMap: TMVCTableMap; function GetCustomTableName: String; virtual; function GetPartitionInfo: TPartitionInfo; function GetConnection: TFDConnection; procedure InitTableInfo(const aTableName: String); class function ExecQuery( const SQL: string; const Values: array of Variant; const Unidirectional: Boolean; const DirectExecute: Boolean): TDataSet; overload; class function ExecQuery( const SQL: string; const Values: array of Variant; const Connection: TFDConnection; const Unidirectional: Boolean; const DirectExecute: Boolean) : TDataSet; overload; class function ExecQuery( const SQL: string; const Values: array of Variant; const ValueTypes: array of TFieldType; const Unidirectional: Boolean; const DirectExecute: 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; const DirectExecute: 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; // 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; overload; function InternalSelectRQL(const RQL: string; const MaxRecordCount: Integer; const OutList: TMVCActiveRecordList): UInt32; overload; public constructor Create(aLazyLoadConnection: Boolean); overload; // cannot be virtual! constructor Create; overload; virtual; destructor Destroy; override; procedure EnsureConnection; procedure Assign(ActiveRecord: TMVCActiveRecord); virtual; procedure InvalidateConnection(const ReacquireAfterInvalidate: Boolean = false); function GetBackEnd: string; /// /// Executes an Insert (pk is null) or an Update (pk is not null) /// procedure Store; /// /// Reload the current instance from database if the primary key is not empty. /// procedure Refresh; virtual; 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; function FindSQLQueryByName(const QueryName: String; out NamedSQLQuery: TSQLQueryWithName): Boolean; function FindRQLQueryByName(const QueryName: String; out NamedRQLQuery: TRQLQueryWithName): Boolean; property Attributes[const AttrName: string]: TValue read GetAttributes write SetAttributes; [MVCDoNotSerialize] property TableName: string read GetTableName; [MVCDoNotSerialize] property PrimaryKeyIsAutogenerated: Boolean read GetPrimaryKeyIsAutogenerated write SetPrimaryKeyIsAutogenerated; class function GetScalar(const SQL: string; const Params: array of Variant): Variant; 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); TMergeModeItem = (mmInsert, mmUpdate, mmDelete); TMergeMode = set of TMergeModeItem; IMVCMultiExecutor = interface ['{C815246B-19CA-4F6C-AA67-8E491F809340}'] procedure Apply(const ItemApplyAction: TMVCItemApplyAction = nil); end; TMVCActiveRecordHelper = class helper for TMVCActiveRecord { GetByPK } 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 GetByPK(const aValue: string; const aFieldType: TFieldType; const RaiseExceptionIfNotFound: Boolean): T; overload; 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; { Select } /// /// Returns a TObjectList from a SQL using variant params /// class function Select(const SQL: string; const Params: array of Variant; const Options: TMVCActiveRecordLoadOptions = []): TObjectList; overload; /// /// Returns a TObjectList from a SQL using typed params /// class function Select( const SQL: string; const Params: array of Variant; const ParamTypes: array of TFieldType; const Options: TMVCActiveRecordLoadOptions = []) : TObjectList; overload; /// /// Returns a TMVCActiveRecordList from a SQL using typed params and class ref /// class function Select( const MVCActiveRecordClass: TMVCActiveRecordClass; const SQL: string; const Params: array of Variant; const ParamTypes: array of TFieldType; const Options: TMVCActiveRecordLoadOptions = []) : TMVCActiveRecordList; overload; /// /// Fills a TObjectList from a SQL using typed params. /// Returns number of the records in the list (not only the selected records, but the current .Count of the list) /// class function Select( const SQL: string; const Params: array of Variant; const ParamTypes: array of TFieldType; const Options: TMVCActiveRecordLoadOptions; const OutList: TObjectList): UInt32; overload; class function Select( const MVCActiveRecordClass: TMVCActiveRecordClass; const SQL: string; const Params: array of Variant; const ParamTypes: array of TFieldType; const Options: TMVCActiveRecordLoadOptions; const OutList: TMVCActiveRecordList): UInt32; overload; 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 Select(const aClass: TMVCActiveRecordClass; const SQL: string; const Params: array of Variant; const Connection: TFDConnection; const OutList: TMVCActiveRecordList): UInt32; overload; { SelectOne } 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; { SelectRQL } function SelectRQL(const RQL: string; const MaxRecordCount: Integer) : TMVCActiveRecordList; overload; class function SelectRQL(const RQL: string; const MaxRecordCount: Integer) : TObjectList; overload; class function SelectRQL(const RQL: string; const MaxRecordCount: Integer; const OutList: TObjectList): UInt32; overload; class function SelectOneByRQL(const RQL: string; const RaiseExceptionIfNotFound: Boolean = True): T; overload; class function SelectRQL(const aClass: TMVCActiveRecordClass; const RQL: string; const MaxRecordCount: Integer) : TMVCActiveRecordList; overload; class function SelectRQL(const aClass: TMVCActiveRecordClass; const RQL: string; const MaxRecordCount: Integer; const OutList: TMVCActiveRecordList): UInt32; overload; { Misc } class function All: TObjectList; overload; class function DeleteRQL(const RQL: string = ''): Int64; overload; class function Count(const RQL: string = ''): Int64; overload; { Where } 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 Where(const SQLWhere: string; const Params: array of Variant; const ParamTypes: array of TFieldType; const OutList: TObjectList): UInt32; 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 Where( const aClass: TMVCActiveRecordClass; const SQLWhere: string; const Params: array of Variant; const Connection: TFDConnection; const OutList: TMVCActiveRecordList): UInt32; overload; { GetXXXByWhere } 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; { Merge } class function Merge(CurrentList, NewList: TObjectList; const MergeMode: TMergeMode = [mmInsert, mmUpdate, mmDelete]): IMVCMultiExecutor; { Misc } class function All(const aClass: TMVCActiveRecordClass): TObjectList; overload; class function All(const aQualifiedClassName: String): TObjectList; overload; class function DeleteAll(const aClass: TMVCActiveRecordClass): Int64; overload; class function DeleteRQL(const aClass: TMVCActiveRecordClass; const RQL: string): Int64; overload; function Count(const RQL: string = ''): Int64; overload; class function Count(const aClass: TMVCActiveRecordClass; const RQL: string = '') : int64; overload; { SelectDataSet } class function SelectDataSet(const SQL: string; const Params: array of Variant; const Unidirectional: Boolean = False; const DirectExecute: Boolean = False): TDataSet; overload; class function SelectDataSet(const SQL: string; const Params: array of Variant; const ParamTypes: array of TFieldType; const Unidirectional: Boolean = False; const DirectExecute: Boolean = False): TDataSet; overload; { NamedQuery} class function SelectByNamedQuery( const QueryName: String; const Params: array of Variant; const ParamTypes: array of TFieldType; const Options: TMVCActiveRecordLoadOptions = []): TObjectList; overload; class function SelectByNamedQuery( const MVCActiveRecordClass: TMVCActiveRecordClass; const QueryName: String; const Params: array of Variant; const ParamTypes: array of TFieldType; const Options: TMVCActiveRecordLoadOptions = []): TMVCActiveRecordList; overload; class function SelectRQLByNamedQuery( const QueryName: String; const Params: array of const; const MaxRecordCount: Integer): TObjectList; overload; class function SelectRQLByNamedQuery( const MVCActiveRecordClass: TMVCActiveRecordClass; const QueryName: String; const Params: array of const; const MaxRecordCount: Integer): TMVCActiveRecordList; overload; class function DeleteRQLByNamedQuery( const QueryName: String; const Params: array of const): Int64; class function CountRQLByNamedQuery( const QueryName: string; const Params: array of const): Int64; class function TryGetSQLQuery( const QueryName: String; out NamedSQLQuery: TSQLQueryWithName): Boolean; overload; class function TryGetRQLQuery( const QueryName: String; out NamedRQLQuery: TRQLQueryWithName): Boolean; { RTTI } class function CreateMVCActiveRecord(AQualifiedClassName: string; const AParams: TArray = nil): T; 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; IMVCActiveRecordTableMap = interface ['{517A863F-8BAD-4F66-A520-205149228360}'] procedure AddTableMap(const AR: TMVCActiveRecord; const TableName: String; var TableMap: TMVCTableMap); function TryGetValue(const AR: TMVCActiveRecord; const TableName: String; out TableMap: TMVCTableMap): Boolean; procedure ExecWithExclusiveLock(Proc: TProc); procedure FlushCache; end; IMVCActiveRecordConnections = interface ['{7B87473C-1784-489F-A838-925E7DDD0DE2}'] procedure AddConnection(const aName: string; const aConnection: TFDConnection; const Owns: Boolean = false); overload; procedure AddDefaultConnection(const aConnection: TFDConnection; const Owns: Boolean = false); overload; procedure AddDefaultConnection(const aConnectionDefName: String); overload; procedure AddConnection(const aName, 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 GetCurrentConnectionName(const RaiseExceptionIfNotAvailable: Boolean = False): String; 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); overload; procedure AddConnection(const aName, aConnectionDefName: String); overload; 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 GetCurrentConnectionName(const RaiseExceptionIfNotAvailable: Boolean = False): String; function GetByName(const aName: string): TFDConnection; function GetCurrentBackend: string; procedure SetDefault; end; TMVCTableMapRepository = class(TInterfacedObject, IMVCActiveRecordTableMap) private fMREW: TMultiReadExclusiveWriteSynchronizer; fTableMapDict: TObjectDictionary; function GetCacheKey(const AR: TMVCActiveRecord; const TableName: String): String; inline; protected procedure AddTableMap(const AR: TMVCActiveRecord; const TableName: String; var TableMap: TMVCTableMap); function TryGetValue(const AR: TMVCActiveRecord; const TableName: String; out TableMap: TMVCTableMap): Boolean; procedure ExecWithExclusiveLock(Proc: TProc); procedure FlushCache; public constructor Create; virtual; destructor Destroy; override; 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 PartitionSQL, FilteringSQL: 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; function HasNativeUUID: 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 TableMap: TMVCTableMap; const ARInstance: TMVCActiveRecord): 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 TableMap: TMVCTableMap; const ARInstance: TMVCActiveRecord): string; virtual; function CreateDeleteAllSQL(const TableName: string): string; virtual; function CreateSelectCount(const TableName: string): string; virtual; function CreateUpdateSQL(const TableMap: TMVCTableMap; const ARInstance: TMVCActiveRecord): 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; TMVCActiveRecordBackEnd = record public const Unknown = 'unknown'; Oracle = 'oracle'; MSSql = 'mssql'; MSAccess = 'msaccess'; MySQL ='mysql'; DB2 = 'db2'; SQLAnywhere = 'sqlanywhere'; Advantage = 'advantage'; Interbase = 'interbase'; FirebirdSQL = 'firebird'; SQLite = 'sqlite'; PostgreSQL = 'postgresql'; NexusDB = 'nexusdb'; DataSnap = 'dataSnap'; Informix = 'informix'; Teradata = 'teradata'; MongoDB = 'mongodb'; Other = 'other'; end; function ActiveRecordConnectionsRegistry: IMVCActiveRecordConnections; function ActiveRecordTableMapRegistry: IMVCActiveRecordTableMap; function ActiveRecordMappingRegistry: IMVCEntitiesRegistry; function GetBackEndByConnection(aConnection: TFDConnection): string; const OBJECT_VERSION_STARTING_VALUE = '1'; OBJECT_VERSION_STARTING_VALUE_AS_INT: Int64 = 1; implementation uses System.IOUtils, System.Classes, MVCFramework.DataSet.Utils, MVCFramework.Logger, MVCFramework.Nullables, MVCFramework.RTTI.Utils, FireDAC.Stan.Option, Data.FmtBcd, System.Variants, System.Math; var gCtx: TRttiContext; gEntitiesRegistry: IMVCEntitiesRegistry; gConnections: IMVCActiveRecordConnections; gConnectionsLock: TObject; gTableMap: IMVCActiveRecordTableMap; gTableMapLock: TObject; function GetBackEndByConnection(aConnection: TFDConnection): string; begin if not aConnection.Connected then begin aConnection.Connected := True; {required to know the backend} end; case Ord(aConnection.RDBMSKind) of 0: Exit(TMVCActiveRecordBackEnd.Unknown); 1: Exit(TMVCActiveRecordBackEnd.Oracle); 2: Exit(TMVCActiveRecordBackEnd.MSSql); 3: Exit(TMVCActiveRecordBackEnd.MSAccess); 4: Exit(TMVCActiveRecordBackEnd.MySQL); 5: Exit(TMVCActiveRecordBackEnd.DB2); 6: Exit(TMVCActiveRecordBackEnd.SQLAnywhere); 7: Exit(TMVCActiveRecordBackEnd.Advantage); 8: Exit(TMVCActiveRecordBackEnd.Interbase); 9: Exit(TMVCActiveRecordBackEnd.FirebirdSQL); 10: Exit(TMVCActiveRecordBackEnd.SQLite); 11: Exit(TMVCActiveRecordBackEnd.PostgreSQL); 12: Exit(TMVCActiveRecordBackEnd.NexusDB); 13: Exit(TMVCActiveRecordBackEnd.DataSnap); 14: Exit(TMVCActiveRecordBackEnd.Informix); 15: Exit(TMVCActiveRecordBackEnd.Teradata); 16: Exit(TMVCActiveRecordBackEnd.MongoDB); 17: Exit(TMVCActiveRecordBackEnd.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 ActiveRecordTableMapRegistry: IMVCActiveRecordTableMap; begin if gTableMap = nil then // double check here begin TMonitor.Enter(gTableMapLock); try if gTableMap = nil then begin gTableMap := TMVCTableMapRepository.Create; end; finally TMonitor.Exit(gTableMapLock); end; end; Result := gTableMap; 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.AddConnection(const aName, aConnectionDefName: String); var lConn: TFDConnection; begin lConn := TFDConnection.Create(nil); try lConn.ConnectionDefName := aConnectionDefName; AddConnection(aName, lConn, True); except on E: Exception do begin lConn.Free; raise; end; end; end; procedure TMVCConnectionsRepository.AddDefaultConnection(const aConnectionDefName: String); begin AddConnection('default', aConnectionDefName); 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.GetCurrentConnectionName( const RaiseExceptionIfNotAvailable: Boolean): String; var lName: string; begin {$IF not Defined(TokyoOrBetter)} Result := ''; {$ENDIF} fMREW.BeginRead; try if fCurrentConnectionsByThread.TryGetValue(TThread.CurrentThread.ThreadID, lName) then begin Result := lName; end else begin if RaiseExceptionIfNotAvailable then raise EMVCActiveRecord.Create('No current connection for thread') else Result := ''; end; 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; fCurrentConnectionsByThread.Remove(TThread.CurrentThread.ThreadID); 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; 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]; MapTValueToParam(lValue, lPar); end end; { end-partitioning } for lPair in fTableMap.fMap do begin lPar := lQry.FindParam(SQLGenerator.GetParamNameForSQL(lPair.Value.FieldName)); if lPar <> nil then begin lValue := lPair.Key.GetValue(Self); lPar.DataTypeName := fTableMap.fMap.GetInfoByFieldName(lPair.Value.FieldName).DataTypeName; MapTValueToParam(lValue, lPar); end end; // Check if it's the primary key lPar := lQry.FindParam(SQLGenerator.GetParamNameForSQL(fTableMap.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(fTableMap.fPrimaryKey.GetValue(Self), lPar); end; end; if RefreshAutoGenerated and (TMVCActiveRecordFieldOption.foAutoGenerated in fTableMap.fPrimaryKeyOptions) and fTableMap.fPrimaryKeySequenceName.IsEmpty then begin lValue := fTableMap.fPrimaryKey.GetValue(Self); lQry.Open; if (lValue.Kind = tkRecord) then begin MapDataSetFieldToNullableRTTIField(lValue, lQry.Fields[0], fTableMap.fPrimaryKey, Self); end else begin lValue := lQry.FieldByName(fTableMap.fPrimaryKeyFieldName).AsInteger; fTableMap.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; const DirectExecute: Boolean): TDataSet; begin Result := ExecQuery(SQL, Values, [], Connection, Unidirectional, DirectExecute); end; procedure TMVCActiveRecord.FillPrimaryKey(const SequenceName: string); var lDS: TDataSet; lSQL: string; begin if not SequenceName.IsEmpty then begin lSQL := SQLGenerator.GetSequenceValueSQL(fTableMap.fPrimaryKeyFieldName, SequenceName); if lSQL.IsEmpty then begin Exit; end; lDS := ExecQuery(lSQL, [], True, False); try MapDataSetFieldToRTTIField(lDS.Fields[0], fTableMap.fPrimaryKey, Self); finally lDS.Free; end; end; end; function TMVCActiveRecord.FindRQLQueryByName(const QueryName: String; out NamedRQLQuery: TRQLQueryWithName): Boolean; var I: Integer; begin for I := Low(fTableMap.fNamedRQLQueries) to High(fTableMap.fNamedRQLQueries) do begin if SameText(QueryName, fTableMap.fNamedRQLQueries[I].Name) then begin NamedRQLQuery := fTableMap.fNamedRQLQueries[I]; Exit(True); end; end; Result := False; end; function TMVCActiveRecord.FindSQLQueryByName(const QueryName: String; out NamedSQLQuery: TSQLQueryWithName): Boolean; var I: Integer; lBackEnd: String; begin for I := Low(fTableMap.fNamedSQLQueries) to High(fTableMap.fNamedSQLQueries) do begin if SameText(QueryName, fTableMap.fNamedSQLQueries[I].Name) then begin lBackEnd := fTableMap.fNamedSQLQueries[I].BackEnd; if lBackEnd.IsEmpty or (lBackEnd = GetBackEnd) then begin NamedSQLQuery := fTableMap.fNamedSQLQueries[I]; Exit(True); end; end; end; Result := False; end; class function TMVCActiveRecord.ExecQuery(const SQL: string; const Values: array of Variant; const Unidirectional: Boolean; const DirectExecute: Boolean): TDataSet; begin Result := ExecQuery(SQL, Values, nil, Unidirectional, DirectExecute); end; procedure TMVCActiveRecord.InitTableInfo(const aTableName: String); var lAttribute: TCustomAttribute; lRTTIField: TRTTIField; lFieldInfo: TFieldInfo; lPrimaryFieldTypeAsStr: string; lTableMap: TMVCTableMap; lPKCount: Integer; lNamedSQLQueryCount: Integer; lNamedRQLQueryCount: Integer; lNeedsTableName: Boolean; begin if ActiveRecordTableMapRegistry.TryGetValue(Self, aTableName, fTableMap) then begin Exit; end; TMonitor.Enter(gTableMapLock); try if ActiveRecordTableMapRegistry.TryGetValue(Self, aTableName, fTableMap) then //double check here begin Exit; end; lTableMap := TMVCTableMap.Create; SetLength(lTableMap.fMapping, 0); lTableMap.fPartitionInfoInternal := nil; lTableMap.fEntityAllowedActions := [TMVCEntityAction.eaCreate, TMVCEntityAction.eaRetrieve, TMVCEntityAction.eaUpdate, TMVCEntityAction.eaDelete]; lTableMap.fTableName := aTableName; lTableMap.fPartitionClause := ''; lTableMap.fRTTIType := gCtx.GetType(Self.ClassInfo) as TRttiInstanceType; lTableMap.fObjAttributes := lTableMap.fRTTIType.GetAttributes; lPKCount := 0; lNeedsTableName := lTableMap.fTableName.IsEmpty; lNamedSQLQueryCount := Length(lTableMap.fNamedSQLQueries); lNamedRQLQueryCount := Length(lTableMap.fNamedRQLQueries); for lAttribute in lTableMap.fObjAttributes do begin if lNeedsTableName and (lAttribute is MVCTableAttribute) then begin lTableMap.fTableName := MVCTableAttribute(lAttribute).Name; lTableMap.fDefaultRQLFilter := MVCTableAttribute(lAttribute).RQLFilter; Continue; end; if lAttribute is MVCEntityActionsAttribute then begin lTableMap.fEntityAllowedActions := MVCEntityActionsAttribute(lAttribute).EntityAllowedActions; Continue; end; if lAttribute is MVCPartitionAttribute then begin lTableMap.fPartitionClause := MVCPartitionAttribute(lAttribute).PartitionClause; Continue; end; if lAttribute is MVCNamedSQLQueryAttribute then begin Inc(lNamedSQLQueryCount); SetLength(lTableMap.fNamedSQLQueries, lNamedSQLQueryCount); lTableMap.fNamedSQLQueries[lNamedSQLQueryCount - 1].Name := MVCNamedSQLQueryAttribute(lAttribute).Name; lTableMap.fNamedSQLQueries[lNamedSQLQueryCount - 1].SQLText := MVCNamedSQLQueryAttribute(lAttribute).SQLQuery; lTableMap.fNamedSQLQueries[lNamedSQLQueryCount - 1].BackEnd := MVCNamedSQLQueryAttribute(lAttribute).Backend; Continue; end; if lAttribute is MVCNamedRQLQueryAttribute then begin Inc(lNamedRQLQueryCount); SetLength(lTableMap.fNamedRQLQueries, lNamedRQLQueryCount); lTableMap.fNamedRQLQueries[lNamedRQLQueryCount - 1].Name := MVCNamedRQLQueryAttribute(lAttribute).Name; lTableMap.fNamedRQLQueries[lNamedRQLQueryCount - 1].RQLText := MVCNamedRQLQueryAttribute(lAttribute).RQLQuery; Continue; end; end; if lTableMap.fTableName = '' then begin if [eaCreate, eaUpdate, eaDelete] * lTableMap.fEntityAllowedActions <> [] then begin raise Exception.Create('Cannot find MVCTable attribute nor a valid "GetCustomTableName" method on class "' + ClassName + '" - [HINT] Is ' + ClassName + ' class decorated with MVCTable and its fields with MVCTableField?'); end; end; lTableMap.fProps := lTableMap.fRTTIType.GetFields; for lRTTIField in lTableMap.fProps do begin lTableMap.fPropsAttributes := lRTTIField.GetAttributes; if Length(lTableMap.fPropsAttributes) = 0 then Continue; for lAttribute in lTableMap.fPropsAttributes do begin if lAttribute is MVCTableFieldAttribute then begin if foPrimaryKey in MVCTableFieldAttribute(lAttribute).FieldOptions then begin lTableMap.fPrimaryKey := lRTTIField; lPrimaryFieldTypeAsStr := lTableMap.fPrimaryKey.FieldType.ToString.ToLowerInvariant; if lPrimaryFieldTypeAsStr.EndsWith('int64') then begin lTableMap.fPrimaryKeyFieldType := ftLargeInt; end else if lPrimaryFieldTypeAsStr.EndsWith('integer') or lPrimaryFieldTypeAsStr.EndsWith('int16') or lPrimaryFieldTypeAsStr.EndsWith('int32') then begin lTableMap.fPrimaryKeyFieldType := ftInteger; end else if lPrimaryFieldTypeAsStr.EndsWith('string') then begin lTableMap.fPrimaryKeyFieldType := ftString; end else if lPrimaryFieldTypeAsStr.EndsWith('guid') then begin lTableMap.fPrimaryKeyFieldType := ftGuid; end else begin raise EMVCActiveRecord.Create ('Allowed primary key types are: (Nullable)Integer, (Nullable)Int16, (Nullable)Int32, (Nullable)Int64, (Nullable)String, GUID - found: ' + lPrimaryFieldTypeAsStr); end; lTableMap.fPrimaryKeyFieldName := MVCTableFieldAttribute(lAttribute).FieldName; lTableMap.fPrimaryKeyOptions := MVCTableFieldAttribute(lAttribute).FieldOptions; lTableMap.fPrimaryKeySequenceName := MVCTableFieldAttribute(lAttribute).SequenceName; Inc(lPKCount); Continue; end; lFieldInfo := TFieldInfo.Create; lTableMap.fMap.Add(lRTTIField, lFieldInfo); lFieldInfo.FieldName := MVCTableFieldAttribute(lAttribute).FieldName; lFieldInfo.FieldOptions := MVCTableFieldAttribute(lAttribute).FieldOptions; lFieldInfo.DataTypeName := MVCTableFieldAttribute(lAttribute).DataTypeName; if foVersion in lFieldInfo.FieldOptions then begin if not lTableMap.fVersionFieldName.IsEmpty then begin raise EMVCActiveRecord.Create('Only one version field is allowed for table - Currently at least fields [' + lTableMap.fVersionFieldName + '] and [' + lFieldInfo.FieldName + '] are marked as foVersion'); end; lTableMap.fVersionRTTIField := lRTTIField; lTableMap.fVersionFieldName := lFieldInfo.FieldName; lTableMap.fIsVersioned := True; end; end; end; end; lTableMap.fMap.EndUpdates; if (lPKCount + lTableMap.fMap.WritableFieldsCount + lTableMap.fMap.ReadableFieldsCount) = 0 then begin raise EMVCActiveRecord.Create( 'No fields nor PKs defined in class ' + ClassName + '. [HINT] Use MVCTableField in private fields'); end; if lTableMap.fIsVersioned then begin lFieldInfo := lTableMap.fMap.GetInfoByFieldName(lTableMap.fVersionFieldName); if not (lFieldInfo.Insertable and lFieldInfo.Updatable) then begin raise EMVCActiveRecord .CreateFmt('Field [%s], is marked as foVersion so must be a Read/Write field - ' + '[HINT] This constraint is valid only for the field itself, a property mapped over this field can be defined "read-only", "write-only" or "read-write"', [lTableMap.fVersionFieldName]); end; end; lTableMap.fPartitionInfoInternal := nil; ActiveRecordTableMapRegistry.AddTableMap(Self, aTableName, lTableMap); fTableMap := lTableMap; finally TMonitor.Exit(gTableMapLock); end; end; procedure TMVCActiveRecord.Insert; var SQL: string; begin CheckAction(TMVCEntityAction.eaCreate); OnValidation(TMVCEntityAction.eaCreate); OnBeforeInsert; OnBeforeInsertOrUpdate; if fTableMap.fMap.WritableFieldsCount = 0 then begin raise EMVCActiveRecord.CreateFmt ('Cannot insert an entity if no fields are writable. Class [%s] mapped on table [%s]', [ClassName, TableName]); end; if (foAutoGenerated in fTableMap.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 fTableMap.fPrimaryKeySequenceName.IsEmpty then begin raise EMVCActiveRecord.Create('SequenceName is empty for entity ' + ClassName + ' but ' + GetBackEnd + ' requires it'); end; if foReadOnly in fTableMap.fPrimaryKeyOptions then begin raise EMVCActiveRecord.Create('Cannot define a read-only primary key when a sequence is used for the class ' + ClassName); end; FillPrimaryKey(fTableMap.fPrimaryKeySequenceName); end; end; end; SQL := SQLGenerator.CreateInsertSQL(fTableMap, Self); ExecNonQuery(SQL, True); if fTableMap.fIsVersioned then begin { in case of INSERT version is defined by constants } SetInitialObjVersion(fTableMap, Self); end; OnAfterInsert; OnAfterInsertOrUpdate; end; function TMVCActiveRecord.InternalCount(const RQL: string): int64; var lSQL: string; begin lSQL := Self.SQLGenerator.CreateSelectCount(TableName); lSQL := lSQL + fSQLGenerator.CreateSQLWhereByRQL(RQL, GetMapping, false, True); Result := GetScalar(lSQL, []); end; function TMVCActiveRecord.InternalSelectRQL(const RQL: string; const MaxRecordCount: Integer; const OutList: TMVCActiveRecordList): UInt32; 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, [], nil, OutList); 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; if not aLazyLoadConnection then begin GetConnection; end; InitTableInfo(GetCustomTableName); end; function TMVCActiveRecord.GenerateSelectSQL: string; begin Result := SQLGenerator.CreateSelectSQL(TableName, fTableMap.fMap, fTableMap.fPrimaryKeyFieldName, fTableMap.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; var lFound: Boolean; begin Result := aActiveRecord; try if Result.SQLGenerator.HasNativeUUID then begin lFound := Result.LoadByPK(aValue, aFieldType) end else begin lFound := Result.LoadByPK(aValue); end; if not lFound then begin if RaiseExceptionIfNotFound then raise EMVCActiveRecordNotFound.Create('No data found') else FreeAndNil(Result); end; except FreeAndNil(Result); raise; end; end; class function TMVCActiveRecordHelper.GetByPK(const aClass: TMVCActiveRecordClass; const aValue: string; const RaiseExceptionIfNotFound: Boolean): TMVCActiveRecord; begin Result := GetByPK(aClass.Create, aValue, ftString, RaiseExceptionIfNotFound); end; class function TMVCActiveRecordHelper.GetByPK(const aClass: TMVCActiveRecordClass; const aValue: int64; const RaiseExceptionIfNotFound: Boolean): TMVCActiveRecord; begin Result := GetByPK(aClass.Create, aValue.ToString, ftInteger, RaiseExceptionIfNotFound); end; class function TMVCActiveRecordHelper.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.GetByPK(const aValue: string; const aFieldType: TFieldType; const RaiseExceptionIfNotFound: Boolean): T; begin Result := T(GetByPK(T.Create, aValue, aFieldType, 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; lPropFromField: TRttiProperty; lParentType: TRttiType; lTmp: String; 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(fTableMap.fMapping) = 0 then begin if not fTableMap.fPrimaryKeyFieldName.IsEmpty then begin lParentType := fTableMap.fPrimaryKey.Parent; SetLength(fTableMap.fMapping, fTableMap.fMap.Count + 1); fTableMap.fMapping[0].InstanceFieldName := fTableMap.fPrimaryKey.Name.Substring(1).ToLower; fTableMap.fMapping[0].DatabaseFieldName := fTableMap.fPrimaryKeyFieldName; lPropFromField := lParentType.GetProperty(fTableMap.fPrimaryKey.Name.Substring(1)); if Assigned(lPropFromField) then begin lTmp := TMVCSerializerHelper.GetKeyName(lPropFromField, lParentType); if not SameText(lTmp, fTableMap.fMapping[0].InstanceFieldName) then begin fTableMap.fMapping[0].Alias := lTmp; end; end; I := 1; end else begin SetLength(fTableMap.fMapping, fTableMap.fMap.Count); I := 0; end; for lPair in fTableMap.fMap do begin lParentType := lPair.Key.Parent; fTableMap.fMapping[I].InstanceFieldName := lPair.Key.Name.Substring(1).ToLower; fTableMap.fMapping[I].DatabaseFieldName := lPair.Value.FieldName; lPropFromField := lParentType.GetProperty(lPair.Key.Name.Substring(1)); if Assigned(lPropFromField) then begin lTmp := TMVCSerializerHelper.GetKeyName(lPropFromField, lParentType); if not SameText(lTmp, fTableMap.fMapping[I].InstanceFieldName) then begin fTableMap.fMapping[I].Alias := lTmp; end; end; Inc(I); end; end; Result := fTableMap.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; class function TMVCActiveRecordHelper.SelectRQL(const RQL: string; const MaxRecordCount: Integer; const OutList: TObjectList): UInt32; 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, [], [], OutList); finally lAR.Free; end; end; class function TMVCActiveRecordHelper.SelectRQLByNamedQuery( const MVCActiveRecordClass: TMVCActiveRecordClass; const QueryName: String; const Params: array of const; const MaxRecordCount: Integer): TMVCActiveRecordList; var lT: TMVCActiveRecord; lRQLQuery: TRQLQueryWithName; begin lT := MVCActiveRecordClass.Create; try if not lT.FindRQLQueryByName(QueryName, lRQLQuery) then begin raise EMVCActiveRecord.CreateFmt('NamedRQLQuery not found: %s', [QueryName]); end; Result := SelectRQL(MVCActiveRecordClass, Format(lRQLQuery.RQLText, Params), MaxRecordCount); finally lT.Free; end; end; class function TMVCActiveRecordHelper.SelectRQLByNamedQuery( const QueryName: string; const Params: array of const; const MaxRecordCount: Integer): TObjectList; var lT: T; lRQLQuery: TRQLQueryWithName; begin lT := T.Create; try if not lT.FindRQLQueryByName(QueryName, lRQLQuery) then begin raise EMVCActiveRecord.CreateFmt('NamedRQLQuery not found: %s', [QueryName]); end; Result := SelectRQL(Format(lRQLQuery.RQLText, Params), MaxRecordCount); finally lT.Free; end; end; class function TMVCActiveRecordHelper.Where(const SQLWhere: string; const Params: array of Variant; const ParamTypes: array of TFieldType; const OutList: TObjectList): UInt32; 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, [], OutList); end else begin if lFilter.IsEmpty then begin Result := Select(lAR.GenerateSelectSQL + ' WHERE ' + SQLWhere, Params, ParamTypes, [], OutList); end else begin Result := Select(lAR.GenerateSelectSQL + lFilter + ' AND ' + SQLWhere, Params, ParamTypes, [], OutList); end; end; finally lAR.Free; end; end; function TMVCActiveRecord.GetPartitionInfo: TPartitionInfo; var lRQLCompilerClass: TRQLCompilerClass; begin if fTableMap.fPartitionInfoInternal = nil then begin lRQLCompilerClass := TRQLCompilerRegistry.Instance.GetCompiler(GetBackEnd); fTableMap.fPartitionInfoInternal := TPartitionInfo.BuildPartitionClause(fTableMap.fPartitionClause, lRQLCompilerClass); end; Result := fTableMap.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 := fTableMap.fPrimaryKeyFieldType; end; function TMVCActiveRecord.GetPrimaryKeyIsAutogenerated: Boolean; begin Result := foAutoGenerated in fTableMap.fPrimaryKeyOptions; end; class function TMVCActiveRecord.GetScalar(const SQL: string; const Params: array of Variant): Variant; begin Result := CurrentConnection.ExecSQLScalar(SQL, Params); end; function TMVCActiveRecord.GetTableName: string; begin if Assigned(fTableMap) then begin Result := fTableMap.fTableName end else begin Result := ''; end; end; function TMVCActiveRecord.CheckAction(const aEntityAction: TMVCEntityAction; const aRaiseException: Boolean): Boolean; begin Result := aEntityAction in fTableMap.fEntityAllowedActions; if (not Result) and aRaiseException then raise EMVCActiveRecord.CreateFmt ('Action [%s] not allowed on entity [%s]. [HINT] If this isn''t the expected behavior, add the entity action in MVCEntityActions attribute.', [GetEnumName(TypeInfo(TMVCEntityAction), Ord(aEntityAction)), ClassName]) at ReturnAddress; end; class function TMVCActiveRecordHelper.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 TMVCActiveRecordHelper.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 TMVCActiveRecordHelper.CountRQLByNamedQuery( const QueryName: string; const Params: array of const): Int64; var lRQLQuery: TRQLQueryWithName; lT: T; begin lT := T.Create; try if not lT.FindRQLQueryByName(QueryName, lRQLQuery) then begin raise EMVCActiveRecord.CreateFmt('NamedRQLQuery not found: %s', [QueryName]); end; Result := Count(Format(lRQLQuery.RQLText, Params)); finally lT.Free; end; end; class function TMVCActiveRecordHelper.CreateMVCActiveRecord( AQualifiedClassName: string; const AParams: TArray): T; var lTmp: TObject; begin lTmp := TRttiUtils.CreateObject(AQualifiedClassName, AParams); try Result := lTmp as T; except on E: EInvalidCast do begin lTmp.Free; raise EMVCActiveRecord.Create(AQualifiedClassName + ' is not a TMVCActiveRecord descendant'); end; end; end; class function TMVCActiveRecordHelper.DeleteRQL(const RQL: string): int64; begin Result := TMVCActiveRecord.DeleteRQL(TMVCActiveRecordClass(T), RQL); end; class function TMVCActiveRecordHelper.DeleteRQLByNamedQuery( const QueryName: String; const Params: array of const): Int64; var lRQLQuery: TRQLQueryWithName; lT: T; begin lT := T.Create; try if not lT.FindRQLQueryByName(QueryName, lRQLQuery) then begin raise EMVCActiveRecord.CreateFmt('NamedRQLQuery not found: %s', [QueryName]); end; Result := DeleteRQL(Format(lRQLQuery.RQLText, Params)); finally lT.Free; end; end; class function TMVCActiveRecordHelper.TryGetSQLQuery( const QueryName: String; out NamedSQLQuery: TSQLQueryWithName): Boolean; var lT: T; begin lT := T.Create; try Result := lT.FindSQLQueryByName(QueryName, NamedSQLQuery); finally lT.Free; end; end; class function TMVCActiveRecordHelper.TryGetRQLQuery( const QueryName: String; out NamedRQLQuery: TRQLQueryWithName): Boolean; var lT: T; begin lT := T.Create; try Result := lT.FindRQLQueryByName(QueryName, NamedRQLQuery); finally lT.Free; end; 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; function TMVCActiveRecord.GetCustomTableName: String; begin Result := ''; end; procedure TMVCActiveRecord.Delete(const RaiseExceptionIfNotFound: Boolean); var SQL: string; lAffectedRows: int64; begin CheckAction(TMVCEntityAction.eaDelete); OnValidation(TMVCEntityAction.eaDelete); OnBeforeDelete; if not Assigned(fTableMap.fPrimaryKey) then raise Exception.CreateFmt('Cannot delete %s without a primary key', [ClassName]); SQL := SQLGenerator.CreateDeleteSQL(fTableMap, Self); lAffectedRows := ExecNonQuery(SQL, false); if (lAffectedRows = 0) and RaiseExceptionIfNotFound then begin if fTableMap.fIsVersioned then begin raise EMVCActiveRecordVersionedItemNotFound.CreateFmt('No record deleted for key [Entity: %s][PK: %s][Version: %d] - record or version not found', [ClassName, fTableMap.fPrimaryKeyFieldName, fTableMap.VersionValueAsInt64For(Self)]); end else begin raise EMVCActiveRecordNotFound.CreateFmt('No record deleted for key [Entity: %s][PK: %s]', [ClassName, fTableMap.fPrimaryKeyFieldName]); end; end; OnAfterDelete; end; class function TMVCActiveRecordHelper.DeleteAll(const aClass: TMVCActiveRecordClass): int64; var lAR: TMVCActiveRecord; begin lAR := aClass.Create; try Result := lAR.ExecNonQuery(lAR.SQLGenerator.CreateDeleteAllSQL(lAR.fTableMap.fTableName) + lAR.SQLGenerator.GetDefaultSQLFilter(True)); finally lAR.Free; end; end; class function TMVCActiveRecordHelper.DeleteRQL(const aClass: TMVCActiveRecordClass; const RQL: string): int64; var lAR: TMVCActiveRecord; begin lAR := aClass.Create(True); try Result := lAR.ExecNonQuery(lAR.SQLGenerator.CreateDeleteAllSQL(lAR.fTableMap.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; var lNullableType: TNullableType; begin Assert(aValue.Kind = tkRecord); Result := True; lNullableType := GetNullableType(aValue.TypeInfo); case lNullableType of ntInvalidNullableType: begin Exit(False); end; ntNullableString: begin if not aValue.AsType().HasValue then begin aParam.DataType := ftString; aParam.Clear; Exit(True); end else begin aValue := aValue.AsType().Value; end; end; ntNullableCurrency: begin if not aValue.AsType().HasValue then begin aParam.DataType := TFieldType.ftCurrency; aParam.Clear; Exit(True); end else begin aValue := aValue.AsType().Value; end; end; ntNullableBoolean: begin if not aValue.AsType().HasValue then begin aParam.DataType := ftBoolean; aParam.Clear; Exit(True); end else begin aValue := TValue.From(aValue.AsType().Value); end; end; ntNullableTDate: begin if not aValue.AsType().HasValue then begin aParam.DataType := ftDate; aParam.Clear; Exit(True); end else begin aValue := TValue.From(aValue.AsType().Value); end; end; ntNullableTTime: begin if not aValue.AsType().HasValue then begin aParam.DataType := ftTime; aParam.Clear; Exit(True); end else begin aValue := TValue.From(aValue.AsType().Value); end; end; ntNullableTDateTime: begin if not aValue.AsType().HasValue then begin aParam.DataType := ftDateTime; aParam.Clear; Exit(True); end else begin aValue := TValue.From(aValue.AsType().Value); end; end; ntNullableSingle: begin if not aValue.AsType().HasValue then begin aParam.DataType := TFieldType.ftSingle; aParam.Clear; Exit(True); end else begin aValue := aValue.AsType().Value; end; end; ntNullableDouble: begin if not aValue.AsType().HasValue then begin aParam.DataType := TFieldType.ftFloat; aParam.Clear; Exit(True); end else begin aValue := aValue.AsType().Value; end; end; ntNullableExtended: begin if not aValue.AsType().HasValue then begin aParam.DataType := TFieldType.ftExtended; aParam.Clear; Exit(True); end else begin aValue := aValue.AsType().Value; end; end; ntNullableInt16: begin if not aValue.AsType().HasValue then begin aParam.DataType := ftInteger; aParam.Clear; Exit(True); end else begin aValue := aValue.AsType().Value; end; end; ntNullableUInt16: begin if not aValue.AsType().HasValue then begin aParam.DataType := ftInteger; aParam.Clear; Exit(True); end else begin aValue := aValue.AsType().Value; end; end; ntNullableInt32: begin if not aValue.AsType().HasValue then begin aParam.DataType := ftInteger; aParam.Clear; Exit(True); end else begin aValue := aValue.AsType().Value; end; end; ntNullableUInt32: begin if not aValue.AsType().HasValue then begin aParam.DataType := ftInteger; aParam.Clear; Exit(True); end else begin aValue := aValue.AsType().Value; end; end; ntNullableInt64: begin if not aValue.AsType().HasValue then begin aParam.DataType := ftLargeInt; aParam.Clear; Exit(True); end else begin aValue := aValue.AsType().Value; end; end; ntNullableUInt64: begin if not aValue.AsType().HasValue then begin aParam.DataType := ftLargeInt; aParam.Clear; Exit(True); end else begin aValue := aValue.AsType().Value; end; end; ntNullableTGUID: begin if not aValue.AsType().HasValue then begin aParam.DataType := TFieldType.ftGuid; aParam.Clear; Exit(True); end else begin aValue := TValue.From(aValue.AsType().Value); end; end; end; // case // the nullable value contains a value, so let's call // the "non nullable" version of this procedure MapTValueToParam(aValue, aParam); 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 if aParam.DataTypeName.StartsWith('int', true) then begin aParam.AsInteger := IfThen(aValue.AsBoolean,1,0); end else begin aParam.AsBoolean := aValue.AsBoolean; end; end else begin aParam.AsInteger := aValue.AsOrdinal; 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.TypeInfo = TypeInfo(TGuid) then begin if SQLGenerator.HasNativeUUID then begin aParam.AsGuid := aValue.AsType end else begin aParam.AsString := GUIDToString(aValue.AsType); end; end else if aValue.TypeInfo = 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 fTableMap.fMap do begin if not lItem.Value.Selectable 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 fTableMap.fPrimaryKeyFieldName.IsEmpty then begin MapDataSetFieldToRTTIField(aDataSet.FieldByName(fTableMap.fPrimaryKeyFieldName), fTableMap.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(TableName, fTableMap.fMap, fTableMap.fPrimaryKeyFieldName, fTableMap.fPrimaryKeyOptions); lDataSet := ExecQuery(SQL, [id], [aFieldType], GetConnection, True, False); 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.Refresh; begin if not GetPK.IsEmpty then begin case GetPrimaryKeyFieldType of ftLargeInt: begin LoadByPK(GetPK.AsInt64); end; ftInteger: begin LoadByPK(GetPK.AsInteger); end; ftString: begin LoadByPK(GetPK.AsString); end; ftGuid: begin LoadByPK(GetPK.AsType); end; else raise EMVCActiveRecord.Create('Unknown primary key type'); end; end; 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 TMVCActiveRecordHelper.Select(const aClass: TMVCActiveRecordClass; const SQL: string; const Params: array of Variant): TMVCActiveRecordList; begin Result := Select(aClass, SQL, Params, nil); end; class function TMVCActiveRecordHelper.Select(const aClass: TMVCActiveRecordClass; const SQL: string; const Params: array of Variant; const Connection: TFDConnection): TMVCActiveRecordList; begin Result := TMVCActiveRecordList.Create; try Select(aClass, SQL, Params, Connection, Result); except Result.Free; raise; end; end; class function TMVCActiveRecordHelper.SelectDataSet(const SQL: string; const Params: array of Variant; const ParamTypes: array of TFieldType; const Unidirectional: Boolean; const DirectExecute: Boolean): TDataSet; begin Result := TMVCActiveRecord.ExecQuery(SQL, Params, ParamTypes, Unidirectional, DirectExecute); 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 TMVCActiveRecordHelper.SelectDataSet(const SQL: string; const Params: array of Variant; const Unidirectional: Boolean; const DirectExecute: Boolean): TDataSet; begin Result := TMVCActiveRecord.ExecQuery(SQL, Params, Unidirectional, DirectExecute); end; function TMVCActiveRecordHelper.SelectRQL(const RQL: string; const MaxRecordCount: Integer): TMVCActiveRecordList; begin Result := InternalSelectRQL(RQL, MaxRecordCount); end; class function TMVCActiveRecordHelper.SelectRQL(const aClass: TMVCActiveRecordClass; const RQL: string; const MaxRecordCount: Integer; const OutList: TMVCActiveRecordList): UInt32; var lAR: TMVCActiveRecord; begin lAR := aClass.Create(True); try Result := lAR.InternalSelectRQL(RQL, MaxRecordCount, OutList); finally lAR.Free; end; end; class function TMVCActiveRecordHelper.Select( const MVCActiveRecordClass: TMVCActiveRecordClass; const SQL: string; const Params: array of Variant; const ParamTypes: array of TFieldType; const Options: TMVCActiveRecordLoadOptions; const OutList: TMVCActiveRecordList): UInt32; var lDataSet: TDataSet; lAR: TMVCActiveRecord; begin lDataSet := ExecQuery(SQL, Params, ParamTypes, True, False); try while not lDataSet.Eof do begin lAR := MVCActiveRecordClass.Create; OutList.Add(lAR); lAR.LoadByDataset(lDataSet, Options); lDataSet.Next; end; Result := OutList.Count; finally lDataSet.Free; end; end; class function TMVCActiveRecordHelper.Select( const MVCActiveRecordClass: TMVCActiveRecordClass; const SQL: string; const Params: array of Variant; const ParamTypes: array of TFieldType; const Options: TMVCActiveRecordLoadOptions): TMVCActiveRecordList; begin Result := TMVCActiveRecordList.Create; try Select(MVCActiveRecordClass, SQL, Params, ParamTypes, Options, Result); except Result.Free; raise; end; end; class function TMVCActiveRecordHelper.Select(const SQL: string; const Params: array of Variant; const ParamTypes: array of TFieldType; const Options: TMVCActiveRecordLoadOptions; const OutList: TObjectList): UInt32; var lDataSet: TDataSet; lAR: TMVCActiveRecord; begin lDataSet := ExecQuery(SQL, Params, ParamTypes, True, False); try while not lDataSet.Eof do begin lAR := T.Create; OutList.Add(lAR); lAR.LoadByDataset(lDataSet, Options); lDataSet.Next; end; Result := OutList.Count; finally lDataSet.Free; end; end; class function TMVCActiveRecordHelper.SelectByNamedQuery( const MVCActiveRecordClass: TMVCActiveRecordClass; const QueryName: String; const Params: array of Variant; const ParamTypes: array of TFieldType; const Options: TMVCActiveRecordLoadOptions): TMVCActiveRecordList; var lT: TMVCActiveRecord; lSQLQuery: TSQLQueryWithName; begin lT := MVCActiveRecordClass.Create; try if not lT.FindSQLQueryByName(QueryName, lSQLQuery) then begin raise EMVCActiveRecord.CreateFmt('NamedSQLQuery "%s" not found for entity "%s"', [QueryName, lT.ClassName]); end; Result := Select(MVCActiveRecordClass, lSQLQuery.SQLText, Params, ParamTypes, Options); finally lT.Free; end; end; class function TMVCActiveRecordHelper.SelectByNamedQuery( const QueryName: String; const Params: array of Variant; const ParamTypes: array of TFieldType; const Options: TMVCActiveRecordLoadOptions): TObjectList; var lT: T; lSQLQuery: TSQLQueryWithName; begin lT := T.Create; try if not lT.FindSQLQueryByName(QueryName, lSQLQuery) then begin raise EMVCActiveRecord.CreateFmt('NamedSQLQuery "%s" not found for entity "%s"', [QueryName, lT.ClassName]); end; Result := Select(lSQLQuery.SQLText, Params, ParamTypes, Options); finally lT.Free; end; end; class function TMVCActiveRecordHelper.Select(const SQL: string; const Params: array of Variant; const ParamTypes: array of TFieldType; const Options: TMVCActiveRecordLoadOptions): TObjectList; begin Result := TObjectList.Create(True); try Select(SQL, Params, ParamTypes, Options, Result); 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 lList: TObjectList; begin 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; begin Result := TObjectList.Create(True); try Where(SQLWhere, Params, ParamTypes, Result); except Result.Free; raise; end; end; class function TMVCActiveRecordHelper.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 fTableMap.fPrimaryKeyFieldName.IsEmpty then begin raise Exception.Create('No primary key defined'); end; if fTableMap.fPrimaryKey.GetValue(Self).Kind = tkRecord then begin lPKValue := fTableMap.fPrimaryKey.GetValue(Self); if lPKValue.IsType { and aValue.IsType() } then begin if aValue.IsType then begin lPKValue := TValue.From(IntToNullableInt(aValue.AsInteger)); end else begin raise EMVCActiveRecord.Create('Invalid type for primary key'); 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; fTableMap.fPrimaryKey.SetValue(Self, lPKValue); end else begin fTableMap.fPrimaryKey.SetValue(Self, aValue) end; end; procedure TMVCActiveRecord.SetPrimaryKeyIsAutogenerated(const Value: Boolean); begin if Value then begin Include(fTableMap.fPrimaryKeyOptions, foAutoGenerated); end else begin Exclude(fTableMap.fPrimaryKeyOptions, foAutoGenerated); end; end; procedure TMVCActiveRecord.SetInitialObjVersion(const TableMap: TMVCTableMap; const ARInstance: TMVCActiveRecord); begin TableMap.fVersionRTTIField.SetValue(ARInstance, OBJECT_VERSION_STARTING_VALUE_AS_INT); end; function TMVCActiveRecord.SQLGenerator: TMVCSQLGenerator; var lSQLGeneratorClass: TMVCSQLGeneratorClass; begin if not Assigned(fSQLGenerator) then begin GetConnection.Connected := True; lSQLGeneratorClass := TMVCSQLGeneratorRegistry.Instance.GetSQLGenerator(GetBackEnd); fSQLGenerator := lSQLGeneratorClass.Create(GetMapping, fTableMap.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: ' + TableName; for KeyValue in fTableMap.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 fTableMap.fPrimaryKeyFieldName.IsEmpty then raise Exception.Create('No primary key defined'); Value := fTableMap.fPrimaryKey.GetValue(Self); if Value.Kind = tkRecord then begin if Value.IsType() then begin Result := Value.AsType().TryHasValue(Value); end else if Value.IsType() then begin Result := Value.AsType().TryHasValue(Value) end else if Value.IsType() then begin Result := Value.AsType().TryHasValue(Value) end else if Value.IsType() then begin Result := Value.AsType().TryHasValue(Value) end else if Value.IsType() then begin Result := Value.AsType().TryHasValue(Value) end else if Value.IsType() then begin Result := Value.AsType().TryHasValue(Value) end else if Value.IsType() then begin Result := Value.AsType().TryHasValue(Value) end else if Value.IsType() then begin Result := Value.AsType().TryHasValue(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 fTableMap.fMap.WritableFieldsCount = 0 then begin raise EMVCActiveRecord.CreateFmt ('Cannot update an entity if no fields are writeable. Class [%s] mapped on table [%s]', [ClassName, TableName]); end; SQL := SQLGenerator.CreateUpdateSQL(fTableMap, Self); lAffectedRows := ExecNonQuery(SQL, false); if (lAffectedRows = 0) and RaiseExceptionIfNotFound then begin if fTableMap.fIsVersioned then begin raise EMVCActiveRecordVersionedItemNotFound.CreateFmt('No record updated for key [Entity: %s][PK: %s][Version: %d] - record or version not found', [ClassName, fTableMap.fPrimaryKeyFieldName, fTableMap.VersionValueAsInt64For(Self)]); end else begin raise EMVCActiveRecordNotFound.CreateFmt('No record updated for key [Entity: %s][PK: %s]', [ClassName, fTableMap.fPrimaryKeyFieldName]); end; end; if fTableMap.fIsVersioned then begin AdvanceVersioning(fTableMap, Self); end; OnAfterUpdate; OnAfterInsertOrUpdate; end; class function TMVCActiveRecordHelper.Where(const aClass: TMVCActiveRecordClass; const SQLWhere: string; const Params: array of Variant; const Connection: TFDConnection; const OutList: TMVCActiveRecordList): UInt32; var lAR: TMVCActiveRecord; begin lAR := aClass.Create; try Result := Select(aClass, lAR.GenerateSelectSQL + SQLWhere, Params, Connection, OutList); finally lAR.Free; end; 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 TMVCActiveRecordHelper.All(const aClass: TMVCActiveRecordClass): TObjectList; var lAR: TMVCActiveRecord; begin lAR := aClass.Create; try Result := Select(aClass, lAR.GenerateSelectSQL + lAR.SQLGenerator.GetDefaultSQLFilter(True), []); finally lAR.Free; end; end; procedure TMVCActiveRecord.AdvanceVersioning(const TableMap: TMVCTableMap; const ARInstance: TMVCActiveRecord); var lCurrVersion: Int64; begin lCurrVersion := TableMap.VersionValueAsInt64For(ARInstance); Inc(lCurrVersion); TableMap.fVersionRTTIField.SetValue(ARInstance, lCurrVersion); end; procedure TMVCActiveRecord.Assign(ActiveRecord: TMVCActiveRecord); begin //do nothing end; class function TMVCActiveRecordHelper.All(const aQualifiedClassName: String): TObjectList; var lAR: TMVCActiveRecord; begin lAR := TMVCActiveRecord.CreateMVCActiveRecord(aQualifiedClassName, []); try Result := Select(TMVCActiveRecordClass(lAR.ClassType), lAR.GenerateSelectSQL + lAR.SQLGenerator.GetDefaultSQLFilter(True), []); finally lAr.Free; end; end; class function TMVCActiveRecordHelper.All: TObjectList; var lAR: TMVCActiveRecord; begin lAR := T.Create; try Result := Select( lAR.GenerateSelectSQL + lAR.SQLGenerator.GetDefaultSQLFilter(True), []); finally lAR.Free; end; end; class function TMVCActiveRecordHelper.Where(const aClass: TMVCActiveRecordClass; const SQLWhere: string; const Params: array of Variant): TMVCActiveRecordList; begin Result := Where(aClass, SQLWhere, Params, nil); end; class function TMVCActiveRecordHelper.Where(const aClass: TMVCActiveRecordClass; const SQLWhere: string; const Params: array of Variant; const Connection: TFDConnection): TMVCActiveRecordList; begin Result := TMVCActiveRecordList.Create; try Where(aClass, SQLWhere, Params, Connection, Result); except Result.Free; raise; 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; const MergeMode: TMergeMode): IMVCMultiExecutor; var I: Integer; lFoundAtIndex: Integer; lUnitOfWork: IMVCUnitOfWork; lPKType: TFieldType; lNeedsToBeUpdated: Boolean; begin lUnitOfWork := TMVCUnitOfWork.Create; if mmDelete in MergeMode then begin lUnitOfWork.RegisterDelete(CurrentList); end; 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 if mmInsert in MergeMode then begin lUnitOfWork.RegisterInsert(NewList[I]); end; 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 for merge'); end; if lNeedsToBeUpdated then begin if mmUpdate in MergeMode then begin lUnitOfWork.RegisterUpdate(NewList[I]) end; end else begin if mmInsert in MergeMode then begin lUnitOfWork.RegisterInsert(NewList[I]); end; end; 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". [HINT] Include unit "MVCFramework.SQLGenerators.%s.pas" somewhere in the project code, if available.', [aBackend, 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 TableMap: TMVCTableMap; const ARInstance: TMVCActiveRecord): string; begin Result := CreateDeleteAllSQL(TableMap.fTableName) + ' WHERE ' + GetFieldNameForSQL(TableMap.fPrimaryKeyFieldName) + '=:' + GetParamNameForSQL(TableMap.fPrimaryKeyFieldName); if TableMap.fIsVersioned then begin Result := Result + ' and ' + GetFieldNameForSQL(TableMap.fVersionFieldName) + ' = ' + IntToStr(TableMap.VersionValueAsInt64For(ARInstance)); end; 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 TableMap: TMVCTableMap; const ARInstance: TMVCActiveRecord): string; var lPair: TPair; // I: Integer; begin Result := 'UPDATE ' + GetTableNameForSQL(TableMap.fTableName) + ' SET '; for lPair in TableMap.fMap do begin if lPair.Value.IsVersion then begin Result := Result + GetFieldNameForSQL(lPair.Value.FieldName) + ' = ' + GetParamNameForSQL(lPair.Value.FieldName) + ' + 1,'; end else if lPair.Value.Updatable 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 TableMap.fPrimaryKeyFieldName.IsEmpty then begin Result := Result + ' where ' + GetFieldNameForSQL(TableMap.fPrimaryKeyFieldName) + '= :' + GetParamNameForSQL(TableMap.fPrimaryKeyFieldName); if TableMap.fIsVersioned then begin Result := Result + ' and ' + GetFieldNameForSQL(TableMap.fVersionFieldName) + ' = ' + TableMap.VersionValueAsInt64For(ARInstance).ToString end; end else begin raise EMVCActiveRecord.Create('Cannot perform an update without an entity primary key'); 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.HasNativeUUID: Boolean; begin Result := false; 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; end; function TMVCSQLGenerator.MergeSQLFilter(const PartitionSQL, FilteringSQL: String): String; begin Result := ''; if PartitionSQL + FilteringSQL = '' then begin Exit; end; //if PartitionSQL.IsEmpty and (not FilteringSQL.IsEmpty) then if not FilteringSQL.IsEmpty then begin Exit(FilteringSQL); //ignore partitioning while reading if filtering is present end; if FilteringSQL.IsEmpty and (not PartitionSQL.IsEmpty) then begin Exit(PartitionSQL); end; // Result := '((' + PartitionSQL + ') and (' + FilteringSQL + '))'; 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 lPair.Value.Selectable 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; FHTTPStatusCode := 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; const DirectExecute: Boolean): TDataSet; var lQry: TFDQuery; begin lQry := TFDQuery.Create(nil); try lQry.FetchOptions.Mode := TFDFetchMode.fmAll; lQry.FetchOptions.Unidirectional := Unidirectional; lQry.UpdateOptions.ReadOnly := True; lQry.ResourceOptions.DirectExecute := DirectExecute; //2023-07-12 if Connection = nil then begin lQry.Connection := ActiveRecordConnectionsRegistry.GetCurrent; end else begin lQry.Connection := Connection; end; 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; const DirectExecute: Boolean): TDataSet; begin Result := ExecQuery(SQL, Values, ValueTypes, nil, Unidirectional, DirectExecute); 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 lPair.Value.Insertable or lPair.Value.Updatable then begin Inc(fWritableFieldsCount); end; if lPair.Value.Selectable 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; Selectable := false; Insertable := False; Updatable := False; end else begin //Writeable := ((FieldOptions * [foReadOnly, foAutoGenerated]) = []); Selectable := not (foDoNotSelect in FieldOptions); Insertable := not (foDoNotInsert in FieldOptions); Updatable := not (foDoNotUpdate in FieldOptions); if foReadOnly in FieldOptions then begin Insertable := False; Updatable := False; Selectable := True; end; end; IsVersion := foVersion in FieldOptions; // field options consistency check // if Writeable and (not Updatable) then // begin // raise EMVCActiveRecord.CreateFmt('Field "%s" cannot be Writeable but not Updateable', [FieldName]); // end; // if (not Writeable) and (Readable) and (Updatable or Insertable) then // begin // raise EMVCActiveRecord.CreateFmt('Field "%s" cannot be ReadOnly but (Updateable or Insertable)', [FieldName]); // 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 Create; 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 TMonitor.Enter(PartitionInfoCache); try if PartitionInfoCache.TryGetValue(PartitionClause + '|' + RQLCompilerClass.ClassName, Result) then begin Exit; end; 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] Partioning 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; finally TMonitor.Exit(PartitionInfoCache); end; end; end; class constructor TPartitionInfo.Create; begin PartitionInfoCache := TMVCThreadedObjectCache.Create; end; { TMVCTableMapRepository } procedure TMVCTableMapRepository.AddTableMap(const AR: TMVCActiveRecord; const TableName: String; var TableMap: TMVCTableMap); var lKey: string; {$IF Not Defined(RIOORBETTER)} lTmpTableMap: TMVCTableMap; {$ENDIF} begin fMREW.BeginWrite; try lKey := GetCacheKey(AR, TableName); // if, due to multi-threading (and the micro-lock used in the caller), // the tablemap definition is already in the case, I free the passed TableMap // and return the TableMap already present in the cache. LogD(Format('ActiveRecord: Add "%s" to the metadata cache', [lKey])); {$IF Defined(RIOORBETTER)} if not fTableMapDict.TryAdd(lKey, TableMap) then begin LogD(Format('ActiveRecord: Discarded new mapping - cache for "%s" already present', [lKey])); TableMap.Free; TableMap := fTableMapDict[lKey]; end; {$ELSE} // https://github.com/danieleteti/delphimvcframework/issues/728 if fTableMapDict.TryGetValue(lKey, lTmpTableMap) then begin LogD(Format('ActiveRecord: Discarded new mapping - cache for "%s" already present', [lKey])); TableMap.Free; TableMap := lTmpTableMap; end else begin fTableMapDict.Add(lKey, TableMap); end; {$ENDIF} finally fMREW.EndWrite; end; end; constructor TMVCTableMapRepository.Create; begin inherited; fMREW := TMultiReadExclusiveWriteSynchronizer.Create; fTableMapDict := TObjectDictionary.Create([doOwnsValues]); end; destructor TMVCTableMapRepository.Destroy; begin fTableMapDict.Free; fMREW.Free; inherited; end; procedure TMVCTableMapRepository.ExecWithExclusiveLock(Proc: TProc); begin fMREW.BeginWrite; try Proc(Self); finally fMREW.EndWrite; end; end; procedure TMVCTableMapRepository.FlushCache; begin ExecWithExclusiveLock( procedure(Map: IMVCActiveRecordTableMap) begin TMVCTableMapRepository(Map).fTableMapDict.Clear; end); end; function TMVCTableMapRepository.GetCacheKey(const AR: TMVCActiveRecord; const TableName: String): String; begin Result := AR.QualifiedClassName + ':' + TableName; end; function TMVCTableMapRepository.TryGetValue( const AR: TMVCActiveRecord; const TableName: String; out TableMap: TMVCTableMap): Boolean; begin {$IF not Defined(TokyoOrBetter)} Result := nil; {$ENDIF} fMREW.BeginRead; try Result := fTableMapDict.TryGetValue(GetCacheKey(AR, TableName), TableMap); finally fMREW.EndRead; end; end; { TMVCTableMap } constructor TMVCTableMap.Create; begin inherited; fMap := TFieldsMap.Create; fIsVersioned := False; fVersionFieldName := ''; end; destructor TMVCTableMap.Destroy; begin fMap.Free; inherited; end; function TMVCTableMap.VersionValueAsInt64For(AR: TMVCActiveRecord): Int64; begin Result := fVersionRTTIField.GetValue(AR).AsInt64; end; class function TMVCActiveRecordHelper.Select( const aClass: TMVCActiveRecordClass; const SQL: string; const Params: array of Variant; const Connection: TFDConnection; const OutList: TMVCActiveRecordList): UInt32; var lDataSet: TDataSet; lAR: TMVCActiveRecord; begin lDataSet := ExecQuery(SQL, Params, Connection, True, False); try while not lDataSet.Eof do begin lAR := aClass.Create; OutList.Add(lAR); lAR.LoadByDataset(lDataSet); lDataSet.Next; end; Result := OutList.Count; finally lDataSet.Free; end; end; { MVCNamedSQLQueryAttribute } constructor MVCNamedSQLQueryAttribute.Create(aName, aSQLSelect: String); begin Create(aName, aSQLSelect, ''); end; constructor MVCNamedSQLQueryAttribute.Create(aName, aSQLSelect, aBackEnd: String); begin inherited Create; Name := aName; SQLQuery := aSQLSelect; BackEnd := aBackEnd; end; { MVCNamedRQLQueryAttribute } constructor MVCNamedRQLQueryAttribute.Create(aName, aRQL: String); begin inherited Create; Name := aName; RQLQuery := aRQL; end; constructor TMVCActiveRecord.Create; begin Create(True); end; initialization gConnectionsLock := TObject.Create; gTableMapLock := TObject.Create; gCtx := TRttiContext.Create; gCtx.FindType(''); finalization gCtx.Free; gConnectionsLock.Free; gTableMapLock.Free; end.