I want to extend TApplication by adding extra methods, variables, and code to be initialized in the constructor.
Deriving my own class from TApplication won't work, obviously, because the global VAR Application is declared (Vcl.Forms) and instantiated (VclControls.InitControls) as TApplication. Obviously, I will try to stay away from hacking and recompiling that unit.
There is a post on SO that might seem similar, but it is not because the owner of the post wants to override the TApplication for a whole different reason.
The class declaration would be something like (work in progress):
TYPE
TAppData= class(TObject)
private
FAppName: string;
FLastFolder: string; { used by AppLastUsedFolder } //todo: reaname to FLastFolder
function getLastUsedFolder: string;
public
Initializing: Boolean; { Used in cvIniFile.pas. Set it to false once your app finished initializing. }
constructor Create(aAppName: string);
{--------------------------------------------------------------------------------------------------
App path/name
--------------------------------------------------------------------------------------------------}
function AppDir : string;
function SysDir : string;
function AppDataFolder(ForceDir: Boolean= FALSE): string;
function AppDataFolderAllUsers: string;
function AppShortName: string;
property AppName: string read FAppName;
property LastUsedFolder: string read getLastUsedFolder write FLastFolder;
{--------------------------------------------------------------------------------------------------
App Control
--------------------------------------------------------------------------------------------------}
function RunningFirstTime: Boolean;
procedure Restart;
procedure SelfDelete;
procedure Restore;
function RunSelfAtWinStartUp(Active: Boolean): Boolean;
function RunFileAtWinStartUp(FilePath: string; Active: Boolean): Boolean; { Porneste anApp odata cu windows-ul }
{-------------------------------------------------------------------------------------------------
APPLICATION Version
--------------------------------------------------------------------------------------------------}
function GetVersionInfoV : string; { MAIN. Returns version without Build number. Example: v1.0.0 }
function GetVersionInfo(ShowBuildNo: Boolean= False): string;
function GetVersionInfoMajor: Word;
function GetVersionInfoMinor: Word;
function GetVersionInfo_: string;
function getVersionFixedInfo(CONST FileName: string; VAR FixedInfo: TVSFixedFileInfo): Boolean;
{--------------------------------------------------------------------------------------------------
BetaTester tools
--------------------------------------------------------------------------------------------------}
function RunningHome: Boolean;
function BetaTesterMode: Boolean;
function IsHardCodedExp(Year, Month, Day: word): Boolean;
end;
I thought of a Class Helper but I need to initialize stuff in the constructor:
constructor TAppData.Create(aAppName: string);
begin
inherited Create;
Initializing:= True; { Used in cvIniFile.pas. Set it to false once your app finished initializing. }
FAppName:= aAppName;
FRunningFirstTime:= NOT FileExists(IniFile);
ForceDirectories(AppDataFolder);
//ToDo: !!!!!!!!!!!!!!!!!!!!!!!! CreateLogForm; But this will create dependencies on the Log!
end;
I encountered some error for which i just can't find a proper hint on the net. Hopefully one of you can point me to the right direction.
Simple Problem: I've got a class inheriting from TObject. I've got a constructor named Create and i want to call Inherited on the very first line of the very only constructor.
Does not work!
On compile i get a
[dcc32 Fehler] ULSRAware.pas(58): E2008 Inkompatible Typen
If I comment the inherited out it compiles fine but on runtime on creating the object, while I can access methods regulary (like some private _InitAdo method), every access to a property yields an access violation error.
I guess it's coming from calling the inherited nonetheless but without any sufficient success.
This is the declaration at the head of the Unit. Just to mention it, it's just this class in the unit. And of course in the implementation section the implementation.
type TLAConnect = class( TObject )
private
_mailHost : String;
_mailPort : Integer;
_mailUsername : String;
_mailPassword : String;
_mailAddress : String;
_sql_script_sms : String;
_sql_script_mail: String;
_sms_mail_addon : String;
//connection : TADOConnection;
(*
procedure SendMessage( recp:String; subj, body : String );
procedure _InitAdo( config_filename : String; path: String );
function GetMsgId( msg : String ) : Integer;
function GetMsgIdFromByteBit( byte, bit : String ) : Integer;
function ProcessMessage( msgId : Integer ): String;
procedure Trigger( msgId : Integer );
procedure QuittMsg( msgId : Integer );
procedure MakeMessage( _msgid : Integer; _fsms, _fmail : Boolean; _smsgl, _smsgs : String );
function CreateNewByteTrigger( byte, bit : String ) : Integer;
*)
public
Constructor Create( config : String );
Destructor Destroy; override;
//function Call( msg:String ) : Boolean;
end;
And the implementation of the constructor and the desctructor.
Constructor TLAConnect.Create( config : String );
begin
inherited.Create;
//self._InitAdo( config, 'lsraware ado' );
_mailHost := 'blabla';
_mailPort := 587;
_mailUsername := 'blabla_user';
_mailPassword := 'blabla_pass';
_mailAddress := 'blabal';
end;
Destructor TLAConnect.Destroy;
begin
self.connection.Free;
Inherited;
end;
Howdey,
I am using TVirtualInterface to implement some interfaces. Those interfaes represent Keys that can be found in a DB. I generate the interface definitions with a custom made code generator. For example :
// Base code
IKey = interface
function KeyFields : string;
function KeyValues : Variant;
function GetKeyValue(const aKeyName : string) : Variant;
procedure SetKeyValue(const aKeyName : string; Value : Variant);
end;
// Generated code
ITable1Key = interface(IKey)
end;
ITable1Key1 = interface(ITable1Key)
procedure SetField1(const Value : string);
function GetField1 : string;
property Field1 : string read GetField1 write SetField1;
end;
ITable1Key2 = interface(ITable1Key)
procedure SetField1(const Value : string);
function GetField1 : string;
property Field1 : string read GetField1 write SetField1;
procedure SetField2(const Value : string);
function GetField2 : string;
property Field2 : string read GetField1 write SetField1;
end;
// Other generated declarations
I use the TVirtualInterface to implement each IKey interface instead of implementing them one by one.
Though, in my TVirtualInterface :
TKey = TVirtualInterface
public
constructor Create(aType : PTypeInfo);
function Cast : IKey;
end;
TKey<T : IKey>
public
constructor Create; reintroduce;
function Cast : T;
end;
constructor TKey.Create(aType : PTypeInfo)
begin
inherited Create(aType, aHandlerMethod);
end;
function TKey.Cast;
var
pInfo: PTypeInfo;
begin
pInfo := TypeInfo(IKey);
if QueryInterface(GetTypeData(pInfo).Guid, Result) <> 0 then
begin
raise Exception.CreateFmt('Sorry, TKey is unable to cast %s to its interface ', [string(pInfo.Name)]);
end;
end;
constructor TKey<T>.Create;
begin
inherited Create(TypeInfo(T));
end;
function TKey<T>.Cast;
var
pInfo: PTypeInfo;
begin
pInfo := TypeInfo(T);
if QueryInterface(GetTypeData(pInfo).Guid, Result) <> 0 then
begin
raise Exception.CreateFmt('Sorry, TKey<T> is unable to cast %s to its interface ', [string(pInfo.Name)]);
end;
end;
I have no problem casting the TKey virtual interface to the T type using the TKey.Cast method, though TKey.Cast returns a Interface not supported error.
I checked in System.Rtti for the part that wasn't working the way I wanted it to :
function TVirtualInterface.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
if iid = FIID then
begin
_AddRef;
Pointer(Obj) := #VTable;
Result := S_OK;
end
else
Result := inherited
end;
Now, how can I force the TVirtualInterface to cast itself to a IID that is a parent interface of the FIID field ? Do I have to create another instance of the TVirtualInterface for the IKey interface ?
Thank you very much.
You are misusing TVirtualInterface. It is just an RTTI helper, you should not be deriving from it at all. You should be deriving from TInterfacedObject instead.
Also, both of your TKey classes are ignoring the PTypeInfo that is passed to the constructor. The non-Generic TKey.Cast() is always querying for IKey only, never a descendant interface. And the Generic TKey<T>.Cast is always re-querying T's RTTI to get its IID. So get rid of the PTypeInfo in the constructor, it is wasted.
Since the non-Generic TKey is just a base class that doesn't actually implement any derived interfaces at all, TKey.QueryInterface() will always fail for any interface other than IKey itself. At least the Generic TKey can query a derived interface.
Your Cast functions are redundant anyway, since you can use the as operator, or the SysUtils.Supports() function, to cast one interface to another. These are the preferred methods, not using QueryInterface() manually.
In any case, your interfaces are missing IIDs in their declarations, so you can't cast between interfaces anyway.
Try something more like this:
// Base code
IKey = interface
['{D6D212E0-C173-468C-8267-962CFC3FECF5}']
function KeyFields : string;
function KeyValues : Variant;
function GetKeyValue(const aKeyName : string) : Variant;
procedure SetKeyValue(const aKeyName : string; Value : Variant);
end;
// Generated code
ITable1Key = interface(IKey)
['{B8E44C43-7248-442C-AE1B-6B9E426372C1}']
end;
ITable1Key1 = interface(ITable1Key)
['{0C86ECAA-A8E7-49EB-834F-77DE62BE1D28}']
procedure SetField1(const Value : string);
function GetField1 : string;
property Field1 : string read GetField1 write SetField1;
end;
ITable1Key2 = interface(ITable1Key)
['{82226DE9-221C-4268-B971-CD72617C19C7}']
procedure SetField1(const Value : string);
function GetField1 : string;
property Field1 : string read GetField1 write SetField1;
procedure SetField2(const Value : string);
function GetField2 : string;
property Field2 : string read GetField1 write SetField1;
end;
// Other generated declarations
type
TKey = class(TInterfacedObject, IKey)
public
function Cast : IKey;
// IKey methods...
end;
TKey<T : IKey> = class(TInterfacedObject, IKey, T)
public
function Cast : T;
end;
TTable1Key = class(TKey, IKey, ITable1Key)
end;
TTable1Key1 = class(TTable1Key, IKey, ITable1Key, ITable1Key1)
public
// ITable1Key1 methods...
end;
TTable1Key2 = class(TTable1Key, IKey, ITable1Key, ITable1Key2)
public
// Table1Key2 methods...
end;
// and so on ...
function TKey.Cast: IKey;
begin
if not Supports(Self, IKey, Result) then
raise Exception.Create('Sorry, unable to cast to IKey');
end;
function TKey<T>.Cast: T;
begin
if not Supports(Self, GetTypeData(TypeInfo(T)).Guid, Result) then
raise Exception.CreateFmt('Sorry, unable to cast to %s', [string(TypeInfo(T).Name)]);
end;
// other class methods as needed ...
Also note how the derived classes have to repeat the interfaces implemented by their base classes. That is a known Delphi limitation. Derived classes do not inherit base class interfaces. Each class has to explicitly specify the interfaces it implements, even if the actual implementation is in a base class.
I would like to deserialize data from an JSON string response into a class with Delphi - Is there a way to do it in Delphi with generics so I can define a POCO class for every different type of class response - within the Data property of a default Response class? I have better knowledge in C# and have accomplished it there with JavaScriptSerializer Deserialize method, like this:
public Response<T> Get<T>(string methodUrl) where T: class
...
var _json_serializer = new JavaScriptSerializer();
_response = _json_serializer.Deserialize<Response<T>>(api_response);
...
public class Response
{
public bool Success { get; set; }
public string ErrorMessage { get; set; }
}
public class Response<T> : Response
{
public T Data;
public Response()
{
Data = default(T);
Success = false;
ErrorMessage = Settings.Default.errString;
}
}
I can then call it like so:
response = _webapi.Get<GetTestClass>(url_userinfo + sUserName);
internal class GetTestClass
{
public string DomainName { get; set; }
public int Code { get; set; }
}
Is there a way to do this in Delphi? I have implemented a GET method in Delphi10.1 from a Web API service with the function GetUrlContent - I get a valid string response. So I tried this, it compiled but I got an error when it tried to fill the class:
uses PPUserInfoDetails, APIRootClass;
var answer_class: TRootClass<TPPUserInfoDetails>;
Test_APIGet: string;
...
Test_APIGet := GetUrlContent(url_userinfo + sUserName);
answer_class:= TRootClass<TPPUserInfoDetails>.FromJsonString(Test_APIGet);
...
unit PPUserInfoDetails;
interface
type
TDataClass = class
private
FDisplayName: String;
FCode: Integer;
FRights: TArray<Integer>;
public
property DisplayName: String read FDisplayName write FDisplayName;
property Code: Integer read FCode write FCode;
property Rights: TArray<Integer> read FRights write FRights;
end;
implementation
end.
unit APIRootClass;
interface
uses Rest.Json , sysutils;
type
TRootClass<T> = class
private
FData: T;
FErrorMessage: String;
FSuccess: Boolean;
public
property Data: T read FData write FData;
property ErrorMessage: String read FErrorMessage write FErrorMessage;
property Success: Boolean read FSuccess write FSuccess;
constructor Create;
destructor Destroy; override;
function ToJsonString: string;
class function FromJsonString(AJsonString: string): TRootClass<T>;
end;
implementation
constructor TRootClass<T>.Create;
begin
inherited;
FData := Default(T);
end;
destructor TRootClass<T>.Destroy;
begin
freeandnil(FData);
inherited;
end;
function TRootClass<T>.ToJsonString: string;
begin
result := TJson.ObjectToJsonString(self);
end;
class function TRootClass<T>.FromJsonString(AJsonString: string): TRootClass<T>;
begin
result := TJson.JsonToObject<TRootClass<T>>(AJsonString)
end;
I get the error:
Project Test.exe raised exception class EConversionError with message 'Internal: Cannot instantiate type APIRootClass.TRootClass'
I am able to deserialize the data into a specific format class when I define the class without generics like this in my APINoGenerics unit:
uses APINoGenerics;
var answer_class: TRootClass;
...
Test_APIGet := GetUrlContent(url_userinfo + sUserName);
answer_class := TRootClass.FromJsonString(Test_APIGet);
...
unit APINoGenerics;
interface
uses Rest.Json;
type
TDataClass = class
private
FDisplayName: String;
FCode: Integer;
FRights: TArray<Integer>;
public
property DisplayName: String read FDisplayName write FDisplayName;
property Code: Integer read FCode write FCode;
property Rights: TArray<Integer> read FRights write FRights;
end;
TRootClass = class
private
FData: TDataClass;
FErrorMessage: String;
FSuccess: Boolean;
public
property Data: TDataClass read FData write FData;
property ErrorMessage: String read FErrorMessage write FErrorMessage;
property Success: Boolean read FSuccess write FSuccess;
constructor Create;
destructor Destroy; override;
function ToJsonString: string;
class function FromJsonString(AJsonString: string): TRootClass;
end;
implementation
constructor TRootClass.Create;
begin
inherited;
FData := TDataClass.Create();
end;
destructor TRootClass.Destroy;
begin
FData.free;
inherited;
end;
function TRootClass.ToJsonString: string;
begin
result := TJson.ObjectToJsonString(self);
end;
class function TRootClass.FromJsonString(AJsonString: string): TRootClass;
begin
result := TJson.JsonToObject<TRootClass>(AJsonString)
end;
I would like to be able to this with generics in Delphi - so I would just like to know if it's possible and how? I tried to search for an answer, but have mostly come across answers that generics can't function like this in Delphi so I post this since I haven't seen this type of question.
So assume this code work.
{***Start declaration of TMakeProd ***}
TListMakeProd = class (TListNF)
procedure SortProcProdSeqNum;
procedure LoadFromRep(aFileRep, aNo : String);
function Find(aMakeProdID : Integer) : TMakeProd;
function FindObj(aMakeProd : TMakeProd) : TMakeProd;
end;
TMakeProd = class (TProduct)
private
FMakeProductID : Integer;
FProdLotSize : Longint;
public
LiProcProd : TListProcProd;
{Load from a database.}
{ procedure SortLiProcProdSeqNum; }
constructor Init(aMakeProductID: Integer; aProdLotSize: Longint);
destructor Done; override;
destructor Destroy; override;
property MakeProductID : Integer read FMakeProductID write FMakeProductID ;
property ProdLotSize : Longint read FProdLotSize write FProdLotSize ;
function findNextProcProd(aProcProd: TProcProd) : TProcProd;
{ create function with return if required. }
end;
What I don't understand is this declaration LiProcProd : TListProcProd;
I know that TListProcProd is a class, everything else I understand it but this part I don't also this is just a class declaration and assume all the class have been properly declared
type
TMakeProd = class(TProduct)
....
LiProcProd : TListProcProd;
....
end;
In this declaration, LiProcProd is a public field. This is described by the documentation.