USER
unit orm_utils;
interface
uses
System.SysUtils, System.Classes, System.Generics.Collections, System.Generics.Defaults, System.Rtti, System.TypInfo, Data.DB, Uni, pixel_classes, orm_customattributes, Vcl.Controls, Vcl.Forms, Dialogs, Variants;
const
DATE_FORMATS: array[0..3] of string = (
'dd/mm/yyyy',
'dd-mm-yyyy',
'dd.mm.yyyy',
'yyyy-mm-dd'
);
type
TQryRecInfo = class;
// Define the event type
TPropertyChangedEvent = procedure(Sender: TQryRecInfo; const PropertyName: string) of object;
EORMUtilsException = class(Exception);
/// <summary>
/// Represents the key used in the component-ORM mapping dictionary.
/// Combines a reference to an ORM record with a specific field name.
/// </summary>
TORMKey = record
ORMRec: TQryRecInfo;
FieldName: string;
end;
/// <summary>
/// Custom comparer for TORMKey to handle equality checks and hashing.
/// </summary>
TORMKeyComparer = class(TEqualityComparer<TORMKey>)
function Equals(const Left, Right: TORMKey): Boolean; override;
function GetHashCode(const Key: TORMKey): Integer; override;
end;
/// <summary>
/// Manages the binding between UI components and ORM records.
/// </summary>
TORMManager = class
private
FComponentDict: TDictionary<TORMKey, TComponent>;
procedure HandleEditExit(Sender: TObject);
procedure HandleDatePickerCloseUp(Sender: TObject);
procedure HandleCheckBoxClick(Sender: TObject);
procedure HandleComboCloseUp(Sender: TObject);
function GetPropertyIndex(ORMRec: TQryRecInfo; const PropertyName: string): Integer;
public
constructor Create;
destructor Destroy; override;
procedure UpdateComponentsForORMRec(ORMRec: TQryRecInfo);
procedure HandlePropertyChanged(Sender: TQryRecInfo;
const PropertyName: string);
/// <summary>
/// Registers a component with its corresponding ORM record and field name.
/// </summary>
procedure RegisterComponent(Component: TComponent; ORMRec: TQryRecInfo; const FieldName: string);
/// <summary>
/// Unregisters a component from ORM binding.
/// </summary>
procedure UnregisterComponent(Component: TComponent);
/// <summary>
/// Finds the component associated with a specific ORM record and field name.
/// </summary>
function FindComponent(ORMRec: TQryRecInfo; const FieldName: string): TComponent;
/// <summary>
/// Retrieves all registered components.
/// </summary>
function GetAllComponents: TArray<TComponent>;
/// <summary>
/// Updates a component's UI based on the latest ORM record data.
/// </summary>
procedure UpdateComponentFromORM(Component: TComponent; ORMRec: TQryRecInfo; const FieldName: string);
/// <summary>
/// Retrieves the ORM record associated with a given component.
/// </summary>
function GetORMRecForComponent(Component: TComponent): TQryRecInfo;
/// <summary>
/// Retrieves the field name associated with a given component.
/// </summary>
function GetFieldNameForComponent(Component: TComponent): string;
/// <summary>
/// Registers components based on their Hint property.
/// </summary>
procedure RegisterComponentsByHint(MyForm: TForm; ORMRec: TQryRecInfo);
procedure UnregisterComponentsByORM(ORMRec: TQryRecInfo);
/// <summary>
/// Sets a translated value to the ORM property bound to a component
/// </summary>
/// <param name="Component">The bound UI component</param>
/// <param name="DisplayValue">The display value to be translated and set</param>
procedure SetTranslatedValue(Component: TComponent; const DisplayValue: string);
end;
/// <summary>
/// Helper methods extending TComponent to interface with ORMManager.
/// </summary>
TComponentHelper = class helper for TComponent
public
/// <summary>
/// Retrieves the ORM record associated with the component.
/// </summary>
function GetORMRec: TQryRecInfo;
/// <summary>
/// Retrieves the field name associated with the component.
/// </summary>
function GetORMRecField: string;
end;
/// <summary>
/// Defines the type of filter operation
/// </summary>
TFilterType = (
tfEqualTo, // =
tfNotEqualTo, // <>
tfGreaterThan, // >
tfGreaterOrEqual, // >=
tfLessThan, // <
tfLessOrEqual, // <=
tfBetween, // BETWEEN
tfNotBetween, // NOT BETWEEN
tfLike, // LIKE
tfNotLike, // NOT LIKE
tfInList, // IN
tfNotInList, // NOT IN
tfIsNull, // IS NULL
tfIsNotNull, // IS NOT NULL
tfBeginsWith, // LIKE 'value%'
tfEndsWith, // LIKE '%value'
tfContains // LIKE '%value%'
);
/// <summary>
/// Defines how filters are concatenated (AND/OR)
/// </summary>
TFilterConcatenator = (fcAnd, fcOr);
/// <summary>
/// Defines parenthesis handling for filter groups
/// </summary>
TFilterParenthesis = (fpNone, fpOpen, fpClose, fpBoth);
/// <summary>
/// Represents a single filter condition
/// </summary>
TFilterItem = record
FieldName: string;
FilterType: TFilterType;
Value1: Variant;
Value2: Variant;
Concatenator: TFilterConcatenator;
Parenthesis: TFilterParenthesis;
DateTimeFormat: string;
end;
/// <summary>
/// Exception class for filter-related errors
/// </summary>
EFilterException = class(Exception);
/// <summary>
/// Manages a group of filter conditions
/// </summary>
TFilterGroup = class
private
FItems: TList<TFilterItem>;
FParenthesisLevel: Integer;
FConcatenator: TFilterConcatenator;
function FormatDateTimeValue(const Value: Variant; const Format: string = ''): string;
function ProcessDateTimeFilter(const Item: TFilterItem): string;
function GetFilterText: string;
public
constructor Create(AConcatenator: TFilterConcatenator = fcAnd);
destructor Destroy; override;
function AddSingleFilter(const FieldName: string; FilterType: TFilterType;
const Value: Variant; Concatenator: TFilterConcatenator = fcAnd;
Parenthesis: TFilterParenthesis = fpNone): TFilterGroup;
function AddRangeFilter(const FieldName: string; FilterType: TFilterType;
const Value1, Value2: Variant; Concatenator: TFilterConcatenator = fcAnd;
Parenthesis: TFilterParenthesis = fpNone): TFilterGroup;
property Items: TList<TFilterItem> read FItems;
property ParenthesisLevel: Integer read FParenthesisLevel write FParenthesisLevel;
property Concatenator: TFilterConcatenator read FConcatenator;
property FilterText: string read GetFilterText;
end;
/// <summary>
/// Fluent interface for building filters
/// </summary>
TFilterBuilder = class
private
FCurrentGroup: TFilterGroup;
FGroups: TObjectList<TFilterGroup>;
FCurrentFieldName: string;
FDateTimeFormat: string;
function GetFilterText: string;
procedure ValidateCurrentField;
function AddFilterInternal(FilterType: TFilterType; const Value: Variant): TFilterBuilder;
public
constructor Create;
destructor Destroy; override;
// Basic filter methods
function Where(const FieldName: string): TFilterBuilder;
function AndWhere(const FieldName: string): TFilterBuilder;
function OrWhere(const FieldName: string): TFilterBuilder;
// Comparison methods
function EqualTo(const Value: Variant): TFilterBuilder;
function NotEqualTo(const Value: Variant): TFilterBuilder;
function GreaterThan(const Value: Variant): TFilterBuilder;
function GreaterOrEqual(const Value: Variant): TFilterBuilder;
function LessThan(const Value: Variant): TFilterBuilder;
function LessOrEqual(const Value: Variant): TFilterBuilder;
function Between(const Value1, Value2: Variant): TFilterBuilder;
function NotBetween(const Value1, Value2: Variant): TFilterBuilder;
// List operations
function InList(const Values: array of Variant): TFilterBuilder;
function NotInList(const Values: array of Variant): TFilterBuilder;
// NULL checks
function IsNull: TFilterBuilder;
function IsNotNull: TFilterBuilder;
// String operations
function Like(const Value: string): TFilterBuilder;
function NotLike(const Value: string): TFilterBuilder;
function BeginsWith(const Value: string): TFilterBuilder;
function EndsWith(const Value: string): TFilterBuilder;
function Contains(const Value: string): TFilterBuilder;
// Direct filter addition
function AddFilter(const FieldName: string; FilterType: TFilterType;
const Value: Variant; Concatenator: TFilterConcatenator = fcAnd): TFilterBuilder;
// Grouping
function BeginGroup: TFilterBuilder;
function EndGroup: TFilterBuilder;
// Helper methods
function Clear: TFilterBuilder;
procedure ApplyToQuery(var SQL: string);
property FilterText: string read GetFilterText;
end;
/// <summary>
/// Base class for query record information
/// Use descendants of this class to represent specific database records.
/// </summary>
TQryRecInfo = class
private
FDirtyFields: TDictionary<string, Boolean>;
FPreviousValues: TDictionary<string, TValue>;
FOnPropertyChanged: TPropertyChangedEvent; // New event
FIsNewRec: Boolean; // New field
FFilterBuilder: TFilterBuilder;
class var FBaseQuery: string;
procedure SetInfo(Index: Integer; const Value: TValue);
procedure HandlePropertyChange(const PropertyName: string);
public
constructor Create;
destructor Destroy; override;
// Event property
property OnPropertyChanged: TPropertyChangedEvent read FOnPropertyChanged write FOnPropertyChanged;
// New property
property IsNewRec: Boolean read FIsNewRec;
// Methods to set nullable fields
procedure SetInfoNullableString(Index: Integer; const Value: TNullable<string>);
procedure SetInfoNullableInteger(Index: Integer; const Value: TNullable<Integer>);
procedure SetInfoNullableInt64(Index: Integer; const Value: TNullable<Int64>);
procedure SetInfoNullableExtended(Index: Integer; const Value: TNullable<Extended>);
procedure SetInfoNullableCurrency(Index: Integer; const Value: TNullable<Currency>);
procedure SetInfoNullableDateTime(Index: Integer; const Value: TNullable<TDateTime>);
procedure SetInfoNullableBoolean(Index: Integer; const Value: TNullable<Boolean>);
procedure SetInfoNullableVariant(Index: Integer; const Value: TNullable<Variant>);
// Methods to set non-nullable simple types
procedure SetInfoCurrency(Index: Integer; const Value: Currency);
procedure SetInfoString(Index: Integer; const Value: string);
procedure SetInfoInteger(Index: Integer; const Value: Integer);
procedure SetInfoInt64(Index: Integer; const Value: Int64);
procedure SetInfoExtended(Index: Integer; const Value: Extended);
procedure SetInfoDateTime(Index: Integer; const Value: TDateTime);
procedure SetInfoBoolean(Index: Integer; const Value: Boolean);
procedure SetInfoVariant(Index: Integer; const Value: Variant);
// Methods to handle dirty fields
function IsFieldDirty(const FieldName: string): Boolean;
procedure ClearDirtyFlags;
property DirtyFields: TDictionary<string, Boolean> read FDirtyFields;
// Methods to handle previous values
function GetPreviousValue(const FieldName: string): TValue;
procedure ClearPreviousValues;
property PreviousValues: TDictionary<string, TValue> read FPreviousValues;
/// <summary>
/// Retrieves the formatted text for a given field based on the FmtProp attribute.
/// </summary>
function GetFormattedText(const FieldName: string): string;
/// <summary>
/// Fetches data for this record from the database based on the provided SQL.
/// </summary>
procedure Fetch(DBConn: TUniConnection; const QryTxt: string = ''); overload;
/// <summary>
/// Retrieves the value of a property by name.
/// </summary>
/// <param name="PropertyName">The name of the property to retrieve.</param>
/// <returns>The value of the specified property as TValue.</returns>
function GetPropertyValue(const PropertyName: string): TValue;
procedure SetORMProperty(const FieldName: string; const Value: TValue);
/// <summary>
/// Converts a display value to its corresponding stored value based on Translation attributes
/// </summary>
/// <param name="PropertyName">The name of the property</param>
/// <param name="DisplayValue">The display value to convert</param>
/// <returns>The corresponding stored value, or the original display value if no translation found</returns>
function GetStoredValueFromDisplay(const PropertyName, DisplayValue: string): string;
/// <summary>
/// Gets the base SQL query for this TQryRecInfo class
/// </summary>
class function GetBaseQuery: string; virtual;
/// <summary>
/// Sets the base SQL query for this TQryRecInfo class
/// </summary>
class procedure SetBaseQuery(const AQuery: string); virtual;
/// <summary>
/// Clears the base SQL query for this TQryRecInfo class
/// </summary>
class procedure ClearBaseQuery; virtual;
function Filter: TFilterBuilder;
function ClearFilter: TQryRecInfo;
// Override existing methods
procedure ApplyFilters(var SQL: string); virtual;
// Modified Fetch method to use new filter system
procedure FetchFiltered(DBConn: TUniConnection; const QryTxt: string = '');
end;
/// <summary>
/// Generic class to handle arrays of TQryRecInfo descendants.
/// </summary>
TQryRecArray<T: TQryRecInfo, constructor> = class
private
FQryRecInfoList: TObjectList<T>;
FFilterSQL: string;
FDBConn: TUniConnection;
function GetCount: Integer;
public
constructor Create;
destructor Destroy; override;
// Add a record to the array
procedure Add(AItem: T);
// Add this method to the TQryRecArray<T> class
procedure Delete(Index: Integer);
procedure Move(OldIndex, NewIndex: Integer);
/// <summary>
/// Fetches all records based on the provided SQL text and populates the array.
/// </summary>
/// <param name="QryTxt">The base SQL query text.</param>
procedure FetchAllInstance(DBConn: TUniConnection; const QryTxt: string = '');
/// <summary>
/// Accesses a record at the specified index.
/// </summary>
/// <param name="Index">The zero-based index of the record.</param>
/// <returns>The record at the specified index.</returns>
function Rec(Index: Integer): T;
/// <summary>
/// Number of records in the array.
/// </summary>
property RecCount: Integer read GetCount;
/// <summary>
/// Database connection used for fetching records.
/// </summary>
property DBConn: TUniConnection read FDBConn write FDBConn;
/// <summary>
/// Additional SQL filter to apply to the query.
/// </summary>
property SQLFilter: string read FFilterSQL write FFilterSQL;
/// <summary>
/// Provides support for for-in loops by returning an enumerator.
/// </summary>
function GetEnumerator: TEnumerator<T>;
/// <summary>
/// Factory method to create and fetch records in a single step.
/// </summary>
/// <param name="DBConn">Database connection.</param>
/// <param name="QryTxt">SQL query text.</param>
/// <returns>Populated instance of TQryRecArray<T>.</returns>
class function FetchAll(DBConn: TUniConnection; const QryTxt: string): TQryRecArray<T>; static;
end;
/// <summary>
/// Manages base SQL queries for TQryRecInfo classes
/// </summary>
TBaseQueryManager = class
private
FBaseQueries: TDictionary<TClass, string>;
class var FInstance: TBaseQueryManager;
constructor Create;
public
destructor Destroy; override;
/// <summary>
/// Gets the base query for a TQryRecInfo class
/// </summary>
function GetBaseQuery(AClass: TClass): string;
/// <summary>
/// Sets or updates the base query for a TQryRecInfo class
/// </summary>
procedure SetBaseQuery(AClass: TClass; const AQuery: string);
/// <summary>
/// Removes the base query for a TQryRecInfo class
/// </summary>
procedure RemoveBaseQuery(AClass: TClass);
/// <summary>
/// Checks if a base query exists for a TQryRecInfo class
/// </summary>
function HasBaseQuery(AClass: TClass): Boolean;
class function GetInstance: TBaseQueryManager;
class procedure ReleaseInstance;
end;
function FormataInfo(info: Variant; tipo: TORMFormatType): string;
function FindPropertyByColumnName(const ColumnName: string; RttiType: TRttiType): string;
function FormatValueByType(const Value: string; FormatType: TORMFormatType; IsNullable: Boolean): Variant;
function HandleBooleanMapping(Field: TField; BoolAttr: BooleanMapAttribute; IsNullable: Boolean): TValue;
function GetBooleanMapAttribute(RttiType: TRttiType; const FieldName: string): BooleanMapAttribute;
// Declare ORMManager as a global variable in the interface for accessibility
var
ORMManager: TORMManager;
implementation
uses
pixel_utils, System.Math, System.Types, Windows, Vcl.StdCtrls, Vcl.WinXCtrls, Vcl.WinXPickers, StrUtils, DateUtils, System.Hash,
Vcl.ComCtrls, AdvDateTimePicker;
// Helper function to find property name by column name, scanning for RefColumn attribute
function FindPropertyByColumnName(const ColumnName: string; RttiType: TRttiType): string;
var
Prop: TRttiProperty;
Field: TRttiField;
Attr: TCustomAttribute;
FieldAttr: RefColumnAttribute;
begin
Result := '';
// First try direct name match (case-insensitive)
for Prop in RttiType.GetProperties do
if SameText(Prop.Name, ColumnName) then
Exit(Prop.Name);
// If no direct match, look for RefColumn attribute
for Prop in RttiType.GetProperties do
begin
// Check property attributes first
for Attr in Prop.GetAttributes do
if Attr is RefColumnAttribute then
begin
FieldAttr := RefColumnAttribute(Attr);
if SameText(FieldAttr.ColumnName, ColumnName) then
Exit(Prop.Name);
end;
// If not found, check corresponding field attributes
Field := RttiType.GetField('_' + Prop.Name);
if Assigned(Field) then
for Attr in Field.GetAttributes do
if Attr is RefColumnAttribute then
begin
FieldAttr := RefColumnAttribute(Attr);
if SameText(FieldAttr.ColumnName, ColumnName) then
Exit(Prop.Name);
end;
end;
end;
// =============================
// TORMKeyComparer Implementation
// =============================
function TORMKeyComparer.Equals(const Left, Right: TORMKey): Boolean;
begin
Result:= (Left.ORMRec = Right.ORMRec) and SameText(Left.FieldName, Right.FieldName);
end;
function TORMKeyComparer.GetHashCode(const Key: TORMKey): Integer;
begin
Result:= Integer(NativeUInt(Key.ORMRec)) xor THashBobJenkins.GetHashValue(LowerCase(Key.FieldName));
end;
// =============================
// TORMManager Implementation
// =============================
constructor TORMManager.Create;
begin
inherited Create;
FComponentDict:= TDictionary<TORMKey, TComponent>.Create(TORMKeyComparer.Create);
end;
destructor TORMManager.Destroy;
begin
FComponentDict.Free;
inherited;
end;
procedure TORMManager.RegisterComponent(Component: TComponent; ORMRec: TQryRecInfo; const FieldName: string);
var
Context: TRttiContext;
RttiType: TRttiType;
Prop: TRttiProperty;
Field: TRttiField;
EnumAttr: EnumValuesAttribute;
TransAttr: TranslationAttribute;
Key: TORMKey;
begin
// Existing validation code remains unchanged
if not Assigned(Component) then
raise EORMUtilsException.Create('Cannot register nil component');
if not Assigned(ORMRec) then
raise EORMUtilsException.Create('Cannot register component for nil ORM record');
if FieldName = '' then
raise EORMUtilsException.Create('Field name cannot be empty');
Key.ORMRec := ORMRec;
Key.FieldName := FieldName;
// Check if component is already registered
if FComponentDict.ContainsKey(Key) then
begin
if FComponentDict[Key] = Component then
Exit;
UnregisterComponent(FComponentDict[Key]);
end;
// Add to dictionary
FComponentDict.Add(Key, Component);
// Get RTTI information for the property
Context := TRttiContext.Create;
RttiType := Context.GetType(ORMRec.ClassType);
Prop := RttiType.GetProperty(FieldName);
// Special handling for TComboBox with EnumValues attribute
if Component is TComboBox then
begin
// Look for EnumValues and Translation attributes
EnumAttr := nil;
TransAttr := nil;
// Check property attributes
for var Attr in Prop.GetAttributes do
begin
if Attr is EnumValuesAttribute then
EnumAttr := EnumValuesAttribute(Attr)
else if Attr is TranslationAttribute then
TransAttr := TranslationAttribute(Attr);
end;
// If not found, check field attributes
if not Assigned(EnumAttr) or not Assigned(TransAttr) then
begin
Field := RttiType.GetField('_' + FieldName);
if Assigned(Field) then
for var Attr in Field.GetAttributes do
begin
if (not Assigned(EnumAttr)) and (Attr is EnumValuesAttribute) then
EnumAttr := EnumValuesAttribute(Attr)
else if (not Assigned(TransAttr)) and (Attr is TranslationAttribute) then
TransAttr := TranslationAttribute(Attr);
end;
end;
// Populate combo box items if EnumValues attribute exists
if Assigned(EnumAttr) then
begin
TComboBox(Component).Style := csDropDownList;
TComboBox(Component).Items.Clear;
if Assigned(TransAttr) then
begin
// Use translated display values
for var Value in EnumAttr.GetValues do
TComboBox(Component).Items.Add(TransAttr.GetDisplayValue(Value));
end
else
begin
// Use raw enum values
for var Value in EnumAttr.GetValues do
TComboBox(Component).Items.Add(Value);
end;
// Set up event handler
TComboBox(Component).OnCloseUp := HandleComboCloseUp;
end;
end
else if Component is TCheckBox then
begin
// Set up OnClick event for TCheckBox
TCheckBox(Component).OnClick := HandleCheckBoxClick;
end;
// Update component with current ORM value
UpdateComponentFromORM(Component, ORMRec, FieldName);
end;
function TORMManager.FindComponent(ORMRec: TQryRecInfo; const FieldName: string): TComponent;
var
Key: TORMKey;
begin
Key.ORMRec:= ORMRec;
Key.FieldName:= FieldName;
if FComponentDict.TryGetValue(Key, Result) then Exit
else Result:= nil;
end;
function TORMManager.GetAllComponents: TArray<TComponent>;
var
Comp: TComponent;
CompList: TList<TComponent>;
begin
CompList:= TList<TComponent>.Create;
try
for Comp in FComponentDict.Values do CompList.Add(Comp);
Result:= CompList.ToArray;
finally
CompList.Free;
end;
end;
// Helper function to format information based on type
function FormataInfo(info: Variant; tipo: TORMFormatType): string;
begin
if VarIsNull(info) or VarIsEmpty(info) then Exit('');
case tipo of
tiString: Result:= VarToStr(info);
tiInteger: Result:= IntToStr(Integer(info));
tiMoney: Result:= FormatFloat(FMT_MONEY, Currency(info));
tiFloat: Result:= FloatToStr(info);
tiDate: if VarIsType(info, [varDate, varDouble]) then
begin
if VarToDateTime(info) < EncodeDate(1900, 1, 1) then Result:= ''
else Result:= FormatDateTime('dd/mm/yyyy', VarToDateTime(info));
end
else raise EORMUtilsException.CreateFmt('FormataInfo: Cannot treat information [%s] as tiDate.', [VarToStr(info)]);
tiDateTime: if VarIsType(info, [varDate, varDouble]) then
begin
if VarToDateTime(info) = 0 then Result:= ''
else Result:= FormatDateTime('dd/mm/yyyy hh:mm:ss', VarToDateTime(info));
end
else raise EORMUtilsException.CreateFmt('FormataInfo: Cannot treat information [%s] as tiDateTime.', [VarToStr(info)]);
tiBoolean: Result:= IfThen(Boolean(info), 'S', 'N');
tiByteArray: Result:= ByteArrayToHex(info);
tiNone: Result:= '';
else raise EORMUtilsException.CreateFmt('FormataInfo: Format type [%s] not recognized.', [GetEnumName(TypeInfo(TORMFormatType), Integer(tipo))]);
end;
end;
procedure SetValueToComponent(aComponent: TComponent; TipoProp: TORMFormatType; Value: Variant);
begin
if not Assigned(aComponent) then
Exit;
// First handle null and empty values
if VarIsNull(Value) or VarIsEmpty(Value) then
begin
case TipoProp of
tiDate, tiDateTime:
begin
if aComponent.InheritsFrom(TDateTimePicker) then
begin
try
(aComponent as TDateTimePicker).Format := ' ';
(aComponent as TDateTimePicker).DateTime := 0;
except
// Ignore any errors during clear operation
end;
end
else if aComponent is TEdit then
TEdit(aComponent).Text := ''
else if aComponent is TLabel then
TLabel(aComponent).Caption := '';
end;
tiString, tiInteger, tiFloat, tiMoney:
begin
if aComponent is TEdit then
TEdit(aComponent).Text := ''
else if aComponent is TLabel then
TLabel(aComponent).Caption := ''
else if aComponent is TMemo then
TMemo(aComponent).Lines.Clear
else if aComponent is TComboBox then
TComboBox(aComponent).ItemIndex := -1;
end;
tiBoolean:
begin
if aComponent is TCheckBox then
TCheckBox(aComponent).State := cbUnchecked;
end;
end;
Exit;
end;
// Now handle non-null values
try
case TipoProp of
tiString:
begin
if aComponent is TEdit then
TEdit(aComponent).Text := Value
else if aComponent is TLabel then
TLabel(aComponent).Caption := Value
else if aComponent is TMemo then
TMemo(aComponent).Lines.Text := Value
else if aComponent is TComboBox then
TComboBox(aComponent).Text := Value;
end;
tiInteger:
begin
if aComponent is TEdit then
TEdit(aComponent).Text := IntToStr(Value)
else if aComponent is TLabel then
TLabel(aComponent).Caption := IntToStr(Value)
else if aComponent is TComboBox then
TComboBox(aComponent).Text := IntToStr(Value);
end;
tiMoney, tiFloat:
begin
var FormattedValue := FormatFloat('#,##0.00', Value);
if aComponent is TEdit then
TEdit(aComponent).Text := FormattedValue
else if aComponent is TLabel then
TLabel(aComponent).Caption := FormattedValue
else if aComponent is TComboBox then
TComboBox(aComponent).Text := FormattedValue;
end;
tiDate, tiDateTime:
begin
try
var DateValue: TDateTime;
if VarIsStr(Value) then
DateValue := StrToDateTime(Value)
else
DateValue := VarToDateTime(Value);
if DateValue >= EncodeDate(1900, 1, 1) then
begin
if aComponent.InheritsFrom(TDateTimePicker) then
begin
if TipoProp = tiDate then
begin
(aComponent as TDateTimePicker).Format:= 'dd/MM/yyyy'; // restaura a formatação original
(aComponent as TDateTimePicker).Date := DateValue;
end
else
begin // TipoProp = tiDateTime
(aComponent as TDateTimePicker).Format:= 'dd/MM/yyyy HH:mm:ss'; // restaura a formatação original
(aComponent as TDateTimePicker).DateTime := DateValue;
end;
end
else if aComponent is TEdit then
begin
if TipoProp = tiDate then
TEdit(aComponent).Text := FormatDateTime('dd/mm/yyyy', DateValue)
else
TEdit(aComponent).Text := FormatDateTime('dd/mm/yyyy hh:mm:ss', DateValue);
end
else if aComponent is TLabel then
begin
if TipoProp = tiDate then
TLabel(aComponent).Caption := FormatDateTime('dd/mm/yyyy', DateValue)
else
TLabel(aComponent).Caption := FormatDateTime('dd/mm/yyyy hh:mm:ss', DateValue);
end;
end
else
begin
// Handle invalid dates by clearing the component
if aComponent.InheritsFrom(TDateTimePicker) then
begin
(aComponent as TDateTimePicker).Format := ' ';
(aComponent as TDateTimePicker).DateTime := 0;
end
else if aComponent is TEdit then
TEdit(aComponent).Text := ''
else if aComponent is TLabel then
TLabel(aComponent).Caption := '';
end;
except
on E: Exception do
begin
// Handle conversion errors by clearing the component
if aComponent.InheritsFrom(TDateTimePicker) then
begin
(aComponent as TDateTimePicker).Format := ' ';
(aComponent as TDateTimePicker).DateTime := 0;
end
else if aComponent is TEdit then
TEdit(aComponent).Text := ''
else if aComponent is TLabel then
TLabel(aComponent).Caption := '';
end;
end;
end;
tiBoolean:
begin
if aComponent is TCheckBox then
TCheckBox(aComponent).Checked := Boolean(Value)
else if aComponent is TEdit then
TEdit(aComponent).Text := BoolToStr(Boolean(Value), True)
else if aComponent is TLabel then
TLabel(aComponent).Caption := BoolToStr(Boolean(Value), True);
end;
else
raise Exception.CreateFmt('SetValueToComponent: Component [%s: %s] with type %s not handled',
[aComponent.Name, aComponent.ClassName, GetEnumName(TypeInfo(TORMFormatType), Ord(TipoProp))]);
end;
except
on E: Exception do
raise Exception.CreateFmt('Error setting value for component [%s: %s]: %s',
[aComponent.Name, aComponent.ClassName, E.Message]);
end;
end;
procedure TORMManager.UpdateComponentFromORM(Component: TComponent; ORMRec: TQryRecInfo; const FieldName: string);
var
ValueToUse: Variant;
Ctx: TRttiContext;
RttiType: TRttiType;
Prop: TRttiProperty;
Field: TRttiField;
FmtType: TORMFormatType;
PropValue: TValue;
HasValue: Boolean;
begin
Ctx := TRttiContext.Create;
RttiType := Ctx.GetType(ORMRec.ClassType);
Prop := RttiType.GetProperty(FieldName);
if not Assigned(Prop) then
raise EORMUtilsException.CreateFmt('Property "%s" not found.', [FieldName]);
// Get the property value
PropValue := Prop.GetValue(Pointer(ORMRec));
HasValue := True; // Default to true for non-nullable types
// Check if it's a TNullable type
if (Prop.PropertyType.TypeKind = tkRecord) and
Prop.PropertyType.Name.StartsWith('TNullable<') then
begin
var HasValueField := Prop.PropertyType.GetField('HasValue');
var ValueField := Prop.PropertyType.GetField('Value');
if Assigned(HasValueField) and Assigned(ValueField) then
begin
HasValue := HasValueField.GetValue(PropValue.GetReferenceToRawData).AsBoolean;
if HasValue then
ValueToUse := ValueField.GetValue(PropValue.GetReferenceToRawData).AsVariant
else
ValueToUse := Null;
end;
end
else
ValueToUse := PropValue.AsVariant;
// Get format type
FmtType := tiNone;
// Check for FmtProp attribute on the property
for var Attr in Prop.GetAttributes do
begin
if Attr is FmtPropAttribute then
begin
FmtType := FmtPropAttribute(Attr).FormatType;
Break;
end;
end;
// If not found on property, check on the field
if FmtType = tiNone then
begin
Field := RttiType.GetField('_' + FieldName);
if Assigned(Field) then
begin
for var Attr in Field.GetAttributes do
begin
if Attr is FmtPropAttribute then
begin
FmtType := FmtPropAttribute(Attr).FormatType;
Break;
end;
end;
end;
end;
// Determine format type if not set by attribute
if FmtType = tiNone then
begin
var UnderlyingType := Prop.PropertyType;
// Get underlying type of TNullable<T>
if UnderlyingType.Name.StartsWith('TNullable<') then
begin
var ValueField := UnderlyingType.GetField('Value');
if Assigned(ValueField) then
UnderlyingType := ValueField.FieldType;
end;
case UnderlyingType.TypeKind of
tkInteger, tkInt64:
FmtType := tiInteger;
tkFloat:
if UnderlyingType.Handle = TypeInfo(TDateTime) then
FmtType := tiDateTime
else if UnderlyingType.Handle = TypeInfo(Currency) then
FmtType := tiMoney
else
FmtType := tiFloat;
tkString, tkLString, tkWString, tkUString:
FmtType := tiString;
tkEnumeration:
if UnderlyingType.Handle = TypeInfo(Boolean) then
FmtType := tiBoolean
else
FmtType := tiString;
tkVariant:
FmtType := tiString;
else
FmtType := tiString;
end;
end;
// Now set the component value based on HasValue
if not HasValue then
SetValueToComponent(Component, FmtType, Null)
else
SetValueToComponent(Component, FmtType, ValueToUse);
end;
function TORMManager.GetORMRecForComponent(Component: TComponent): TQryRecInfo;
var
Key: TORMKey;
begin
Result:= nil;
for Key in FComponentDict.Keys do
if FComponentDict[Key] = Component then
begin
Result:= Key.ORMRec;
Exit;
end;
end;
function TORMManager.GetFieldNameForComponent(Component: TComponent): string;
var
Key: TORMKey;
begin
Result:= '';
for Key in FComponentDict.Keys do
if FComponentDict[Key] = Component then
begin
Result:= Key.FieldName;
Exit;
end;
end;
// =============================
// TComponentHelper Implementation
// =============================
function TComponentHelper.GetORMRec: TQryRecInfo;
begin
Result:= ORMManager.GetORMRecForComponent(Self);
end;
function TComponentHelper.GetORMRecField: string;
begin
Result:= ORMManager.GetFieldNameForComponent(Self);
end;
// =============================
// TQryRecInfo Implementation
// =============================
constructor TQryRecInfo.Create;
begin
inherited Create;
FFilterBuilder := TFilterBuilder.Create;
FDirtyFields:= TDictionary<string, Boolean>.Create;
FPreviousValues:= TDictionary<string, TValue>.Create;
FIsNewRec:= False; // Initialize as not new
end;
destructor TQryRecInfo.Destroy;
begin
FFilterBuilder.Free;
FDirtyFields.Free;
FPreviousValues.Free;
inherited;
end;
procedure TQryRecInfo.ClearDirtyFlags;
begin
FDirtyFields.Clear;
FIsNewRec:= False; // Reset IsNewRec when clearing dirty flags
end;
procedure TQryRecInfo.ClearPreviousValues;
begin
FPreviousValues.Clear;
end;
function TQryRecInfo.IsFieldDirty(const FieldName: string): Boolean;
begin
Result:= FDirtyFields.ContainsKey(FieldName) and FDirtyFields[FieldName];
end;
function TQryRecInfo.GetPreviousValue(const FieldName: string): TValue;
begin
if not FPreviousValues.TryGetValue(FieldName, Result) then raise EORMUtilsException.CreateFmt('No previous value found for field "%s".', [FieldName]);
end;
function TQryRecInfo.GetFormattedText(const FieldName: string): string;
var
Ctx: TRttiContext;
RttiType: TRttiType;
Prop: TRttiProperty;
Field: TRttiField;
Value: TValue;
FmtType: TORMFormatType;
UnderlyingType: TRttiType;
HasValueField: TRttiField;
ValueField: TRttiField;
HasValue: Boolean;
ActualValue: TValue;
Attr: TCustomAttribute;
FmtAttr: FmtPropAttribute;
begin
Result:= '';
Ctx:= TRttiContext.Create;
try
RttiType:= Ctx.GetType(Self.ClassType);
// Find the property by name
Prop:= RttiType.GetProperty(FieldName);
if not Assigned(Prop) then raise EORMUtilsException.CreateFmt('Property "%s" not found.', [FieldName]);
// Get the value of the property
Value:= Prop.GetValue(Self);
FmtType:= tiNone;
// Check for FmtProp attribute on the property
for Attr in Prop.GetAttributes do
begin
if Attr is FmtPropAttribute then
begin
FmtAttr:= FmtPropAttribute(Attr);
FmtType:= FmtAttr.FormatType;
Break;
end;
end;
// If not found on property, check on the corresponding field
if FmtType = tiNone then
begin
Field:= RttiType.GetField('_' + FieldName);
if Assigned(Field) then
begin
for Attr in Field.GetAttributes do
begin
if Attr is FmtPropAttribute then
begin
FmtAttr:= FmtPropAttribute(Attr);
FmtType:= FmtAttr.FormatType;
Break;
end;
end;
end;
end;
// Determine default FmtType based on property type if not set by attribute
if FmtType = tiNone then
begin
UnderlyingType:= Prop.PropertyType;
// Handle TNullable<T>
if UnderlyingType.TypeKind = tkRecord then
begin
ValueField:= UnderlyingType.GetField('Value');
if Assigned(ValueField) then UnderlyingType:= ValueField.FieldType;
end;
case UnderlyingType.TypeKind of
tkInteger, tkInt64: FmtType:= tiInteger;
tkFloat: if UnderlyingType.Handle = TypeInfo(TDateTime) then FmtType:= tiDateTime
else FmtType:= tiFloat;
tkString, tkLString, tkWString, tkUString: FmtType:= tiString;
tkEnumeration: if UnderlyingType.Handle = TypeInfo(Boolean) then FmtType:= tiBoolean
else FmtType:= tiString;
tkVariant: FmtType:= tiString;
else FmtType:= tiNone;
end;
end;
// Extract actual value from TNullable<T> if necessary
if Value.Kind = tkRecord then
begin
// Assuming TNullable<T> has 'HasValue' and 'Value' fields
UnderlyingType:= Prop.PropertyType;
HasValueField:= UnderlyingType.GetField('HasValue');
ValueField:= UnderlyingType.GetField('Value');
if Assigned(HasValueField) and Assigned(ValueField) then
begin
HasValue:= HasValueField.GetValue(Value.GetReferenceToRawData).AsBoolean;
if HasValue then
begin
ActualValue:= ValueField.GetValue(Value.GetReferenceToRawData);
// Format the actual value
Result:= FormataInfo(ActualValue.AsVariant, FmtType);
end
else Result:= '';
end
else
begin
// Not TNullable<T>, handle value directly
if not Value.IsEmpty then Result:= FormataInfo(Value.AsVariant, FmtType)
else Result:= '';
end;
end
else
begin
// Not a record, handle value directly
if not Value.IsEmpty then Result:= FormataInfo(Value.AsVariant, FmtType)
else Result:= '';
end;
finally
// No need to free TRttiContext as it's a record
end;
end;
procedure TQryRecInfo.Fetch(DBConn: TUniConnection; const QryTxt: string = '');
var
SQL: string;
qr: TUniQuery;
Ctx: TRttiContext;
ObjType: TRttiType;
Prop: TRttiProperty;
Field: TField;
ORMFieldName: string;
PropName: string;
begin
if not Assigned(DBConn) then
Exit;
// Use provided query or base query
if QryTxt <> '' then
SQL := QryTxt
else
begin
SQL := GetBaseQuery;
if SQL = '' then
raise EORMUtilsException.CreateFmt('No query provided and no base query found for class %s', [ClassName]);
end;
qr := TUniQuery.Create(nil);
try
qr.Connection := DBConn;
qr.SpecificOptions.Values['FetchAll'] := 'True';
qr.SpecificOptions.Values['CreateConnection'] := 'False';
qr.SQL.Text := SQL;
qr.Open;
if qr.RecordCount > 0 then
begin
Ctx := TRttiContext.Create;
try
ObjType := Ctx.GetType(Self.ClassType);
for Field in qr.Fields do
begin
PropName := FindPropertyByColumnName(Field.FieldName, ObjType);
if PropName = '' then
Continue;
ORMFieldName := '_' + PropName;
Prop := ObjType.GetProperty(PropName);
if not Assigned(Prop) or not Prop.IsWritable then
Continue;
if Prop.PropertyType.TypeKind = tkRecord then
begin
if Prop.PropertyType.Name.StartsWith('TNullable<') then
begin
if ObjType.GetField(ORMFieldName) = nil then
Continue;
if Field.IsNull then
begin
if Prop.PropertyType.Name = 'TNullable<System.string>' then
ObjType.GetField(ORMFieldName).SetValue(Self, TValue.From<TNullable<string>>(NullValue))
else if Prop.PropertyType.Name = 'TNullable<System.Integer>' then
ObjType.GetField(ORMFieldName).SetValue(Self, TValue.From<TNullable<Integer>>(NullValue))
else if Prop.PropertyType.Name = 'TNullable<System.Int64>' then
ObjType.GetField(ORMFieldName).SetValue(Self, TValue.From<TNullable<Int64>>(NullValue))
else if Prop.PropertyType.Name = 'TNullable<System.Extended>' then
ObjType.GetField(ORMFieldName).SetValue(Self, TValue.From<TNullable<Extended>>(NullValue))
else if Prop.PropertyType.Name = 'TNullable<System.Currency>' then
ObjType.GetField(ORMFieldName).SetValue(Self, TValue.From<TNullable<Currency>>(NullValue))
else if Prop.PropertyType.Name = 'TNullable<System.TDateTime>' then
ObjType.GetField(ORMFieldName).SetValue(Self, TValue.From<TNullable<TDateTime>>(NullValue))
else if Prop.PropertyType.Name = 'TNullable<System.Boolean>' then
ObjType.GetField(ORMFieldName).SetValue(Self, TValue.From<TNullable<Boolean>>(NullValue))
else if Prop.PropertyType.Name = 'TNullable<System.Variant>' then
ObjType.GetField(ORMFieldName).SetValue(Self, TValue.From<TNullable<Variant>>(NullValue))
else
raise EORMUtilsException.CreateFmt('Unsupported TNullable type: %s', [Prop.PropertyType.Name]);
end
else
begin
if Prop.PropertyType.Name = 'TNullable<System.string>' then
ObjType.GetField(ORMFieldName).SetValue(Self, TValue.From<TNullable<string>>(Field.AsString))
else if Prop.PropertyType.Name = 'TNullable<System.Integer>' then
ObjType.GetField(ORMFieldName).SetValue(Self, TValue.From<TNullable<Integer>>(Field.AsInteger))
else if Prop.PropertyType.Name = 'TNullable<System.Int64>' then
ObjType.GetField(ORMFieldName).SetValue(Self, TValue.From<TNullable<Int64>>(Field.AsLargeInt))
else if Prop.PropertyType.Name = 'TNullable<System.Extended>' then
ObjType.GetField(ORMFieldName).SetValue(Self, TValue.From<TNullable<Extended>>(Field.AsFloat))
else if Prop.PropertyType.Name = 'TNullable<System.Currency>' then
ObjType.GetField(ORMFieldName).SetValue(Self, TValue.From<TNullable<Currency>>(Field.AsCurrency))
else if Prop.PropertyType.Name = 'TNullable<System.TDateTime>' then
ObjType.GetField(ORMFieldName).SetValue(Self, TValue.From<TNullable<TDateTime>>(Field.AsDateTime))
else if Prop.PropertyType.Name = 'TNullable<System.Boolean>' then
begin
var BoolAttr := GetBooleanMapAttribute(ObjType, ORMFieldName);
ObjType.GetField(ORMFieldName).SetValue(Self, HandleBooleanMapping(Field, BoolAttr, True));
end
else if Prop.PropertyType.Name = 'TNullable<System.Variant>' then
ObjType.GetField(ORMFieldName).SetValue(Self, TValue.From<TNullable<Variant>>(Field.Value))
else
raise EORMUtilsException.CreateFmt('Unsupported TNullable type: %s', [Prop.PropertyType.Name]);
end;
end;
end
else
begin
case Prop.PropertyType.TypeKind of
tkString, tkLString, tkWString, tkUString:
ObjType.GetField(ORMFieldName).SetValue(Self, Field.AsString);
tkInteger:
ObjType.GetField(ORMFieldName).SetValue(Self, Field.AsInteger);
tkInt64:
ObjType.GetField(ORMFieldName).SetValue(Self, Field.AsLargeInt);
tkFloat:
if Prop.PropertyType.Handle = TypeInfo(Currency) then
ObjType.GetField(ORMFieldName).SetValue(Self, Field.AsCurrency)
else if Prop.PropertyType.Handle = TypeInfo(TDateTime) then
ObjType.GetField(ORMFieldName).SetValue(Self, Field.AsDateTime)
else
ObjType.GetField(ORMFieldName).SetValue(Self, Field.AsFloat);
tkVariant:
ObjType.GetField(ORMFieldName).SetValue(Self, TValue.FromVariant(Field.Value));
tkEnumeration:
if Prop.PropertyType.Handle = TypeInfo(Boolean) then
begin
var BoolAttr := GetBooleanMapAttribute(ObjType, ORMFieldName);
ObjType.GetField(ORMFieldName).SetValue(Self, HandleBooleanMapping(Field, BoolAttr, False));
end;
end;
end;
end;
ClearDirtyFlags;
ORMManager.UpdateComponentsForORMRec(Self);
finally
end;
end;
finally
qr.Free;
end;
end;
procedure TQryRecInfo.SetInfo(Index: Integer; const Value: TValue);
var
PropName: string;
PropKind: TTypeKind;
Ctx: TRttiContext;
Prop: TRttiProperty;
Field: TRttiField;
OldValue: TValue;
begin
// Retrieve property name and kind based on index
// Assuming that the index corresponds to the property order
Ctx:= TRttiContext.Create;
try
Prop:= Ctx.GetType(Self.ClassType).GetProperties()[index];
if not Assigned(Prop) then raise EORMUtilsException.CreateFmt('Error: The index "%d" does not correspond to any property in class "%s".', [index, ClassName]);
PropName:= Prop.Name;
PropKind:= Prop.PropertyType.TypeKind;
Field:= Ctx.GetType(Self.ClassType).GetField('_' + PropName);
if not Assigned(Field) then raise EORMUtilsException.CreateFmt('Error: Field "_%s" not found in class "%s".', [PropName, ClassName]);
// If the field is not yet dirty, store the previous value
if not FDirtyFields.ContainsKey(PropName) then
begin
OldValue:= Field.GetValue(Self);
FPreviousValues.AddOrSetValue(PropName, OldValue);
// Since a field is being modified, mark IsNewRec as true
FIsNewRec:= True;
end;
// Set the new value
Field.SetValue(Self, Value);
// Mark the property as dirty
FDirtyFields.AddOrSetValue(PropName, True);
// Trigger the OnPropertyChanged event
if Assigned(FOnPropertyChanged) then FOnPropertyChanged(Self, PropName)
else Self.HandlePropertyChange(PropName);
// Update corresponding component if any
var
UpdatedComp:= ORMManager.FindComponent(Self, PropName);
if Assigned(UpdatedComp) then ORMManager.UpdateComponentFromORM(UpdatedComp, ORMManager.GetORMRecForComponent(UpdatedComp), ORMManager.GetFieldNameForComponent(UpdatedComp));
finally
// No need to free TRttiContext as it's a record
end;
end;
procedure TQryRecInfo.SetInfoCurrency(Index: Integer; const Value: Currency);
begin
SetInfo(index, TValue.From<Currency>(Value));
end;
procedure TQryRecInfo.SetInfoString(Index: Integer; const Value: string);
begin
SetInfo(index, TValue.From<string>(Value));
end;
procedure TQryRecInfo.SetInfoInteger(Index: Integer; const Value: Integer);
begin
SetInfo(index, TValue.From<Integer>(Value));
end;
procedure TQryRecInfo.SetInfoInt64(Index: Integer; const Value: Int64);
begin
SetInfo(index, TValue.From<Int64>(Value));
end;
procedure TQryRecInfo.SetInfoExtended(Index: Integer; const Value: Extended);
begin
SetInfo(index, TValue.From<Extended>(Value));
end;
procedure TQryRecInfo.SetInfoDateTime(Index: Integer; const Value: TDateTime);
begin
SetInfo(index, TValue.From<TDateTime>(Value));
end;
procedure TQryRecInfo.SetInfoBoolean(Index: Integer; const Value: Boolean);
begin
SetInfo(index, TValue.From<Boolean>(Value));
end;
procedure TQryRecInfo.SetInfoVariant(Index: Integer; const Value: Variant);
begin
SetInfo(index, TValue.From<Variant>(Value));
end;
procedure TQryRecInfo.SetInfoNullableBoolean(Index: Integer; const Value: TNullable<Boolean>);
begin
SetInfo(index, TValue.From < TNullable < Boolean >> (Value));
end;
procedure TQryRecInfo.SetInfoNullableCurrency(Index: Integer; const Value: TNullable<Currency>);
begin
SetInfo(index, TValue.From < TNullable < Currency >> (Value));
end;
procedure TQryRecInfo.SetInfoNullableDateTime(Index: Integer; const Value: TNullable<TDateTime>);
begin
SetInfo(index, TValue.From < TNullable < TDateTime >> (Value));
end;
procedure TQryRecInfo.SetInfoNullableExtended(Index: Integer; const Value: TNullable<Extended>);
begin
SetInfo(index, TValue.From < TNullable < Extended >> (Value));
end;
procedure TQryRecInfo.SetInfoNullableInteger(Index: Integer; const Value: TNullable<Integer>);
begin
SetInfo(index, TValue.From < TNullable < Integer >> (Value));
end;
procedure TQryRecInfo.SetInfoNullableInt64(Index: Integer; const Value: TNullable<Int64>);
begin
SetInfo(index, TValue.From < TNullable < Int64 >> (Value));
end;
procedure TQryRecInfo.SetInfoNullableString(Index: Integer; const Value: TNullable<string>);
begin
SetInfo(index, TValue.From < TNullable < string >> (Value));
end;
procedure TQryRecInfo.SetInfoNullableVariant(Index: Integer; const Value: TNullable<Variant>);
begin
SetInfo(index, TValue.From < TNullable < Variant >> (Value));
end;
function TQryRecInfo.GetPropertyValue(const PropertyName: string): TValue;
begin
Result := TValue.Empty;
var Ctx := TRttiContext.Create;
try
var RttiType := Ctx.GetType(Self.ClassType);
var Prop := RttiType.GetProperty(PropertyName);
if not Assigned(Prop) then
raise EORMUtilsException.CreateFmt('Property "%s" not found.', [PropertyName]);
// Get the value of the property
var Value := Prop.GetValue(Self);
// Check if the value is TNullable<T>
if Prop.PropertyType.TypeKind = tkRecord then
begin
var HasValueField := Prop.PropertyType.GetField('HasValue');
var ValueField := Prop.PropertyType.GetField('Value');
if Assigned(HasValueField) and Assigned(ValueField) then
begin
var HasValue := HasValueField.GetValue(Value.GetReferenceToRawData).AsBoolean;
if HasValue then
Result := ValueField.GetValue(Value.GetReferenceToRawData)
else
Result := TValue.FromVariant(Null); // Important change here
end
else
Result := Value;
end
else
Result := Value;
finally
end;
end;
function FormatValueByType(const Value: string; FormatType: TORMFormatType;
IsNullable: Boolean): Variant;
var
TempDate: TDateTime;
begin
// Handle empty values
if Value.Trim = '' then
begin
if IsNullable then
Result := Null
else
raise Exception.Create('This field cannot be empty.');
Exit;
end;
case FormatType of
tiString:
Result := Value;
tiInteger:
Result := PegaInt(Value); // Always succeeds
tiMoney:
Result := GetMoney(Value); // Always succeeds
tiFloat:
Result := PegaFloat(Value); // Always succeeds
tiDate, tiDateTime:
begin
if not TryStrToDateTime(Value, TempDate) then
begin
var ValidDate := False;
for var DateFormat in DATE_FORMATS do
begin
if TryStrToDateTime(Value, TempDate) then
begin
ValidDate := True;
Break;
end;
end;
if not ValidDate then
raise Exception.Create('Please enter a valid date (dd/mm/yyyy).');
end;
Result := TempDate;
end;
tiBoolean:
begin
var UpperValue := UpperCase(Value);
if (UpperValue = 'TRUE') or (UpperValue = 'T') or (UpperValue = 'YES') or
(UpperValue = 'Y') or (UpperValue = 'S') or (UpperValue = '1') then
Result := True
else if (UpperValue = 'FALSE') or (UpperValue = 'F') or (UpperValue = 'NO') or
(UpperValue = 'N') or (UpperValue = '0') then
Result := False
else
raise Exception.Create('Please enter a valid boolean value (Yes/No, True/False, 1/0).');
end;
else
Result := Value; // Default case
end;
end;
// =============================
// TQryRecArray<T> Implementation
// =============================
constructor TQryRecArray<T>.Create;
begin
inherited Create;
FQryRecInfoList:= TObjectList<T>.Create(True); // Owns objects
end;
destructor TQryRecArray<T>.Destroy;
begin
FQryRecInfoList.Free;
inherited;
end;
procedure TQryRecArray<T>.Add(AItem: T);
begin
FQryRecInfoList.Add(AItem); // Add to the underlying list
end;
procedure TQryRecArray<T>.Delete(Index: Integer);
begin
if (index < 0) or (index >= FQryRecInfoList.Count) then raise EORMUtilsException.CreateFmt('Index %d out of bounds.', [index]);
FQryRecInfoList.Delete(index); // Remove from the underlying list
end;
procedure TQryRecArray<T>.Move(OldIndex, NewIndex: Integer);
begin
if (OldIndex < 0) or (OldIndex >= FQryRecInfoList.Count) or (NewIndex < 0) or (NewIndex >= FQryRecInfoList.Count) then
raise EORMUtilsException.CreateFmt('Invalid move operation: OldIndex=%d, NewIndex=%d, Count=%d', [OldIndex, NewIndex, FQryRecInfoList.Count]);
FQryRecInfoList.Move(OldIndex, NewIndex); // Move the record in the underlying list
end;
function TQryRecArray<T>.GetCount: Integer;
begin
Result:= FQryRecInfoList.Count;
end;
function TQryRecArray<T>.Rec(Index: Integer): T;
begin
if (index < 0) or (index >= FQryRecInfoList.Count) then raise EORMUtilsException.CreateFmt('Index %d out of bounds.', [index]);
Result:= FQryRecInfoList[index];
end;
procedure TQryRecArray<T>.FetchAllInstance(DBConn: TUniConnection; const QryTxt: string = '');
var
SQL: string;
BaseQuery: string;
qr: TUniQuery;
RecInstance: T;
Ctx: TRttiContext;
ObjType: TRttiType;
Prop: TRttiProperty;
Field: TField;
ORMFieldName: string;
PropName: string;
PropertyCache: TDictionary<string, string>;
FieldsCache: TDictionary<string, TRttiField>;
begin
if not Assigned(DBConn) then
raise Exception.Create('Database connection (DBConn) is not assigned.');
// Use provided query or base query
if QryTxt <> '' then
SQL := QryTxt
else
begin
BaseQuery := T.GetBaseQuery;
if BaseQuery = '' then
raise EORMUtilsException.CreateFmt('No query provided and no base query found for class %s', [T.ClassName]);
SQL := BaseQuery;
end;
// Create caches
PropertyCache := TDictionary<string, string>.Create;
FieldsCache := TDictionary<string, TRttiField>.Create;
qr := TUniQuery.Create(nil);
try
qr.Connection := DBConn;
qr.SpecificOptions.Values['FetchAll'] := 'True';
qr.SpecificOptions.Values['CreateConnection'] := 'False';
qr.SQL.Text := SQL;
qr.Open;
if qr.IsEmpty then
Exit;
Ctx := TRttiContext.Create;
try
ObjType := Ctx.GetType(T);
// Pre-build the property mapping cache for all fields
for Field in qr.Fields do
begin
PropName := FindPropertyByColumnName(Field.FieldName, ObjType);
if PropName <> '' then
begin
PropertyCache.Add(Field.FieldName, PropName);
ORMFieldName := '_' + PropName;
var BackingField := ObjType.GetField(ORMFieldName);
if Assigned(BackingField) then
FieldsCache.Add(Field.FieldName, BackingField);
end;
end;
// Process each record
while not qr.Eof do
begin
RecInstance := T.Create;
try
// Process each field using cached mapping
for Field in qr.Fields do
begin
if not PropertyCache.TryGetValue(Field.FieldName, PropName) then
Continue;
var BackingField: TRttiField;
if not FieldsCache.TryGetValue(Field.FieldName, BackingField) then
Continue;
// Get the property information
Prop := ObjType.GetProperty(PropName);
if not Assigned(Prop) then
Continue;
// Handle TNullable<T> types
if Prop.PropertyType.TypeKind = tkRecord then
begin
if Prop.PropertyType.Name.StartsWith('TNullable<') then
begin
if Field.IsNull then
begin
if Prop.PropertyType.Name = 'TNullable<System.string>' then
BackingField.SetValue(Pointer(RecInstance), TValue.From<TNullable<string>>(NullValue))
else if Prop.PropertyType.Name = 'TNullable<System.Integer>' then
BackingField.SetValue(Pointer(RecInstance), TValue.From<TNullable<Integer>>(NullValue))
else if Prop.PropertyType.Name = 'TNullable<System.Int64>' then
BackingField.SetValue(Pointer(RecInstance), TValue.From<TNullable<Int64>>(NullValue))
else if Prop.PropertyType.Name = 'TNullable<System.Extended>' then
BackingField.SetValue(Pointer(RecInstance), TValue.From<TNullable<Extended>>(NullValue))
else if Prop.PropertyType.Name = 'TNullable<System.Currency>' then
BackingField.SetValue(Pointer(RecInstance), TValue.From<TNullable<Currency>>(NullValue))
else if Prop.PropertyType.Name = 'TNullable<System.TDateTime>' then
BackingField.SetValue(Pointer(RecInstance), TValue.From<TNullable<TDateTime>>(NullValue))
else if Prop.PropertyType.Name = 'TNullable<System.Boolean>' then
BackingField.SetValue(Pointer(RecInstance), TValue.From<TNullable<Boolean>>(NullValue))
else if Prop.PropertyType.Name = 'TNullable<System.Variant>' then
BackingField.SetValue(Pointer(RecInstance), TValue.From<TNullable<Variant>>(NullValue))
else
raise EORMUtilsException.CreateFmt('Unsupported TNullable type: %s', [Prop.PropertyType.Name]);
end
else
begin
if Prop.PropertyType.Name = 'TNullable<System.string>' then
BackingField.SetValue(Pointer(RecInstance), TValue.From<TNullable<string>>(Field.AsString))
else if Prop.PropertyType.Name = 'TNullable<System.Integer>' then
BackingField.SetValue(Pointer(RecInstance), TValue.From<TNullable<Integer>>(Field.AsInteger))
else if Prop.PropertyType.Name = 'TNullable<System.Int64>' then
BackingField.SetValue(Pointer(RecInstance), TValue.From<TNullable<Int64>>(Field.AsLargeInt))
else if Prop.PropertyType.Name = 'TNullable<System.Extended>' then
BackingField.SetValue(Pointer(RecInstance), TValue.From<TNullable<Extended>>(Field.AsFloat))
else if Prop.PropertyType.Name = 'TNullable<System.Currency>' then
BackingField.SetValue(Pointer(RecInstance), TValue.From<TNullable<Currency>>(Field.AsCurrency))
else if Prop.PropertyType.Name = 'TNullable<System.TDateTime>' then
BackingField.SetValue(Pointer(RecInstance), TValue.From<TNullable<TDateTime>>(Field.AsDateTime))
else if Prop.PropertyType.Name = 'TNullable<System.Boolean>' then
begin
var BoolAttr := GetBooleanMapAttribute(ObjType, BackingField.Name);
BackingField.SetValue(Pointer(RecInstance), HandleBooleanMapping(Field, BoolAttr, True));
end
else if Prop.PropertyType.Name = 'TNullable<System.Variant>' then
BackingField.SetValue(Pointer(RecInstance), TValue.From<TNullable<Variant>>(Field.Value))
else
raise EORMUtilsException.CreateFmt('Unsupported TNullable type: %s', [Prop.PropertyType.Name]);
end;
end;
end
else
begin
// Handle non-nullable types
case Prop.PropertyType.TypeKind of
tkString, tkLString, tkWString, tkUString:
BackingField.SetValue(Pointer(RecInstance), Field.AsString);
tkInteger:
BackingField.SetValue(Pointer(RecInstance), Field.AsInteger);
tkInt64:
BackingField.SetValue(Pointer(RecInstance), Field.AsLargeInt);
tkFloat:
if Prop.PropertyType.Handle = TypeInfo(Currency) then
BackingField.SetValue(Pointer(RecInstance), Field.AsCurrency)
else if Prop.PropertyType.Handle = TypeInfo(TDateTime) then
BackingField.SetValue(Pointer(RecInstance), Field.AsDateTime)
else
BackingField.SetValue(Pointer(RecInstance), Field.AsFloat);
tkVariant:
BackingField.SetValue(Pointer(RecInstance), TValue.FromVariant(Field.Value));
tkEnumeration:
if Prop.PropertyType.Handle = TypeInfo(Boolean) then
begin
var BoolAttr := GetBooleanMapAttribute(ObjType, BackingField.Name);
BackingField.SetValue(Pointer(RecInstance), HandleBooleanMapping(Field, BoolAttr, False));
end;
end;
end;
end;
// Add the populated record to the list
if RecInstance is TQryRecInfo then
TQryRecInfo(RecInstance).ClearDirtyFlags;
FQryRecInfoList.Add(RecInstance);
RecInstance := nil; // Prevent double-free
except
RecInstance.Free;
raise;
end;
qr.Next;
end;
finally
// No need to free TRttiContext as it's a record
end;
finally
PropertyCache.Free;
FieldsCache.Free;
qr.Free;
end;
end;
function TQryRecArray<T>.GetEnumerator: TEnumerator<T>;
begin
Result:= FQryRecInfoList.GetEnumerator;
end;
class function TQryRecArray<T>.FetchAll(DBConn: TUniConnection; const QryTxt: string): TQryRecArray<T>;
var
Instance: TQryRecArray<T>;
begin
Instance:= TQryRecArray<T>.Create;
try
Instance.FetchAllInstance(DBConn, QryTxt);
Result:= Instance;
except
Instance.Free;
raise;
end;
end;
function TORMManager.GetPropertyIndex(ORMRec: TQryRecInfo; const PropertyName: string): Integer;
var
Context: TRttiContext;
RttiType: TRttiType;
Props: TArray<TRttiProperty>;
begin
Result := -1;
Context := TRttiContext.Create;
RttiType := Context.GetType(ORMRec.ClassType);
Props := RttiType.GetProperties;
// Find the property index based on declaration order of published properties
for var i := 0 to High(Props) do
if (Props[i].Visibility = mvPublished) and
(SameText(Props[i].Name, PropertyName)) then
begin
Result := i;
Break;
end;
end;
procedure TORMManager.HandleEditExit(Sender: TObject);
var
Component: TComponent;
ORMRec: TQryRecInfo;
FieldName: string;
PropIndex: Integer;
begin
Component := TComponent(Sender);
ORMRec := GetORMRecForComponent(Component);
if not Assigned(ORMRec) then Exit;
FieldName := GetFieldNameForComponent(Component);
if FieldName = '' then Exit;
PropIndex := GetPropertyIndex(ORMRec, FieldName);
if PropIndex = -1 then Exit;
var Context := TRttiContext.Create;
var RttiType := Context.GetType(ORMRec.ClassType);
var Prop := RttiType.GetProperty(FieldName);
if not Assigned(Prop) then Exit;
if Prop.PropertyType.Name.StartsWith('TNullable<') then
begin
if TEdit(Component).Text = '' then
begin
if Prop.PropertyType.Name = 'TNullable<System.string>' then
ORMRec.SetInfoNullableString(PropIndex, NullValue)
else if Prop.PropertyType.Name = 'TNullable<System.Integer>' then
ORMRec.SetInfoNullableInteger(PropIndex, NullValue)
else if Prop.PropertyType.Name = 'TNullable<System.Currency>' then
ORMRec.SetInfoNullableCurrency(PropIndex, NullValue)
else if Prop.PropertyType.Name = 'TNullable<System.TDateTime>' then
ORMRec.SetInfoNullableDateTime(PropIndex, NullValue);
end
else
begin
if Prop.PropertyType.Name = 'TNullable<System.string>' then
ORMRec.SetInfoNullableString(PropIndex, TEdit(Component).Text)
else if Prop.PropertyType.Name = 'TNullable<System.Integer>' then
ORMRec.SetInfoNullableInteger(PropIndex, PegaInt(TEdit(Component).Text))
else if Prop.PropertyType.Name = 'TNullable<System.Currency>' then
ORMRec.SetInfoNullableCurrency(PropIndex, GetMoney(TEdit(Component).Text))
else if Prop.PropertyType.Name = 'TNullable<System.TDateTime>' then
begin
var FmtType := tiNone;
// Check property for format type attribute
for var Attr in Prop.GetAttributes do
if Attr is FmtPropAttribute then
begin
FmtType := FmtPropAttribute(Attr).FormatType;
Break;
end;
// If not found on property, check field
if FmtType = tiNone then
begin
var Field := RttiType.GetField('_' + FieldName);
if Assigned(Field) then
for var Attr in Field.GetAttributes do
if Attr is FmtPropAttribute then
begin
FmtType := FmtPropAttribute(Attr).FormatType;
Break;
end;
end;
// Use appropriate conversion based on format type
if FmtType = tiDate then
ORMRec.SetInfoNullableDateTime(PropIndex, PegaData(TEdit(Component).Text))
else
ORMRec.SetInfoNullableDateTime(PropIndex, PegaDataHora(TEdit(Component).Text));
end;
end;
end
else
begin
case Prop.PropertyType.TypeKind of
tkString, tkLString, tkWString, tkUString:
ORMRec.SetInfoString(PropIndex, TEdit(Component).Text);
tkInteger:
ORMRec.SetInfoInteger(PropIndex, PegaInt(TEdit(Component).Text));
tkFloat:
if Prop.PropertyType.Handle = TypeInfo(Currency) then
ORMRec.SetInfoCurrency(PropIndex, GetMoney(TEdit(Component).Text))
else if Prop.PropertyType.Handle = TypeInfo(TDateTime) then
begin
var FmtType := tiNone;
// Check property for format type attribute
for var Attr in Prop.GetAttributes do
if Attr is FmtPropAttribute then
begin
FmtType := FmtPropAttribute(Attr).FormatType;
Break;
end;
// If not found on property, check field
if FmtType = tiNone then
begin
var Field := RttiType.GetField('_' + FieldName);
if Assigned(Field) then
for var Attr in Field.GetAttributes do
if Attr is FmtPropAttribute then
begin
FmtType := FmtPropAttribute(Attr).FormatType;
Break;
end;
end;
// Use appropriate conversion based on format type
if FmtType = tiDate then
ORMRec.SetInfoDateTime(PropIndex, PegaData(TEdit(Component).Text))
else
ORMRec.SetInfoDateTime(PropIndex, PegaDataHora(TEdit(Component).Text));
end;
end;
end;
end;
procedure TORMManager.HandleDatePickerCloseUp(Sender: TObject);
var
Component: TComponent;
ORMRec: TQryRecInfo;
FieldName: string;
PropIndex: Integer;
begin
Component := TComponent(Sender);
ORMRec := GetORMRecForComponent(Component);
if not Assigned(ORMRec) then Exit;
FieldName := GetFieldNameForComponent(Component);
if FieldName = '' then Exit;
PropIndex := GetPropertyIndex(ORMRec, FieldName);
if PropIndex = -1 then Exit;
ORMRec.SetInfoNullableDateTime(PropIndex, TAdvDateTimePicker(Component).DateTime);
end;
procedure TORMManager.UnregisterComponentsByORM(ORMRec: TQryRecInfo);
var
CopyKeys: TArray<TORMKey>;
Key: TORMKey;
Component: TComponent;
begin
if not Assigned(ORMRec) then
Exit;
// Get a copy of the dictionary keys to avoid modification during iteration
CopyKeys := FComponentDict.Keys.ToArray;
// Iterate through all mappings
for Key in CopyKeys do
begin
if Key.ORMRec = ORMRec then
begin
// Get the component before removing from dictionary
if FComponentDict.TryGetValue(Key, Component) then
begin
// Remove event handlers based on component type
if Component is TEdit then
TEdit(Component).OnExit := nil
else if Component is TComboBox then
TComboBox(Component).OnCloseUp := nil
else if Component.InheritsFrom(TDateTimePicker) then
begin
(Component as TDateTimePicker).OnCloseUp := nil;
(Component as TDateTimePicker).OnExit := nil;
end
else if Component is TCheckBox then
TCheckBox(Component).OnClick := nil;
// Remove from dictionary
FComponentDict.Remove(Key);
end;
end;
end;
end;
procedure TORMManager.RegisterComponentsByHint(MyForm: TForm; ORMRec: TQryRecInfo);
var
Context: TRttiContext;
RttiType: TRttiType;
RttiProperty: TRttiProperty;
Component: TComponent;
HintValue: TValue;
begin
Context := TRttiContext.Create;
try
for Component in MyForm do
begin
RttiType := Context.GetType(Component.ClassType);
RttiProperty := RttiType.GetProperty('Hint');
if Assigned(RttiProperty) then
begin
HintValue := RttiProperty.GetValue(Component);
if HintValue.IsEmpty then Continue;
RttiType := Context.GetType(ORMRec.ClassType);
for RttiProperty in RttiType.GetProperties do
begin
if (RttiProperty.Visibility = mvPublished) then
begin
if SameText(HintValue.AsString, RttiProperty.Name) then
begin
RegisterComponent(Component, ORMRec, RttiProperty.Name);
// Set up OnExit event handlers based on component type
if Component is TEdit then
TEdit(Component).OnExit := HandleEditExit
else if Component is TComboBox then
TComboBox(Component).OnCloseUp := HandleComboCloseUp
else if Component.InheritsFrom(TDateTimePicker) then
begin
(Component as TDateTimePicker).OnCloseUp := HandleDatePickerCloseUp;
(Component as TDateTimePicker).OnExit := HandleDatePickerCloseUp;
end
else if Component is TCheckBox then
TCheckBox(Component).OnClick := HandleCheckBoxClick;
Break;
end;
end;
end;
end;
end;
finally
Context.Free;
end;
end;
procedure TORMManager.UnregisterComponent(Component: TComponent);
begin
// Remove event handlers based on component type
if Component is TCheckBox then
TCheckBox(Component).OnClick := nil
else if Component is TComboBox then
TComboBox(Component).OnCloseUp := nil;
// Existing code for removing from dictionary
var CopyKeys := FComponentDict.Keys.ToArray;
for var i := 0 to Length(CopyKeys) - 1 do
begin
var Key := CopyKeys[i];
if FComponentDict[Key] = Component then
FComponentDict.Remove(Key);
end;
end;
procedure TORMManager.HandleCheckBoxClick(Sender: TObject);
var
Component: TComponent;
ORMRec: TQryRecInfo;
FieldName: string;
PropIndex: Integer;
Context: TRttiContext;
RttiType: TRttiType;
Prop: TRttiProperty;
begin
Component := TComponent(Sender);
ORMRec := GetORMRecForComponent(Component);
if not Assigned(ORMRec) then Exit;
FieldName := GetFieldNameForComponent(Component);
if FieldName = '' then Exit;
PropIndex := GetPropertyIndex(ORMRec, FieldName);
if PropIndex = -1 then Exit;
// Get property type info
Context := TRttiContext.Create;
RttiType := Context.GetType(ORMRec.ClassType);
Prop := RttiType.GetProperty(FieldName);
if not Assigned(Prop) then Exit;
// Check if property is TNullable<Boolean> or plain Boolean
if Prop.PropertyType.Name.StartsWith('TNullable<') then
// Handle nullable boolean
ORMRec.SetInfoNullableBoolean(PropIndex, TCheckBox(Component).Checked)
else if Prop.PropertyType.Handle = TypeInfo(Boolean) then
// Handle non-nullable boolean
ORMRec.SetInfoBoolean(PropIndex, TCheckBox(Component).Checked)
else
raise EORMUtilsException.CreateFmt('Property %s is not a boolean type', [FieldName]);
end;
procedure TORMManager.HandleComboCloseUp(Sender: TObject);
var
Component: TComponent;
ORMRec: TQryRecInfo;
FieldName: string;
PropIndex: Integer;
ComboBox: TComboBox;
EnumAttr: EnumValuesAttribute;
TransAttr: TranslationAttribute;
Value: string;
begin
Component := TComponent(Sender);
ComboBox := TComboBox(Component);
ORMRec := GetORMRecForComponent(Component);
if not Assigned(ORMRec) then Exit;
FieldName := GetFieldNameForComponent(Component);
if FieldName = '' then Exit;
PropIndex := GetPropertyIndex(ORMRec, FieldName);
if PropIndex = -1 then Exit;
// Get the selected value
if ComboBox.ItemIndex = -1 then
begin
ORMRec.SetInfoNullableString(PropIndex, NullValue);
Exit;
end;
Value := ComboBox.Items[ComboBox.ItemIndex];
// Check for translation attribute to convert display value to stored value
var Context := TRttiContext.Create;
var RttiType := Context.GetType(ORMRec.ClassType);
var Prop := RttiType.GetProperty(FieldName);
TransAttr := nil;
for var Attr in Prop.GetAttributes do
if Attr is TranslationAttribute then
begin
TransAttr := TranslationAttribute(Attr);
Break;
end;
if not Assigned(TransAttr) then
begin
var Field := RttiType.GetField('_' + FieldName);
if Assigned(Field) then
for var Attr in Field.GetAttributes do
if Attr is TranslationAttribute then
begin
TransAttr := TranslationAttribute(Attr);
Break;
end;
end;
if Assigned(TransAttr) then
Value := TransAttr.GetStoredValue(Value);
ORMRec.SetInfoNullableString(PropIndex, Value);
end;
procedure TORMManager.UpdateComponentsForORMRec(ORMRec: TQryRecInfo);
var
Key: TORMKey;
Component: TComponent;
ComponentKeys: TArray<TORMKey>;
Context: TRttiContext;
RttiType: TRttiType;
Prop: TRttiProperty;
Field: TRttiField;
EnumAttr: EnumValuesAttribute;
TransAttr: TranslationAttribute;
ComboBox: TComboBox;
StoredValue: string;
DisplayValue: string;
PropValue: TValue;
begin
if not Assigned(ORMRec) then
Exit;
Context := TRttiContext.Create;
RttiType := Context.GetType(ORMRec.ClassType);
ComponentKeys := FComponentDict.Keys.ToArray;
for Key in ComponentKeys do
begin
if Key.ORMRec = ORMRec then
begin
if not FComponentDict.TryGetValue(Key, Component) then
Continue;
try
if Component is TComboBox then
begin
ComboBox := TComboBox(Component);
Prop := RttiType.GetProperty(Key.FieldName);
if not Assigned(Prop) then
Continue;
// Get EnumValues and Translation attributes
EnumAttr := nil;
TransAttr := nil;
// Check property attributes
for var Attr in Prop.GetAttributes do
begin
if Attr is EnumValuesAttribute then
EnumAttr := EnumValuesAttribute(Attr)
else if Attr is TranslationAttribute then
TransAttr := TranslationAttribute(Attr);
end;
// If not found on property, check field
if not Assigned(EnumAttr) or not Assigned(TransAttr) then
begin
Field := RttiType.GetField('_' + Key.FieldName);
if Assigned(Field) then
for var Attr in Field.GetAttributes do
begin
if (not Assigned(EnumAttr)) and (Attr is EnumValuesAttribute) then
EnumAttr := EnumValuesAttribute(Attr)
else if (not Assigned(TransAttr)) and (Attr is TranslationAttribute) then
TransAttr := TranslationAttribute(Attr);
end;
end;
// Get the current value from the property
PropValue := ORMRec.GetPropertyValue(Key.FieldName);
// Handle nullable types
if PropValue.TypeInfo = TypeInfo(TNullable<string>) then
begin
var NullableStr := PropValue.AsType<TNullable<string>>;
if not NullableStr.HasValue then
begin
ComboBox.ItemIndex := -1;
Continue;
end;
StoredValue := NullableStr.Value;
end
else
StoredValue := PropValue.AsString;
// Clear and repopulate items if using enum values
if Assigned(EnumAttr) then
begin
ComboBox.Items.Clear;
if Assigned(TransAttr) then
begin
// Add translated display values
for var EnumValue in EnumAttr.GetValues do
ComboBox.Items.Add(TransAttr.GetDisplayValue(EnumValue));
// Find and set the translated display value
if StoredValue <> '' then
begin
DisplayValue := TransAttr.GetDisplayValue(StoredValue);
ComboBox.ItemIndex := ComboBox.Items.IndexOf(DisplayValue);
end
else
ComboBox.ItemIndex := -1;
end
else
begin
// Add raw enum values
for var EnumValue in EnumAttr.GetValues do
ComboBox.Items.Add(EnumValue);
// Set the stored value directly
ComboBox.ItemIndex := ComboBox.Items.IndexOf(StoredValue);
end;
end
else
ComboBox.Text := StoredValue; // Non-enum case
end
else
UpdateComponentFromORM(Component, ORMRec, Key.FieldName);
except
on E: Exception do
raise EORMUtilsException.CreateFmt('Error updating component for field %s: %s',
[Key.FieldName, E.Message]);
end;
end;
end;
end;
procedure TORMManager.HandlePropertyChanged(Sender: TQryRecInfo;
const PropertyName: string);
var
Key: TORMKey;
Component: TComponent;
ComponentKeys: TArray<TORMKey>;
Context: TRttiContext;
RttiType: TRttiType;
TransAttr: TranslationAttribute;
ComboBox: TComboBox;
StoredValue: string;
DisplayValue: string;
begin
if not Assigned(Sender) then
Exit;
Context := TRttiContext.Create;
RttiType := Context.GetType(Sender.ClassType);
ComponentKeys := FComponentDict.Keys.ToArray;
// Find all components bound to this ORM record and property
for Key in ComponentKeys do
begin
if (Key.ORMRec = Sender) and SameText(Key.FieldName, PropertyName) then
begin
if not FComponentDict.TryGetValue(Key, Component) then
Continue;
try
if Component is TComboBox then
begin
ComboBox := TComboBox(Component);
var Prop := RttiType.GetProperty(Key.FieldName);
if not Assigned(Prop) then
Continue;
// Handle enums with translations
TransAttr := nil;
// Check property attributes
for var Attr in Prop.GetAttributes do
begin
if Attr is TranslationAttribute then
begin
TransAttr := TranslationAttribute(Attr);
Break;
end;
end;
// If not found on property, check field
if not Assigned(TransAttr) then
begin
var Field := RttiType.GetField('_' + Key.FieldName);
if Assigned(Field) then
for var Attr in Field.GetAttributes do
if Attr is TranslationAttribute then
begin
TransAttr := TranslationAttribute(Attr);
Break;
end;
end;
// Get current value and handle translation
StoredValue := Sender.GetFormattedText(PropertyName);
if Assigned(TransAttr) then
DisplayValue := TransAttr.GetDisplayValue(StoredValue)
else
DisplayValue := StoredValue;
// Update combo selection
ComboBox.ItemIndex := ComboBox.Items.IndexOf(DisplayValue);
end
else
UpdateComponentFromORM(Component, Sender, Key.FieldName);
except
on E: Exception do
raise Exception.CreateFmt('Error updating component for field %s: %s',
[Key.FieldName, E.Message]);
end;
end;
end;
end;
procedure TQryRecInfo.HandlePropertyChange(const PropertyName: string);
var
Context: TRttiContext;
RttiType: TRttiType;
Prop: TRttiProperty;
Field: TRttiField;
CurrentValue: TValue;
PrevValue: TValue;
TransAttr: TranslationAttribute;
FormatAttr: FmtPropAttribute;
FormatType: TORMFormatType;
CurrentDisplay: string;
PrevDisplay: string;
Attr: TCustomAttribute;
PropType: TRttiType;
ValueField: TRttiField;
HasValueField: TRttiField;
begin
if not Assigned(FOnPropertyChanged) then
Exit;
Context := TRttiContext.Create;
try
RttiType := Context.GetType(Self.ClassType);
Prop := RttiType.GetProperty(PropertyName);
if not Assigned(Prop) then
Exit;
// Get the current value
CurrentValue := Prop.GetValue(Self);
// Get the field format type
FormatType := tiNone;
TransAttr := nil;
// Check property attributes first
for Attr in Prop.GetAttributes do
begin
if (FormatType = tiNone) and (Attr is FmtPropAttribute) then
FormatType := FmtPropAttribute(Attr).FormatType
else if not Assigned(TransAttr) and (Attr is TranslationAttribute) then
TransAttr := TranslationAttribute(Attr);
end;
// If not found, check backing field
if (FormatType = tiNone) or not Assigned(TransAttr) then
begin
Field := RttiType.GetField('_' + PropertyName);
if Assigned(Field) then
begin
for Attr in Field.GetAttributes do
begin
if (FormatType = tiNone) and (Attr is FmtPropAttribute) then
FormatType := FmtPropAttribute(Attr).FormatType
else if not Assigned(TransAttr) and (Attr is TranslationAttribute) then
TransAttr := TranslationAttribute(Attr);
end;
end;
end;
// If still no format type, infer from property type
if FormatType = tiNone then
begin
PropType := Prop.PropertyType;
// Handle TNullable<T>
if (PropType.TypeKind = tkRecord) and PropType.Name.StartsWith('TNullable<') then
begin
ValueField := PropType.GetField('Value');
if Assigned(ValueField) then
PropType := ValueField.FieldType;
end;
case PropType.TypeKind of
tkInteger, tkInt64:
FormatType := tiInteger;
tkFloat:
if PropType.Handle = TypeInfo(TDateTime) then
FormatType := tiDateTime
else if PropType.Handle = TypeInfo(Currency) then
FormatType := tiMoney
else
FormatType := tiFloat;
tkString, tkLString, tkWString, tkUString:
FormatType := tiString;
tkEnumeration:
if PropType.Handle = TypeInfo(Boolean) then
FormatType := tiBoolean
else
FormatType := tiString;
tkVariant:
FormatType := tiString;
else
FormatType := tiString;
end;
end;
// Format the current value
CurrentDisplay := GetFormattedText(PropertyName);
if Assigned(TransAttr) then
CurrentDisplay := TransAttr.GetDisplayValue(CurrentDisplay);
finally
// Context is a record, no need to free
end;
end;
procedure TQryRecInfo.SetORMProperty(const FieldName: string; const Value: TValue);
var
Ctx: TRttiContext;
Prop: TRttiProperty;
ObjType: TRttiType;
Field: TRttiField;
PropIndex: Integer;
Props: TArray<TRttiProperty>;
ConvertedValue: TValue;
IsNullValue: Boolean;
begin
Ctx := TRttiContext.Create;
try
ObjType := Ctx.GetType(Self.ClassType);
Prop := ObjType.GetProperty(FieldName);
Field := ObjType.GetField('_' + FieldName);
if not (Assigned(Prop) and Assigned(Field)) then
raise EORMUtilsException.CreateFmt('Property or field "%s" not found', [FieldName]);
// Get property index for SetInfo methods
Props := ObjType.GetProperties;
PropIndex := -1;
for var i := 0 to High(Props) do
begin
if Props[i].Name = FieldName then
begin
PropIndex := i;
Break;
end;
end;
if PropIndex = -1 then
raise EORMUtilsException.CreateFmt('Property index not found for "%s"', [FieldName]);
// Store previous value if not already marked dirty
if not Self.DirtyFields.ContainsKey(FieldName) then
Self.PreviousValues.AddOrSetValue(FieldName, Field.GetValue(Pointer(Self)));
// Mark as dirty
Self.DirtyFields.AddOrSetValue(FieldName, True);
// Handle TNullable types
if Prop.PropertyType.TypeKind = tkRecord then
begin
var PropTypeName := Prop.PropertyType.Name;
if PropTypeName.StartsWith('TNullable<') then
begin
// Check if the provided value is already a TNullable type
if Value.TypeInfo = Prop.PropertyType.Handle then
begin
// Value is already the correct TNullable type, use it directly
Field.SetValue(Pointer(Self), Value);
end
else
begin
// Need to convert to appropriate TNullable type
IsNullValue := Value.IsEmpty or VarIsNull(Value.AsVariant);
if IsNullValue then
begin
if PropTypeName = 'TNullable<System.string>' then
Field.SetValue(Pointer(Self), TValue.From<TNullable<string>>(NullValue))
else if PropTypeName = 'TNullable<System.Integer>' then
Field.SetValue(Pointer(Self), TValue.From<TNullable<Integer>>(NullValue))
else if PropTypeName = 'TNullable<System.Int64>' then
Field.SetValue(Pointer(Self), TValue.From<TNullable<Int64>>(NullValue))
else if PropTypeName = 'TNullable<System.Extended>' then
Field.SetValue(Pointer(Self), TValue.From<TNullable<Extended>>(NullValue))
else if PropTypeName = 'TNullable<System.Currency>' then
Field.SetValue(Pointer(Self), TValue.From<TNullable<Currency>>(NullValue))
else if PropTypeName = 'TNullable<System.TDateTime>' then
Field.SetValue(Pointer(Self), TValue.From<TNullable<TDateTime>>(NullValue))
else if PropTypeName = 'TNullable<System.Boolean>' then
Field.SetValue(Pointer(Self), TValue.From<TNullable<Boolean>>(NullValue))
else if PropTypeName = 'TNullable<System.Variant>' then
Field.SetValue(Pointer(Self), TValue.From<TNullable<Variant>>(NullValue))
else
raise EORMUtilsException.CreateFmt('Unsupported TNullable type: %s', [PropTypeName]);
end
else
begin
if PropTypeName = 'TNullable<System.string>' then
Field.SetValue(Pointer(Self), TValue.From<TNullable<string>>(Value.AsString))
else if PropTypeName = 'TNullable<System.Integer>' then
Field.SetValue(Pointer(Self), TValue.From<TNullable<Integer>>(Value.AsInteger))
else if PropTypeName = 'TNullable<System.Int64>' then
Field.SetValue(Pointer(Self), TValue.From<TNullable<Int64>>(Value.AsInt64))
else if PropTypeName = 'TNullable<System.Extended>' then
Field.SetValue(Pointer(Self), TValue.From<TNullable<Extended>>(Value.AsExtended))
else if PropTypeName = 'TNullable<System.Currency>' then
Field.SetValue(Pointer(Self), TValue.From<TNullable<Currency>>(Value.AsCurrency))
else if PropTypeName = 'TNullable<System.TDateTime>' then
Field.SetValue(Pointer(Self), TValue.From<TNullable<TDateTime>>(Value.AsType<TDateTime>))
else if PropTypeName = 'TNullable<System.Boolean>' then
Field.SetValue(Pointer(Self), TValue.From<TNullable<Boolean>>(Value.AsBoolean))
else if PropTypeName = 'TNullable<System.Variant>' then
Field.SetValue(Pointer(Self), TValue.From<TNullable<Variant>>(Value.AsVariant))
else
raise EORMUtilsException.CreateFmt('Unsupported TNullable type: %s', [PropTypeName]);
end;
end;
end;
end
else
begin
// Handle non-nullable types
if Value.IsEmpty then
raise EORMUtilsException.CreateFmt('Cannot set null value to non-nullable property "%s"', [FieldName]);
case Prop.PropertyType.TypeKind of
tkString, tkLString, tkWString, tkUString:
Field.SetValue(Pointer(Self), Value.AsString);
tkInteger:
Field.SetValue(Pointer(Self), Value.AsInteger);
tkInt64:
Field.SetValue(Pointer(Self), Value.AsInt64);
tkFloat:
if Prop.PropertyType.Handle = TypeInfo(Currency) then
Field.SetValue(Pointer(Self), Value.AsCurrency)
else if Prop.PropertyType.Handle = TypeInfo(TDateTime) then
Field.SetValue(Pointer(Self), Value.AsType<TDateTime>)
else
Field.SetValue(Pointer(Self), Value.AsExtended);
tkEnumeration:
if Prop.PropertyType.Handle = TypeInfo(Boolean) then
Field.SetValue(Pointer(Self), Value.AsBoolean);
tkVariant:
Field.SetValue(Pointer(Self), Value.AsString);
end;
end;
// Trigger the OnPropertyChanged event if assigned
if Assigned(FOnPropertyChanged) then
FOnPropertyChanged(Self, FieldName);
finally
// TRttiContext is a record and managed automatically
end;
end;
function TQryRecInfo.GetStoredValueFromDisplay(const PropertyName, DisplayValue: string): string;
var
Context: TRttiContext;
RttiType: TRttiType;
Prop: TRttiProperty;
Field: TRttiField;
TransAttr: TranslationAttribute;
begin
Result := DisplayValue; // Default to original value if no translation found
Context := TRttiContext.Create;
try
RttiType := Context.GetType(Self.ClassType);
// First check property attributes
Prop := RttiType.GetProperty(PropertyName);
if Assigned(Prop) then
begin
for var Attr in Prop.GetAttributes do
begin
if Attr is TranslationAttribute then
begin
TransAttr := TranslationAttribute(Attr);
Result := TransAttr.GetStoredValue(DisplayValue);
Exit;
end;
end;
end;
// If not found on property, check backing field
Field := RttiType.GetField('_' + PropertyName);
if Assigned(Field) then
begin
for var Attr in Field.GetAttributes do
begin
if Attr is TranslationAttribute then
begin
TransAttr := TranslationAttribute(Attr);
Result := TransAttr.GetStoredValue(DisplayValue);
Exit;
end;
end;
end;
finally
// TRttiContext is a record, no need to free
end;
end;
class function TQryRecInfo.GetBaseQuery: string;
begin
// First check class variable
if FBaseQuery <> '' then
Result := FBaseQuery
else
// Then check manager
Result := TBaseQueryManager.GetInstance.GetBaseQuery(Self);
end;
class procedure TQryRecInfo.SetBaseQuery(const AQuery: string);
begin
FBaseQuery := AQuery;
TBaseQueryManager.GetInstance.SetBaseQuery(Self, AQuery);
end;
class procedure TQryRecInfo.ClearBaseQuery;
begin
FBaseQuery := '';
TBaseQueryManager.GetInstance.RemoveBaseQuery(Self);
end;
procedure TORMManager.SetTranslatedValue(Component: TComponent; const DisplayValue: string);
var
ORMRec: TQryRecInfo;
FieldName: string;
StoredValue: string;
begin
if not Assigned(Component) then
raise EORMUtilsException.Create('Component cannot be nil');
// Get the bound ORM record and field name
ORMRec := GetORMRecForComponent(Component);
if not Assigned(ORMRec) then
raise EORMUtilsException.CreateFmt('No ORM record bound to component %s', [Component.Name]);
FieldName := GetFieldNameForComponent(Component);
if FieldName = '' then
raise EORMUtilsException.CreateFmt('No field name bound to component %s', [Component.Name]);
// Get the translated stored value
StoredValue := ORMRec.GetStoredValueFromDisplay(FieldName, DisplayValue);
// Set the value using RTTI
ORMRec.SetORMProperty(FieldName, TValue.From<TNullable<string>>(StoredValue));
end;
function HandleBooleanMapping(Field: TField; BoolAttr: BooleanMapAttribute; IsNullable: Boolean): TValue;
var
IsValid: Boolean;
BoolValue: Boolean;
begin
if Field.IsNull then
begin
if IsNullable then
Result := TValue.From<TNullable<Boolean>>(NullValue)
else
Result := False;
Exit;
end;
if Assigned(BoolAttr) then
begin
BoolValue := BoolAttr.ToBool(Field.AsString, IsValid);
if not IsValid then
begin
if IsNullable then
Result := TValue.From<TNullable<Boolean>>(NullValue)
else
Result := False;
end
else if IsNullable then
Result := TValue.From<TNullable<Boolean>>(BoolValue)
else
Result := BoolValue;
end
else if IsNullable then
Result := TValue.From<TNullable<Boolean>>(Field.AsBoolean)
else
Result := Field.AsBoolean;
end;
// Helper function to handle boolean mapping
function GetBooleanMapAttribute(RttiType: TRttiType; const FieldName: string): BooleanMapAttribute;
begin
Result := nil;
var Field := RttiType.GetField(FieldName);
if Assigned(Field) then
begin
for var Attr in Field.GetAttributes do
begin
if Attr is BooleanMapAttribute then
Exit(BooleanMapAttribute(Attr));
end;
end;
var Prop := RttiType.GetProperty(Copy(FieldName, 2, MaxInt)); // Remove leading underscore
if Assigned(Prop) then
begin
for var Attr in Prop.GetAttributes do
begin
if Attr is BooleanMapAttribute then
Exit(BooleanMapAttribute(Attr));
end;
end;
end;
{ TBaseQueryManager }
constructor TBaseQueryManager.Create;
begin
inherited;
FBaseQueries := TDictionary<TClass, string>.Create;
end;
destructor TBaseQueryManager.Destroy;
begin
FBaseQueries.Free;
inherited;
end;
function TBaseQueryManager.GetBaseQuery(AClass: TClass): string;
var
Context: TRttiContext;
RttiType: TRttiType;
Attr: TCustomAttribute;
begin
Result := '';
// First check cache
if FBaseQueries.TryGetValue(AClass, Result) then
Exit;
// If not in cache, check for attribute
Context := TRttiContext.Create;
try
RttiType := Context.GetType(AClass);
for Attr in RttiType.GetAttributes do
begin
if Attr is BaseQueryAttribute then
begin
Result := BaseQueryAttribute(Attr).BaseQuery;
FBaseQueries.Add(AClass, Result);
Break;
end;
end;
finally
// Context is a record, no need to free
end;
end;
procedure TBaseQueryManager.SetBaseQuery(AClass: TClass; const AQuery: string);
begin
FBaseQueries.AddOrSetValue(AClass, AQuery);
end;
procedure TBaseQueryManager.RemoveBaseQuery(AClass: TClass);
begin
FBaseQueries.Remove(AClass);
end;
function TBaseQueryManager.HasBaseQuery(AClass: TClass): Boolean;
begin
Result := FBaseQueries.ContainsKey(AClass) or
(GetBaseQuery(AClass) <> ''); // This will check attribute and cache it
end;
class function TBaseQueryManager.GetInstance: TBaseQueryManager;
begin
if not Assigned(FInstance) then
FInstance := TBaseQueryManager.Create;
Result := FInstance;
end;
class procedure TBaseQueryManager.ReleaseInstance;
begin
FreeAndNil(FInstance);
end;
{ TFilterGroup }
constructor TFilterGroup.Create(AConcatenator: TFilterConcatenator);
begin
inherited Create;
FItems := TList<TFilterItem>.Create;
FConcatenator := AConcatenator;
FParenthesisLevel := 0;
end;
destructor TFilterGroup.Destroy;
begin
FItems.Free;
inherited;
end;
function TFilterGroup.AddSingleFilter(const FieldName: string; FilterType: TFilterType;
const Value: Variant; Concatenator: TFilterConcatenator; Parenthesis: TFilterParenthesis): TFilterGroup;
var
Item: TFilterItem;
begin
Item.FieldName := FieldName;
Item.FilterType := FilterType;
Item.Value1 := Value;
Item.Value2 := Null;
Item.Concatenator := Concatenator;
Item.Parenthesis := Parenthesis;
FItems.Add(Item);
Result := Self;
end;
function TFilterGroup.AddRangeFilter(const FieldName: string; FilterType: TFilterType;
const Value1, Value2: Variant; Concatenator: TFilterConcatenator; Parenthesis: TFilterParenthesis): TFilterGroup;
var
Item: TFilterItem;
begin
Item.FieldName := FieldName;
Item.FilterType := FilterType;
Item.Value1 := Value1;
Item.Value2 := Value2;
Item.Concatenator := Concatenator;
Item.Parenthesis := Parenthesis;
FItems.Add(Item);
Result := Self;
end;
function TFilterGroup.FormatDateTimeValue(const Value: Variant; const Format: string): string;
var
DateValue: TDateTime;
begin
if VarIsNull(Value) or VarIsEmpty(Value) then
Exit('NULL');
if VarIsStr(Value) then
DateValue := StrToDateTime(Value)
else
DateValue := VarToDateTime(Value);
if Format = '' then
Result := QuotedStr(FormatDateTime('yyyy-mm-dd hh:nn:ss', DateValue))
else
Result := QuotedStr(FormatDateTime(Format, DateValue));
end;
function TFilterGroup.ProcessDateTimeFilter(const Item: TFilterItem): string;
var
FormattedValue1, FormattedValue2: string;
begin
case Item.FilterType of
tfBetween:
begin
FormattedValue1 := FormatDateTimeValue(Item.Value1, 'yyyy-mm-dd 00:00:00');
FormattedValue2 := FormatDateTimeValue(Item.Value2, 'yyyy-mm-dd 23:59:59');
Result := Format('%s BETWEEN %s AND %s',
[Item.FieldName, FormattedValue1, FormattedValue2]);
end;
tfGreaterThan, tfGreaterOrEqual:
begin
FormattedValue1 := FormatDateTimeValue(Item.Value1, 'yyyy-mm-dd 00:00:00');
Result := Format('%s %s %s',
[Item.FieldName,
IfThen(Item.FilterType = tfGreaterThan, '>', '>='),
FormattedValue1]);
end;
tfLessThan, tfLessOrEqual:
begin
FormattedValue1 := FormatDateTimeValue(Item.Value1, 'yyyy-mm-dd 23:59:59');
Result := Format('%s %s %s',
[Item.FieldName,
IfThen(Item.FilterType = tfLessThan, '<', '<='),
FormattedValue1]);
end;
else
FormattedValue1 := FormatDateTimeValue(Item.Value1, Item.DateTimeFormat);
Result := Format('%s = %s', [Item.FieldName, FormattedValue1]);
end;
end;
function TFilterGroup.GetFilterText: string;
var
Item: TFilterItem;
ItemText: string;
I: Integer;
IsFirst: Boolean;
function GetOperator(FilterType: TFilterType): string;
begin
case FilterType of
tfEqualTo: Result := '=';
tfNotEqualTo: Result := '<>';
tfGreaterThan: Result := '>';
tfGreaterOrEqual: Result := '>=';
tfLessThan: Result := '<';
tfLessOrEqual: Result := '<=';
else Result := '=';
end;
end;
function FormatValue(const Value: Variant): string;
begin
if VarIsNull(Value) or VarIsEmpty(Value) then
Result := 'NULL'
else if VarIsStr(Value) then
Result := QuotedStr(Value)
else if VarIsFloat(Value) then
Result := FormatFloat('0.####', Value)
else
Result := VarToStr(Value);
end;
begin
Result := '';
if FItems.Count = 0 then
Exit;
IsFirst := True;
for I := 0 to FItems.Count - 1 do
begin
Item := FItems[I];
// Add concatenator if not first item
if not IsFirst then
Result := Result + ' ' + IfThen(Item.Concatenator = fcAnd, 'AND', 'OR') + ' '
else
IsFirst := False;
// Add opening parenthesis if needed
if Item.Parenthesis in [fpOpen, fpBoth] then
Result := Result + '(';
// Build filter condition based on type
case Item.FilterType of
tfIsNull:
ItemText := Format('%s IS NULL', [Item.FieldName]);
tfIsNotNull:
ItemText := Format('%s IS NOT NULL', [Item.FieldName]);
tfBetween, tfNotBetween:
begin
if (VarIsNull(Item.Value1) or VarIsNull(Item.Value2)) then
raise EFilterException.CreateFmt('Both values required for BETWEEN operator on field %s',
[Item.FieldName]);
ItemText := Format('%s %sBETWEEN %s AND %s',
[Item.FieldName,
IfThen(Item.FilterType = tfNotBetween, 'NOT ', ''),
FormatValue(Item.Value1),
FormatValue(Item.Value2)]);
end;
tfInList, tfNotInList:
begin
if VarIsNull(Item.Value1) then
raise EFilterException.CreateFmt('Value list required for IN operator on field %s',
[Item.FieldName]);
ItemText := Format('%s %sIN (%s)',
[Item.FieldName,
IfThen(Item.FilterType = tfNotInList, 'NOT ', ''),
Item.Value1]);
end;
tfLike, tfNotLike, tfBeginsWith, tfEndsWith, tfContains:
begin
var LikeValue := Item.Value1;
case Item.FilterType of
tfBeginsWith: LikeValue := LikeValue + '%';
tfEndsWith: LikeValue := '%' + LikeValue;
tfContains: LikeValue := '%' + LikeValue + '%';
end;
ItemText := Format('%s %sLIKE %s',
[Item.FieldName,
IfThen(Item.FilterType = tfNotLike, 'NOT ', ''),
QuotedStr(LikeValue)]);
end;
else
if Item.DateTimeFormat <> '' then
ItemText := ProcessDateTimeFilter(Item)
else
ItemText := Format('%s %s %s',
[Item.FieldName,
GetOperator(Item.FilterType),
FormatValue(Item.Value1)]);
end;
Result := Result + ItemText;
// Add closing parenthesis if needed
if Item.Parenthesis in [fpClose, fpBoth] then
Result := Result + ')';
end;
end;
{ TFilterBuilder }
constructor TFilterBuilder.Create;
begin
inherited;
FGroups := TObjectList<TFilterGroup>.Create(True);
Clear;
end;
destructor TFilterBuilder.Destroy;
begin
FGroups.Free;
inherited;
end;
function TFilterBuilder.Where(const FieldName: string): TFilterBuilder;
begin
if not Assigned(FCurrentGroup) then
FCurrentGroup := TFilterGroup.Create;
FCurrentFieldName := FieldName;
Result := Self;
end;
function TFilterBuilder.AndWhere(const FieldName: string): TFilterBuilder;
begin
Result := Where(FieldName);
end;
function TFilterBuilder.OrWhere(const FieldName: string): TFilterBuilder;
begin
if not Assigned(FCurrentGroup) then
FCurrentGroup := TFilterGroup.Create(fcOr);
FCurrentFieldName := FieldName;
Result := Self;
end;
procedure TFilterBuilder.ValidateCurrentField;
begin
if FCurrentFieldName = '' then
raise EFilterException.Create('No field specified. Call Where() first.');
end;
function TFilterBuilder.AddFilterInternal(FilterType: TFilterType; const Value: Variant): TFilterBuilder;
begin
ValidateCurrentField;
if Assigned(FCurrentGroup) then
FCurrentGroup.AddSingleFilter(FCurrentFieldName, FilterType, Value);
FCurrentFieldName := '';
Result := Self;
end;
function TFilterBuilder.EqualTo(const Value: Variant): TFilterBuilder;
begin
Result := AddFilterInternal(tfEqualTo, Value);
end;
function TFilterBuilder.NotEqualTo(const Value: Variant): TFilterBuilder;
begin
Result := AddFilterInternal(tfNotEqualTo, Value);
end;
function TFilterBuilder.GreaterThan(const Value: Variant): TFilterBuilder;
begin
Result := AddFilterInternal(tfGreaterThan, Value);
end;
function TFilterBuilder.GreaterOrEqual(const Value: Variant): TFilterBuilder;
begin
Result := AddFilterInternal(tfGreaterOrEqual, Value);
end;
function TFilterBuilder.LessThan(const Value: Variant): TFilterBuilder;
begin
Result := AddFilterInternal(tfLessThan, Value);
end;
function TFilterBuilder.LessOrEqual(const Value: Variant): TFilterBuilder;
begin
Result := AddFilterInternal(tfLessOrEqual, Value);
end;
function TFilterBuilder.Between(const Value1, Value2: Variant): TFilterBuilder;
begin
ValidateCurrentField;
if Assigned(FCurrentGroup) then
FCurrentGroup.AddRangeFilter(FCurrentFieldName, tfBetween, Value1, Value2);
FCurrentFieldName := '';
Result := Self;
end;
function TFilterBuilder.NotBetween(const Value1, Value2: Variant): TFilterBuilder;
begin
ValidateCurrentField;
if Assigned(FCurrentGroup) then
FCurrentGroup.AddRangeFilter(FCurrentFieldName, tfNotBetween, Value1, Value2);
FCurrentFieldName := '';
Result := Self;
end;
function TFilterBuilder.InList(const Values: array of Variant): TFilterBuilder;
var
ValueList: string;
I: Integer;
begin
ValidateCurrentField;
ValueList := '';
for I := Low(Values) to High(Values) do
begin
if I > Low(Values) then
ValueList := ValueList + ',';
if VarIsStr(Values[I]) then
ValueList := ValueList + QuotedStr(Values[I])
else if VarIsFloat(Values[I]) then
ValueList := ValueList + FormatFloat('0.####', Values[I])
else
ValueList := ValueList + VarToStr(Values[I]);
end;
if Assigned(FCurrentGroup) then
FCurrentGroup.AddSingleFilter(FCurrentFieldName, tfInList, ValueList);
FCurrentFieldName := '';
Result := Self;
end;
function TFilterBuilder.NotInList(const Values: array of Variant): TFilterBuilder;
var
ValueList: string;
I: Integer;
begin
ValidateCurrentField;
ValueList := '';
for I := Low(Values) to High(Values) do
begin
if I > Low(Values) then
ValueList := ValueList + ',';
if VarIsStr(Values[I]) then
ValueList := ValueList + QuotedStr(Values[I])
else if VarIsFloat(Values[I]) then
ValueList := ValueList + FormatFloat('0.####', Values[I])
else
ValueList := ValueList + VarToStr(Values[I]);
end;
if Assigned(FCurrentGroup) then
FCurrentGroup.AddSingleFilter(FCurrentFieldName, tfNotInList, ValueList);
FCurrentFieldName := '';
Result := Self;
end;
function TFilterBuilder.IsNull: TFilterBuilder;
begin
ValidateCurrentField;
if Assigned(FCurrentGroup) then
FCurrentGroup.AddSingleFilter(FCurrentFieldName, tfIsNull, Null);
FCurrentFieldName := '';
Result := Self;
end;
function TFilterBuilder.IsNotNull: TFilterBuilder;
begin
ValidateCurrentField;
if Assigned(FCurrentGroup) then
FCurrentGroup.AddSingleFilter(FCurrentFieldName, tfIsNotNull, Null);
FCurrentFieldName := '';
Result := Self;
end;
function TFilterBuilder.Like(const Value: string): TFilterBuilder;
begin
ValidateCurrentField;
if Assigned(FCurrentGroup) then
FCurrentGroup.AddSingleFilter(FCurrentFieldName, tfLike, Value);
FCurrentFieldName := '';
Result := Self;
end;
function TFilterBuilder.NotLike(const Value: string): TFilterBuilder;
begin
ValidateCurrentField;
if Assigned(FCurrentGroup) then
FCurrentGroup.AddSingleFilter(FCurrentFieldName, tfNotLike, Value);
FCurrentFieldName := '';
Result := Self;
end;
function TFilterBuilder.BeginsWith(const Value: string): TFilterBuilder;
begin
ValidateCurrentField;
if Assigned(FCurrentGroup) then
FCurrentGroup.AddSingleFilter(FCurrentFieldName, tfBeginsWith, Value);
FCurrentFieldName := '';
Result := Self;
end;
function TFilterBuilder.EndsWith(const Value: string): TFilterBuilder;
begin
ValidateCurrentField;
if Assigned(FCurrentGroup) then
FCurrentGroup.AddSingleFilter(FCurrentFieldName, tfEndsWith, Value);
FCurrentFieldName := '';
Result := Self;
end;
function TFilterBuilder.Contains(const Value: string): TFilterBuilder;
begin
ValidateCurrentField;
if Assigned(FCurrentGroup) then
FCurrentGroup.AddSingleFilter(FCurrentFieldName, tfContains, Value);
FCurrentFieldName := '';
Result := Self;
end;
function TFilterBuilder.AddFilter(const FieldName: string; FilterType: TFilterType;
const Value: Variant; Concatenator: TFilterConcatenator): TFilterBuilder;
begin
if not Assigned(FCurrentGroup) then
FCurrentGroup := TFilterGroup.Create;
FCurrentGroup.AddSingleFilter(FieldName, FilterType, Value, Concatenator);
Result := Self;
end;
function TFilterBuilder.BeginGroup: TFilterBuilder;
begin
if Assigned(FCurrentGroup) then
begin
FGroups.Add(FCurrentGroup);
FCurrentGroup := TFilterGroup.Create;
end;
Result := Self;
end;
function TFilterBuilder.EndGroup: TFilterBuilder;
begin
if Assigned(FCurrentGroup) then
begin
if FGroups.Count > 0 then
begin
var LastGroup := FGroups[FGroups.Count - 1];
LastGroup.AddSingleFilter('', tfEqualTo, '', fcAnd, fpOpen);
for var Item in FCurrentGroup.Items do
LastGroup.Items.Add(Item);
LastGroup.AddSingleFilter('', tfEqualTo, '', fcAnd, fpClose);
FCurrentGroup.Free;
FCurrentGroup := LastGroup;
FGroups.Delete(FGroups.Count - 1);
end;
end;
Result := Self;
end;
function TFilterBuilder.Clear: TFilterBuilder;
begin
FGroups.Clear;
if Assigned(FCurrentGroup) then
FreeAndNil(FCurrentGroup);
FCurrentFieldName := '';
Result := Self;
end;
function TFilterBuilder.GetFilterText: string;
begin
if Assigned(FCurrentGroup) then
Result := FCurrentGroup.FilterText
else
Result := '';
end;
procedure TFilterBuilder.ApplyToQuery(var SQL: string);
begin
var FilterText := GetFilterText;
if FilterText <> '' then
begin
if Pos('WHERE', UpperCase(SQL)) > 0 then
SQL := SQL + ' AND ' + FilterText
else
SQL := SQL + ' WHERE ' + FilterText;
end;
end;
{ TQryRecInfo }
function TQryRecInfo.Filter: TFilterBuilder;
begin
Result := FFilterBuilder;
end;
function TQryRecInfo.ClearFilter: TQryRecInfo;
begin
FFilterBuilder.Clear;
Result := Self;
end;
procedure TQryRecInfo.FetchFiltered(DBConn: TUniConnection; const QryTxt: string = '');
var
SQL: string;
begin
if QryTxt <> '' then
SQL := QryTxt
else
SQL := GetBaseQuery;
if SQL = '' then
raise Exception.CreateFmt('No query provided and no base query found for class %s',
[ClassName]);
// Apply filters
if Assigned(FFilterBuilder) then
FFilterBuilder.ApplyToQuery(SQL);
// Call inherited Fetch with modified SQL
Fetch(DBConn, SQL);
end;
procedure TQryRecInfo.ApplyFilters(var SQL: string);
begin
if Assigned(FFilterBuilder) then
FFilterBuilder.ApplyToQuery(SQL);
end;
initialization
ORMManager:= TORMManager.Create;
finalization
ORMManager.Free;
end.
Check what is wrong