Delphi TStringList Find method cannot find item - delphi

I am writing my own class to manage the translation of android/ios app and I have produced this code. I will explain the code below but it's pretty easy and short.
unit Localization;
interface
uses
System.Classes, System.SysUtils, Generics.Collections, Vcl.Dialogs;
//this class represents a single language (Italian, French, German...)
type
TLanguage = class
private
FTranslationList: TDictionary<string, string>;
function localize(const aWordId: string): string;
public
constructor Create;
destructor Destroy; override;
//methods
procedure addWord(const aIndex, aWord: string);
procedure removeWord(const aIndex: string);
end;
//this is a "container", it gathers all the languages in one place
type
TLocalization = class
private
FLanguagesList: TObjectList<TLanguage>;
FLocaleList: TStringList;
function getLang(Index: string): TLanguage;
public
constructor Create;
destructor Destroy; override;
//methods
function localize(const aLocaleId: string; const aIndex: string): string;
procedure addLanguage(const localeId: string);
//property to manage the languages
property Locale[Index: string]: TLanguage read getLang;
property langCount: integer read getCount;
end;
implementation
{ TLocalization }
{ add a new language to the class. }
{the localeId is a symbol like 'it' that represents the Italian language}
procedure TLocalization.addLanguage(const localeId: string);
begin
//add the language to the languages container
FLanguagesList.Add(TLanguage.Create);
//add the representation of the language.
FLocaleList.Add(localeId);
end;
constructor TLocalization.Create;
begin
FLanguagesList := TObjectList<TLanguage>.Create;
FLocaleList := TStringList.Create;
end;
destructor TLocalization.Destroy;
begin
FLanguagesList.Free;
FLocaleList.Free;
inherited;
end;
//ERROR HERE
function TLocalization.getLang(Index: string): TLanguage;
var i: integer;
begin
{ I search the locale id (for example 'it') if it's in the list. }
{ if it's in the list, I return the respective TLanguage object}
if not( FLocaleList.Find(Index, i) ) then
Result := FLanguagesList.Items[i]
else
raise Exception.Create('Locale not found');
end;
function TLocalization.localize(const aLocaleId, aIndex: string): string;
var k: integer;
begin
k := 0;
if not( FLocaleList.Find(aLocaleId, k) ) then
raise Exception.Create('Locale not found.');
//ho trovato il locale, adesso basta cercare la parola
Result := FLanguagesList.Items[k].localize(aIndex);
end;
{ TLanguage }
procedure TLanguage.addWord(const aIndex, aWord: string);
begin
FTranslationList.Add(aIndex, aWord);
end;
constructor TLanguage.Create;
begin
FTranslationList := TDictionary<string, string>.Create;
end;
destructor TLanguage.Destroy;
begin
FTranslationList.Free;
inherited;
end;
function TLanguage.localize(const aWordId: string): string;
begin
try
Result := FTranslationList.Items[aWordId];
except
Result := 'Not found.';
end;
end;
procedure TLanguage.removeWord(const aIndex: string);
begin
FTranslationList.Remove(aIndex);
end;
end.
The code above is used as follows:
var a: TLocalization;
begin
a := TLocalization.Create;
a.addLanguage('it');
a.addLanguage('cse');
a.Locale['it'].addWord('test', 'Ciao mondo!');
a.Locale['cse'].addWord('test', 'fadfa ea!');
ButtonSomething.Text := a.localize('it', test);
end;
The TLocalization class does all the work. As you can see I create the variable a, then I add a language to the class (this is managed internally using a dictionary/stringlist).
I can access the languages I have added using the Locale[Index: string] property which returns a TLanguage, a class that I use to indicate a single lang. At the end with the localize method I get my translation.
Oddly enough I always get the error 'Locale not found'. Any idea? Using the debugger I have discovered this:
The FLocaleList has items but I have tested this and I guess that I am doing something wrong on line 71 (where I use the Find function). Am I passing wrongly the Index maybe?

Your code logic is backwards. Find() returns True if it finds a match, otherwise it returns False. You are accessing Items[] if Find() returns False, and raising an exception if it returns True. You need to remove the not in your if statement:
function TLocalization.getLang(Index: string): TLanguage;
var
i: integer;
begin
{ I search the locale id (for example 'it') if it's in the list. }
{ if it's in the list, I return the respective TLanguage object}
if FLocaleList.Find(Index, i) then // <-- HERE
Result := FLanguagesList.Items[i]
else
raise Exception.Create('Locale not found');
end;
But, more importantly, the Find() documentation says:
Note: Only use Find with sorted lists. For unsorted lists, use the IndexOf method instead.
Your list is unsorted, as the Sorted property is false by default. So use IndexOf() instead:
function TLocalization.getLang(Index: string): TLanguage;
var
i: integer;
begin
{ I search the locale id (for example 'it') if it's in the list. }
{ if it's in the list, I return the respective TLanguage object}
i := FLocaleList.IndexOf(Index);
if i <> -1 then
Result := FLanguagesList.Items[i]
else
raise Exception.Create('Locale not found');
end;

Related

Attribute as result of function has empty property value?

program Test;
{$APPTYPE CONSOLE}
uses
System.SysUtils,
System.Rtti;
function GetPropertyValue(const AObject: TObject; APropertyName: string): TValue;
var
oType: TRttiType;
oProp: TRttiProperty;
begin
oType := TRttiContext.Create.GetType(AObject.ClassType);
if oType <> nil then
begin
oProp := oType.GetProperty(APropertyName);
if oProp <> nil then
Exit(oProp.GetValue(AObject));
end;
Result := TValue.Empty;
end;
function GetAttributePropertyValue(const AClass: TClass; AAttribute: TClass;
AAttributePropertyName: string): TValue;
var
oAttr: TCustomAttribute;
begin
for oAttr in TRttiContext.Create.GetType(AClass).GetAttributes do
if oAttr.InheritsFrom(AAttribute) then
Exit(GetPropertyValue(oAttr, AAttributePropertyName));
Result := nil;
end;
function GetClassAttribute(const AClass: TClass; AAttribute: TClass): TCustomAttribute;
begin
for Result in TRttiContext.Create.GetType(AClass).GetAttributes do
if Result.InheritsFrom(AAttribute) then
Exit;
Result := nil;
end;
type
DescriptionAttribute = class(TCustomAttribute)
private
FDescription: string;
public
constructor Create(const ADescription: string);
property Description: string read FDescription;
end;
constructor DescriptionAttribute.Create(const ADescription: string);
begin
FDescription := ADescription;
end;
type
[Description('MyClass description')]
TMyClass = class(TObject);
var
oAttr: TCustomAttribute;
begin
{ ok, output is 'MyClass description' }
WriteLn(GetAttributePropertyValue(TMyClass, DescriptionAttribute, 'Description').AsString);
{ not ok, output is '' }
oAttr := GetClassAttribute(TMyClass, DescriptionAttribute);
WriteLn(DescriptionAttribute(oAttr).Description);
// WriteLn(oAttr.ClassName); // = 'DescriptionAttribute'
ReadLn;
end.
I need the rtti attribute. I was hoping to get attribute with function GetClassAttribute() but the result is not expected.
Result of function GetAttributePropertyValue() is correct (first WriteLn), but result of function GetClassAttribute() is DescriptionAttribute with empty Description value. Why?
What is correct way to get attribute as function result ?
TIA and best regards
Branko
The problem is that all RTTI related objects created during querying information (including attributes) are being destroyed if the TRttiContext goes out of scope.
You can verify this when you put a destructor on your attribute class.
Recent versions introduced KeepContext and DropContext methods on TRttiContext you can use or just put a global variable somewhere and cause it to trigger the internal creation by calling Create or something. I usually put the TRttiContext variable as class variable into the classes using RTTI.
KeepContext and DropContext can be used in code where you might not have one global TRttiContext instance that ensures its lifetime because you are using other classes, methods and routines that have their own TRttiContext reference - see for instance its use in System.Classes where during BeginGlobalLoading KeepContext is being called and in EndGlobalLoading DropContext.

Delphi OTAPI AddMenuCreatorNotifier deprecated, what is the replacement?

I am following the CodeCentral article on how to extend the project menu in Delphi IDE, using IOTAProjectManager.
The sample wizard code on code-central does this:
procedure Register;
begin
FNotifierIndex := (BorlandIDEServices as IOTAProjectManager).AddMenuCreatorNotifier(TMyContextMenu.Create); // deprecated.
end;
What is the new technique to register a context menu such as the project menu one? Note that this was deprecated without even making it onto the docwiki.
Screenshot of desired result:
Update: I could not find any up to date tutorials including code. There is a PDF whitepaper on Embarcadero's website but the code samples from that whitepaper by Bruno Fierens are not anywhere on the web. I made an answer below with a working example, which is on bitbucket, you can download the zip below.
If you look at the source code in $(BDS)\Source\ToolsAPI\ToolsAPI.pas, the declaration of IOTAProjectManager.AddMenuCreatorNotifier() says:
This function is deprecated -- use AddMenuItemCreatorNotifier instead
And also, the declaration of INTAProjectMenuCreatorNotifier says:
This notifier is deprecated. Use IOTAProjectMenuItemCreatorNotifier instead. It supports adding menu items for multi-selected items in the Project Manager.
Here are the relevant declarations and descriptions. Note the comments:
type
...
{ This notifier is deprecated. Use IOTAProjectMenuItemCreatorNotifier instead.
It supports adding menu items for multi-selected items in the Project Manager. }
INTAProjectMenuCreatorNotifier = interface(IOTANotifier)
['{8209348C-2114-439C-AD4E-BFB7049A636A}']
{ The result will be inserted into the project manager local menu. Menu
may have child menus. }
function AddMenu(const Ident: string): TMenuItem;
{ Return True if you wish to install a project manager menu item for this
ident. In cases where the project manager node is a file Ident will be
a fully qualified file name. }
function CanHandle(const Ident: string): Boolean;
end;
IOTAProjectMenuItemCreatorNotifier = interface(IOTANotifier)
['{CFEE5A57-2B04-4CD6-968E-1CBF8BF96522}']
{ For each menu item you wish to add to the project manager for the given
list of idents, add an IOTAProjectManagerMenu to the ProjectManagerMenuList.
An example of a value for IdentList is sFileContainer and the name of the
file, look above in this file for other constants. }
procedure AddMenu(const Project: IOTAProject; const IdentList: TStrings;
const ProjectManagerMenuList: IInterfaceList; IsMultiSelect: Boolean);
end;
IOTAProjectManager = interface(IInterface)
['{B142EF92-0A91-4614-A72A-CE46F9C88B7B}']
{ This function is deprecated -- use AddMenuItemCreatorNotifier instead }
function AddMenuCreatorNotifier(const Notifier: INTAProjectMenuCreatorNotifier): Integer; deprecated;
{ Adds a menu notifier, which allows you to customize the local menu of the
project manager }
function AddMenuItemCreatorNotifier(const Notifier: IOTAProjectMenuItemCreatorNotifier): Integer;
...
{ This function is deprecated -- use RemoveMenuItemCreatorNotifier instead }
procedure RemoveMenuCreatorNotifier(Index: Integer); deprecated;
{ Removes a previously added menu notifier }
procedure RemoveMenuItemCreatorNotifier(Index: Integer);
end;
...
{ This is meant to be an abstract interface that describes a menu context that
can be passed to an IOTALocalMenu-descendant's Execute method. }
IOTAMenuContext = interface(IInterface)
['{378F0D38-ED5F-4128-B7D6-9D423FC1502F}']
{ Returns the identifier for this context }
function GetIdent: string;
{ Returns the verb for this context }
function GetVerb: string;
property Ident: string read GetIdent;
property Verb: string read GetVerb;
end;
{ This is meant to be an abstract interface that describes a local menu item
in an IDE view. Specific views that can have their local menus customized
will provide a descendant interface to be used for that view }
IOTALocalMenu = interface(IOTANotifier)
['{83ECCBDF-939D-4F8D-B96D-A0C67ACC86EA}']
{ Returns the Caption to be used for this menu item }
function GetCaption: string;
{ Returns the Checked state to be used for this menu item }
function GetChecked: Boolean;
{ Returns the Enabled state to be used for this menu item }
function GetEnabled: Boolean;
{ Returns the help context to be used for this menu item }
function GetHelpContext: Integer;
{ Returns the Name for this menu item. If blank, a name will be generated }
function GetName: string;
{ Returns the parent menu for this menu item }
function GetParent: string;
{ Returns the position of this menu item within the menu }
function GetPosition: Integer;
{ Returns the verb associated with this menu item }
function GetVerb: string;
{ Sets the Caption of the menu item to the specified value }
procedure SetCaption(const Value: string);
{ Sets the Checked state of the menu item to the specified value }
procedure SetChecked(Value: Boolean);
{ Sets the Enabled state of the menu item to the specified value }
procedure SetEnabled(Value: Boolean);
{ Sets the help context of the menu item to the specified value }
procedure SetHelpContext(Value: Integer);
{ Sets the Name of the menu item to the specified value }
procedure SetName(const Value: string);
{ Sets the Parent of the menu item to the specified value }
procedure SetParent(const Value: string);
{ Sets the position of the menu item to the specified value }
procedure SetPosition(Value: Integer);
{ Sets the verb associated with the menu item to the specified value }
procedure SetVerb(const Value: string);
property Caption: string read GetCaption write SetCaption;
property Checked: Boolean read GetChecked write SetChecked;
property Enabled: Boolean read GetEnabled write SetEnabled;
property HelpContext: Integer read GetHelpContext write SetHelpContext;
property Name: string read GetName write SetName;
property Parent: string read GetParent write SetParent;
property Position: Integer read GetPosition write SetPosition;
property Verb: string read GetVerb write SetVerb;
end;
{ This is the context used for Project Manager local menu items. The list
passed to IOTAProjectManagerMenu.Execute will be a list of these interfaces }
IOTAProjectMenuContext = interface(IOTAMenuContext)
['{ECEC33FD-837A-46DC-A0AD-1FFEBEEA23AF}']
{ Returns the project associated with the menu item }
function GetProject: IOTAProject;
property Project: IOTAProject read GetProject;
end;
{ This is a Project Manager specific local menu item }
IOTAProjectManagerMenu = interface(IOTALocalMenu)
['{5E3B2F18-306E-4922-9067-3F71843C51FA}']
{ Indicates whether or not this menu item supports multi-selected items }
function GetIsMultiSelectable: Boolean;
{ Sets this menu item's multi-selected state }
procedure SetIsMultiSelectable(Value: Boolean);
{ Execute is called when the menu item is selected. MenuContextList is a
list of IOTAProjectMenuContext. Each item in the list represents an item
in the project manager that is selected }
procedure Execute(const MenuContextList: IInterfaceList); overload;
{ PreExecute is called before the Execute method. MenuContextList is a list
of IOTAProjectMenuContext. Each item in the list represents an item in
the project manager that is selected }
function PreExecute(const MenuContextList: IInterfaceList): Boolean;
{ PostExecute is called after the Execute method. MenuContextList is a list
of IOTAProjectMenuContext. Each item in the list represents an item in
the project manager that is selected }
function PostExecute(const MenuContextList: IInterfaceList): Boolean;
property IsMultiSelectable: Boolean read GetIsMultiSelectable write SetIsMultiSelectable;
end;
Remy's answer is correct, but I'm providing this answer because I have written a little unit to do Project Menu (context menu) integration, and as well, as a bonus, this demo also shows main menu and IDE insight.
The code snippet in my answer covers how to actually write the code which is in several layers of classes, one of which must implement IOTAProjectMenuItemCreatorNotifier interface.
The demo on bitbucket actually does several things that are useful:
As this question asks, it puts a custom item in the project right click context menu.
It also registers a global keyboard shortcut (hotkey).
It also makes the same action visible in the IDE insight search.
It also adds a menu to the main menu.
Handling the interfaces that Remy's answer discusses is non-trivial, so I have made a working example.
unit HelloExpertContextMenu;
// Example of a Project Right Click (Context) menu for Delphi 10 Seattle
// using OTAPI. Must be provided an action list full of actions with valid
// unique names.
//
// Register menu:
//
// Similar code would work in RAD Studio 2010 and newer, but not in older
// Delphi versions.
interface
uses Classes,
SysUtils,
Generics.Collections,
Vcl.ActnList,
ToolsAPI,
Menus,
Windows,
Messages;
type
TProjectManagerMenu = class(TNotifierObject, IOTANotifier, IOTAProjectMenuItemCreatorNotifier)
private
FActionList: TActionList; // reference only.
FProject: IOTAProject; // Reference valid ONLY during MenuExecute
FNotifierIndex: Integer;
FFault:Boolean; // nicer than raising inside the IDE.
{ IOTAProjectMenuItemCreatorNotifier }
procedure AddMenu(const Project: IOTAProject; const Ident: TStrings;
const ProjectManagerMenuList: IInterfaceList; IsMultiSelect: Boolean);
protected
procedure ExecuteVerb(const Verb:string);
public
procedure InstallMenu;
constructor Create(ActionList:TActionList);
procedure MenuExecute(const MenuContextList: IInterfaceList);
property Project: IOTAProject read FProject; // Reference valid ONLY during MenuExecute
property Fault: Boolean read FFault; // InstallMenu fail.
end;
TOTAActionMenu = class(TInterfacedObject, IOTANotifier, IOTALocalMenu)
private
FAction:TAction;
FParent: string;
FPosition: Integer;
public
{ IOTANotifier }
procedure AfterSave;
procedure BeforeSave;
procedure Destroyed;
procedure Modified;
public
{ IOTALocalMenu }
function GetCaption: string;
function GetChecked: Boolean;
function GetEnabled: Boolean;
function GetHelpContext: Integer;
function GetName: string;
function GetParent: string;
function GetPosition: Integer;
function GetVerb: string;
procedure SetChecked(Value: Boolean);
procedure SetEnabled(Value: Boolean);
procedure SetHelpContext(Value: Integer);
procedure SetName(const Value: string);
procedure SetParent(const Value: string);
procedure SetPosition(Value: Integer);
procedure SetVerb(const Value: string);
procedure SetCaption(const Value: string);
property Action: TAction read FAction write FAction; // MUST NOT BE NIL!
property Caption: string read GetCaption write SetCaption;
property Checked: Boolean read GetChecked write SetChecked;
property Enabled: Boolean read GetEnabled write SetEnabled;
property HelpContext: Integer read GetHelpContext write SetHelpContext;
property Name: string read GetName write SetName;
property Parent: string read GetParent write SetParent;
property Position: Integer read GetPosition write SetPosition;
property Verb: string read GetVerb write SetVerb;
end;
TProjectManagerMenuExecuteEvent = procedure (const MenuContextList: IInterfaceList) of object;
TOTAProjectManagerActionMenu = class(TOTAActionMenu, IOTANotifier, IOTALocalMenu, IOTAProjectManagerMenu)
private
FIsMultiSelectable: Boolean;
public
{ IOTAProjectManagerMenu }
function GetIsMultiSelectable: Boolean;
procedure SetIsMultiSelectable(Value: Boolean);
procedure Execute(const MenuContextList: IInterfaceList); overload;
function PreExecute(const MenuContextList: IInterfaceList): Boolean;
function PostExecute(const MenuContextList: IInterfaceList): Boolean;
property IsMultiSelectable: Boolean read GetIsMultiSelectable write SetIsMultiSelectable;
end;
implementation
constructor TProjectManagerMenu.Create(ActionList:TActionList);
begin
inherited Create;
FActionList := ActionList;
end;
procedure TProjectManagerMenu.ExecuteVerb(const Verb: string);
var
AnAction: TAction;
begin
if Assigned(FActionList) then
begin
AnAction := FActionList.FindComponent(Verb) as TAction;
if Assigned(AnAction) then
AnAction.Execute();
end;
end;
procedure TProjectManagerMenu.InstallMenu;
var
OTAProjectManager: IOTAProjectManager;
begin
if Supports(BorlandIDEServices, IOTAProjectManager, OTAProjectManager) then
FNotifierIndex := OTAProjectManager.AddMenuItemCreatorNotifier(Self)
else
FFault := True;
end;
procedure TProjectManagerMenu.AddMenu(const Project: IOTAProject; const Ident: TStrings;
const ProjectManagerMenuList: IInterfaceList; IsMultiSelect: Boolean);
var
AMenu: TOTAProjectManagerActionMenu;
Action:TAction;
n:Integer;
begin
if (not IsMultiSelect) and Assigned(Project) and (Ident.IndexOf(sProjectContainer) <> -1) then
begin
for n := 0 to FActionList.ActionCount-1 do
begin
Action := FActionList.Actions[n] as TAction;
if Action.Name ='' then
Action.Name := 'HelloExpertContextMenuAction'+IntToStr(n+1);
AMenu := TOTAProjectManagerActionMenu.Create;
AMenu.Action := Action;
if AMenu.Caption='' then
AMenu.Caption := 'Menu Item Text Missing'+IntToStr(n);
AMenu.IsMultiSelectable := True;
AMenu.Position := pmmpUserBuild;
ProjectManagerMenuList.Add(AMenu);
end;
end;
end;
procedure TProjectManagerMenu.MenuExecute(const MenuContextList: IInterfaceList);
var
Index: Integer;
MenuContext: IOTAProjectMenuContext;
Verb: string;
begin
try
for Index := 0 to MenuContextList.Count - 1 do
begin
MenuContext := MenuContextList.Items[Index] as IOTAProjectMenuContext;
FProject := MenuContext.Project;
try
Verb := MenuContext.Verb;
ExecuteVerb(Verb);
finally
FProject := nil;
end;
end;
except
on E:Exception do
begin
OutputDebugString(PChar(E.Message));
end;
end;
end;
procedure TOTAActionMenu.AfterSave;
begin
end;
procedure TOTAActionMenu.BeforeSave;
begin
end;
procedure TOTAActionMenu.Destroyed;
begin
end;
procedure TOTAActionMenu.Modified;
begin
end;
function TOTAActionMenu.GetCaption: string;
begin
Result := FAction.Caption;
end;
function TOTAActionMenu.GetChecked: Boolean;
begin
Result := FAction.Checked;
end;
function TOTAActionMenu.GetEnabled: Boolean;
begin
Result := FAction.Enabled;
end;
function TOTAActionMenu.GetHelpContext: Integer;
begin
Result := FAction.HelpContext;
end;
function TOTAActionMenu.GetName: string;
begin
Result := FAction.Name;
end;
function TOTAActionMenu.GetParent: string;
begin
Result := FParent;
end;
function TOTAActionMenu.GetPosition: Integer;
begin
Result := FPosition;
end;
function TOTAActionMenu.GetVerb: string;
begin
Result := FAction.Name; // Name is also Verb
end;
procedure TOTAActionMenu.SetCaption(const Value: string);
begin
FAction.Caption := Value;
end;
procedure TOTAActionMenu.SetChecked(Value: Boolean);
begin
FAction.Checked := Value;
end;
procedure TOTAActionMenu.SetEnabled(Value: Boolean);
begin
FAction.Enabled := Value;
end;
procedure TOTAActionMenu.SetHelpContext(Value: Integer);
begin
FAction.HelpContext := Value;
end;
procedure TOTAActionMenu.SetName(const Value: string);
begin
FAction.Name := Value;
end;
procedure TOTAActionMenu.SetParent(const Value: string);
begin
FParent := Value;
end;
procedure TOTAActionMenu.SetPosition(Value: Integer);
begin
FPosition := Value;
end;
procedure TOTAActionMenu.SetVerb(const Value: string);
begin
FAction.Name := Value; // NAME == VERB!
end;
//=== { TOTAProjectManagerActionMenu } ==========================================
function TOTAProjectManagerActionMenu.GetIsMultiSelectable: Boolean;
begin
Result := FIsMultiSelectable;
end;
procedure TOTAProjectManagerActionMenu.SetIsMultiSelectable(Value: Boolean);
begin
FIsMultiSelectable := Value;
end;
procedure TOTAProjectManagerActionMenu.Execute(const MenuContextList: IInterfaceList);
begin
if Assigned(FAction) then
begin
FAction.Execute;
end;
end;
function TOTAProjectManagerActionMenu.PreExecute(const MenuContextList: IInterfaceList): Boolean;
begin
Result := True;
end;
function TOTAProjectManagerActionMenu.PostExecute(const MenuContextList: IInterfaceList): Boolean;
begin
Result := True;
end;
end.
complete working example on bitbucket at https://bitbucket.org/wpostma/helloworldexpert

Spring4d: How to "force" the container to believe a class implements an interface

I am using RemObjects DataAbstract along with Spring4d. RemObjects generates a SchemaServer_Intf.pas file that contains interfaces for every kind of table that exists in it's schema. It allows for "Strongly typed" datasets, allowing one to access a field using
(aDataSet as IMyDataSet).MyField := aValue
Here is a snapshot of one of the interfaces generated by DataAbstract
IEntiteType = interface(IDAStronglyTypedDataTable)
['{96B82FF7-D087-403C-821A-0323034B4B99}']
{ Property getters and setters }
function GetEntiteIdValue: String;
procedure SetEntiteIdValue(const aValue: String);
function GetEntiteIdIsNull: Boolean;
procedure SetEntiteIdIsNull(const aValue: Boolean);
function GetNameValue: WideString;
procedure SetNameValue(const aValue: WideString);
function GetNameIsNull: Boolean;
procedure SetNameIsNull(const aValue: Boolean);
function GetIsSystemValue: SmallInt;
procedure SetIsSystemValue(const aValue: SmallInt);
function GetIsSystemIsNull: Boolean;
procedure SetIsSystemIsNull(const aValue: Boolean);
{ Properties }
property EntiteId: String read GetEntiteIdValue write SetEntiteIdValue;
property EntiteIdIsNull: Boolean read GetEntiteIdIsNull write SetEntiteIdIsNull;
property Name: WideString read GetNameValue write SetNameValue;
property NameIsNull: Boolean read GetNameIsNull write SetNameIsNull;
property IsSystem: SmallInt read GetIsSystemValue write SetIsSystemValue;
property IsSystemIsNull: Boolean read GetIsSystemIsNull write SetIsSystemIsNull;
end;
Though, there is one problem. If you cast a dataTable like so:
aDataTable := IEntiteType(TDAMemDataTable.Create(nil));
You'll have an "Interface not supported error"
But, as soon as you do:
aDataTable.LogicalName := 'EntiteType';
aDataTable.BusinessRulesId := MyBusinessRuleID;
You can safely write
aDataTable := IEntiteType(TDAMemDataTable.Create(nil));
And you don't get any error.
So, with Spring4d, I thought of writing this in my registration unit:
aContainer.RegisterType<TDAMemDataTable>.Implements<IEntiteType>.DelegateTo(
function : TDAMemDataTable
var aDataTable : TDAMemDataTable;
begin
Result:= TDAMemDataTable.Create(nil);
Result.LogicalName := 'EntiteType';
Result.BusinessRulesId := MyBusinessRuleId;
end
)
But then, Spring4d throws (with reason) error :
Exception 'first chance' à $762D5B68. Classe d'exception ERegistrationException avec un message 'Component type "uDAMemDataTable.TDAMemDataTable" incompatible with service type "SchemaClient_Intf.IEntiteType".'. Processus EntiteREM2.exe (3088)
Is there a way to override this check?
Ok I've found a way to do that. Super simple actually :
aContainer.RegisterType<IAddress>.DelegateTo(
function : IAddress
var aTable : TDAMemDataTable;
begin
aTable := TDAMemDataTable.Create(nil);
aTable.LogicalName := nme_Address;
aTable.BusinessRulesID := RID_Address;
Result := aTable as IAddress;
end
);
Also, for people interested in registering many tables in an elegant fashion :
aContainer.RegisterType<IAddress>.DelegateTo(TableConfigurator.GetTableDelegate<IAddress>(nme_Address, RID_Address));
// Registering other tables here...
Just create some "Helper" class with this method :
class function TableConfigurator.GetTableDelegate<T>(aLogicalName, aBusinessRulesId: string): TActivatorDelegate<T>;
begin
Result := (function: T
var
aTable: TDAMemDataTable;
begin
aTable := TDAMemDataTable.Create(nil);
aTable.LogicalName := aLogicalName;
aTable.BusinessRulesID := aBusinessRulesId;
Result := T(TValue.From(aTable).AsInterface);
end);
end;

Delphi static method of a class returning property value

I'm making a Delphi VCL application. There is a class TStudent where I have two static functions: one which returns last name from an array of TStudent and another one which returns the first name of the student. Their code is something like:
class function TStudent.FirstNameOf(aLastName: string): string;
var i : integer;
begin
for i := 0 to Length(studentsArray) - 1 do begin
if studentsArray[i].LastName = aLastName then
begin
result := studentsArray[i].FirstName;
Exit;
end;
end;
result := 'no match was found';
end;
class function TStudent.LastNameOf(aFirstName: string): string;
var i : integer;
begin
for i := 0 to Length(studentsArray) - 1 do begin
if studentsArray[i].FirstName = aFirstName then
begin
result := studentsArray[i].LastName;
Exit;
end;
end;
result := 'no match was found';
end;
My question is how can I avoid writing almost same code twice. Is there any way to pass the property as parameter of the functions.
You can use an anonymous method with variable capture for this linear search. This approach gives you complete generality with your predicate. You can test for equality of any field, of any type. You can test for more complex predicates for instance an either or check.
The code might look like this:
class function TStudent.LinearSearch(const IsMatch: TPredicate<TStudent>;
out Index: Integer): Boolean;
var
i: Integer;
begin
for i := low(studentsArray) to high(studentsArray) do
begin
if IsMatch(studentsArray[i]) then
begin
Index := i;
Result := True;
exit;
end;
end;
Index := -1;
Result := False;
end;
Now all you need to do is provide a suitable predicate. The definition of TPredicate<T>, from the System.SysUtils unit, is:
type
TPredicate<T> = reference to function (Arg1: T): Boolean;
So you would code your method like this:
class function TStudent.GetFirstName(const LastName: string): string;
var
Index: Integer;
IsMatch: TPredicate<TStudent>;
begin
IsMatch :=
function(Student: TStudent): Boolean
begin
Result := Student.LastName=LastName;
end;
if not LinearSearch(IsMatch, Index) then
begin
raise ...
end;
Result := studentsArray[Index].FirstName;
end;
And likewise for GetLastName.
If your Delphi does not support anonymous methods then you won't be able to use variable capture and will have to find a more convoluted approach using of object method types. However, the basic idea will be much the same.
I haven't tested it, but I believe this could be one solution.
uses TypInfo;
class function TStudent.GetProperty( propertyName: string, searchValue : Variant ) : Variant ;
var i : integer;
begin
for i := 0 to Length(studentsArray) - 1 do begin
if GetPropValue( studentsArray[i], propertyName ) = searchValue
result := GetPropValue( studentsArray[i], propertyName );
end;
// your code in case of not finding anything
end;
If you are using Delphi 2010 or later, you could use Extended RTTI:
uses
..., Rtti;
type
TStudent = class
public
FirstName: String;
LastName: String;
class function GetNameOf(const aFieldToFind, aNameToFind, aFieldToReturn: string): string;
end;
class function TStudent.GetNameOf(const aFieldToFind, aNameToFind, aFieldToReturn: string): string;
var
i : integer;
ctx: TRttiContent;
StudentType: TRttiType;
Field: TRttiField;
Value: TValue;
begin
ctx := TRttiContext.Create;
StudentType := ctx.GetType(TStudent);
Field := StudentType.GetField(aFieldToFind);
for i := 0 to Length(studentsArray) - 1 do
begin
if Field.GetValue(#studentsArray[i]).AsString = aNameToFind then
begin
Result := StudentType.GetField(aFieldToReturn).GetValue(#studentsArray[i]).AsString;
Exit;
end;
end;
Result := 'no match was found';
end;
Then you can call it like this:
FirstName := TStudent.GetNameOf('LastName', 'Smoe', 'FirstName');
LastName := TStudent.GetNameOf('FirstName', 'Joe', 'LastName');
If you restructure the TStudent record a little, everything gets easier. Instead of having multiple string fields with different names, declare an array of strings with an enumeration range.
Give the enumeration meaningful names and add a search function where the search field and result field can be specified.
Type
TStudentField = (sfFirstName,sfLastName); // Helper enumeration type
TStudent = record
Field: array[TStudentField] of String;
class function SearchNameOf(searchField: TStudentField;
const aSearchName: string; resultField: TStudentField): string; static;
end;
Here is a test example:
program ProjectTest;
{$APPTYPE CONSOLE}
Type
TStudentField = (sfFirstName,sfLastName);
TStudent = record
Field: array[TStudentField] of String;
class function SearchNameOf(searchField: TStudentField; const aSearchName: string; resultField: TStudentField): string; static;
end;
var
studentsArray : array of TStudent;
class function TStudent.SearchNameOf(searchField: TStudentField; const aSearchName: string; resultField: TStudentField): string;
var
i : integer;
begin
for i := 0 to Length(studentsArray) - 1 do begin
if (studentsArray[i].Field[searchField] = aSearchName) then
begin
Result := studentsArray[i].Field[resultField];
Exit;
end;
end;
result := 'no match was found';
end;
begin
SetLength(studentsArray,2);
studentsArray[0].Field[sfFirstName] := 'Buzz';
studentsArray[0].Field[sfLastName] := 'Aldrin';
studentsArray[1].Field[sfFirstName] := 'Neil';
studentsArray[1].Field[sfLastName] := 'Armstrong';
WriteLn(TStudent.SearchNameOf(sfFirstName,'Neil',sfLastName));
ReadLn;
end.
You could use a several properties with index specifier backed by single getter function just as you do for regular array properties:
TDefault = class(TObject)
private
class function GetProp(const FindWhat: string; FindWhere: Integer): string;
static;
protected
/// <remarks>
/// You don't really need this one. I've added it for an illustration
/// purposes.
/// </remarks>
class property Prop[const FindWhat: string; FindWhere: Integer]: string read GetProp;
public
class property A[const FindWhat: string]: string index 0 read GetProp;
class property B[const FindWhat: string]: string index 1 read GetProp;
end;
{ ... }
class function TDefault.GetProp(const FindWhat: string; FindWhere: Integer): string;
begin
case FindWhere of
0: Result := 'Hallo!';
1: Result := 'Hello!';
end;
Result := Result + ' ' + Format('searching for "%s"', [FindWhat]);
end;
As you see, the class properties are just the same as instance properties.
And I must say its a pretty bad idea to perform a search in the property getter.

Delphi generics TObjectList<T> inheritance

I want to create a TObjectList<T> descendant to handle common functionality between object lists in my app. Then I want to further descend from that new class to introduce additional functionality when needed. I cannot seem to get it working using more than 1 level of inheritance. I probably need to understand generics a little bit more, but I've search high and low for the correct way to do this without success. Here is my code so far:
unit edGenerics;
interface
uses
Generics.Collections;
type
TObjectBase = class
public
procedure SomeBaseFunction;
end;
TObjectBaseList<T: TObjectBase> = class(TObjectList<T>)
public
procedure SomeOtherBaseFunction;
end;
TIndexedObject = class(TObjectBase)
protected
FIndex: Integer;
public
property Index: Integer read FIndex write FIndex;
end;
TIndexedObjectList<T: TIndexedObject> = class(TObjectBaseList<T>)
private
function GetNextAutoIndex: Integer;
public
function Add(AObject: T): Integer;
function ItemByIndex(AIndex: Integer): T;
procedure Insert(AIndex: Integer; AObject: T);
end;
TCatalogueItem = class(TIndexedObject)
private
FID: integer;
public
property ID: integer read FId write FId;
end;
TCatalogueItemList = class(TIndexedObjectList<TCatalogueItem>)
public
function GetRowById(AId: Integer): Integer;
end;
implementation
uses
Math;
{ TObjectBase }
procedure TObjectBase.SomeBaseFunction;
begin
end;
{ TObjectBaseList<T> }
procedure TObjectBaseList<T>.SomeOtherBaseFunction;
begin
end;
{ TIndexedObjectList }
function TIndexedObjectList<T>.Add(AObject: T): Integer;
begin
AObject.Index := GetNextAutoIndex;
Result := inherited Add(AObject);
end;
procedure TIndexedObjectList<T>.Insert(AIndex: Integer; AObject: T);
begin
AObject.Index := GetNextAutoIndex;
inherited Insert(AIndex, AObject);
end;
function TIndexedObjectList<T>.ItemByIndex(AIndex: Integer): T;
var
I: Integer;
begin
Result := Default(T);
while (Count > 0) and (I < Count) and (Result = Default(T)) do
if Items[I].Index = AIndex then
Result := Items[I]
else
Inc(I);
end;
function TIndexedObjectList<T>.GetNextAutoIndex: Integer;
var
I: Integer;
begin
Result := 0;
for I := 0 to Count - 1 do
Result := Max(Result, Items[I].Index);
Inc(Result);
end;
{ TCatalogueItemList }
function TCatalogueItemList.GetRowById(AId: Integer): Integer;
var
I: Integer;
begin
Result := -1;
for I := 0 to Pred(Self.Count) do
if Self.Items[I].Id = AId then
begin
Result := I;
Break;
end;
end;
end.
/////// ERROR HAPPENS HERE ////// ???? why is beyond me
It appears that the following declaration:
>>> TCatalogueItemList = class(TIndexedObjectList<TCatalogueItem>) <<<<
causes the following compiler error:
[DCC Error] edGenerics.pas(106): E2010 Incompatible types:
'TCatalogueItem' and 'TIndexedObject'
However the compiler shows the error at the END of the compiled unit (line 106), not on the declaration itself, which does not make any sense to me...
Basically the idea is that I have a generic list descending from TObjectList that I can extend with new functionality on an as needs basis. Any help with this would be GREAT!!!
I should add, using Delphi 2010.
Thanks.
Your error is in the type casting, and the compiler error is OK (but it fails to locate the correct file in my Delphi XE3).
Your ItemByIndex method is declared:
TIndexedObjectList<T>.ItemByIndex(AIndex: Integer): T;
But then you have the line:
Result := TIndexedObject(nil);
This is fine for the parent class TIndexedObjectList, where the result of the function is of type TIndexedObject, but is not OK for the descendant class TCatalogueItemList, where the result of the function is of the type TCatalogueItem.
As you may know, a TCatalogueItem instance is assignment compatible with a TIndexedObject variable, but the opposite is not true. It translates to something like this:
function TCatalogueItemList.ItemByIndex(AIndex: Integer): TCatalogueItem;
begin
Result := TIndexedObject(nil); //did you see the problem now?
To initialize the result to a nil value, you can call the Default() pseudo-function, like this:
Result := Default(T);
In Delphi XE or greater, the solution is also generic. Rather than type-casting the result as a fixed TIndexedObjectList class, you apply a generic type casting use the T type
Result := T(nil);
//or
Result := T(SomeOtherValue);
But, in this specific case, type-casting a nil constant is not needed, since nil is a special value that is assignment compatible with any reference, so you just have to replace the line with:
Result := nil;
And it will compile, and hopefully work as you expect.

Resources