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;
Related
How can I mock an interface method call like procedure foo( var i_ : integer ). The tested method local variable passed as a var param, so the test must use Arg.IsAny (The test does not access it). The result value is not the same as the out value of the var param, because the tested method does some processing on it before gives back as a result. The commented When variations in the test does not compile. The current one compiles but results an undefined value (mock Executes does not call at all, because the var=pointer values don't match).
How could I mock a method call with a var parameter?
unit Unit1;
interface
uses
DUnitX.TestFramework
, Spring.Mocking
;
type
IMyInterface = interface ( IInvokable )
['{606BA1D8-EAEC-42CB-A774-911628FD2E6C}']
procedure foo( var x_ : integer );
end;
TMyClass = class
private
fMyInterface : IMyInterface;
public
constructor Create( myInterface_ : IMyInterface );
function bar : integer;
end;
[TestFixture]
TMyClassUnitTest = class
public
[Test]
procedure bar;
end;
implementation
constructor TMyClass.Create( myInterface_ : IMyInterface );
begin
inherited Create;
fMyInterface := myInterface_;
end;
function TMyClass.bar : integer;
var
i : integer;
begin
fMyInterface.foo( i );
result := i + 1;
end;
procedure TMyClassUnitTest.bar;
var
myInterfaceMock : Mock<IMyInterface>;
myClass : TMyClass;
i : integer;
procedure prepareMyInterfaceFooCall( fooVarValue_ : integer );
var
ii : integer;
begin
ii := 7;
myInterfaceMock.Setup.Executes(
function ( const args_ : TCallInfo ) : TValue
begin
args_[0] := TValue.From<integer>( fooVarValue_ );
end
//).When.foo( Arg.IsAny<integer> );
//).When.foo( integer( Arg.IsAny<integer> ) );
).When.foo( ii );
end;
begin
prepareMyInterfaceFooCall( 5 );
myClass := TMyClass.Create( myInterfaceMock );
try
i := myClass.bar;
finally
FreeAndNIL( myClass );
end;
Assert.AreEqual( 6, i );
end;
end.
1.2.2 cannot do this but 2.0 can do (currently develop branch)
Here is the relevant change to your code:
procedure prepareMyInterfaceFooCall(expectedValue: Integer);
begin
myInterfaceMock.Setup.Executes
// put the wildcard matcher because your code passes a non initialized variable
// a matcher on the When() always has priority over any individual parameter matching
.When(Args.Any)
// use the Arg.Ref syntax specifying the return value
.foo(Arg.Ref<Integer>(expectedValue).Return);
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 have a class I want to pass to a datasnap server, but the class contains this field Picture which should be a TPicture but for now I use an integer to avoid getting the marshall error "tkPointer currently not supported" :(
I have tried omitting a field/property "Picture" from getting marshalled by adding [JSONMarshalled(False)] but with no luck.
I have added the units as suggested in the thread here
JSONMarshalled not working in Delphi
unit TestObjU;
interface
uses
Classes, System.Generics.Collections, System.SyncObjs, System.SysUtils,
JSON, DBXJsonReflect, REST.JSON,
Data.FireDACJSONReflect, FireDAC.Comp.Client, vcl.ExtCtrls,
pngimage, graphics, variants,
GlobalFunctionsU, GlobalTypesU;
{$M+}
{$RTTI EXPLICIT FIELDS([vcPrivate])}
type
EPerson = class(Exception);
EPersonsList = class(Exception);
TGender = (Female, Male);
TPerson = class(TObject)
private
FFirstName: string;
FLastName: string;
FId: Integer;
FGender: TGender;
FModified : Boolean;
[JSONMarshalled(False)]
FPicture: Integer;
// [JSONMarshalled(False)] FPicture : TPicture;
function GetName: string;
procedure SetFirstName(const Value: string);
procedure SetLastName(const Value: string);
function GetId: Integer;
procedure SetGender(const Value: TGender);
procedure SetModified(const Value: Boolean);
public
property Id : Integer read GetId;
property Name : string read GetName;
property FirstName : string read FFirstName write SetFirstName;
property LastName : string read FLastName write SetLastName;
property Gender : TGender read FGender write SetGender;
property Modified : Boolean read FModified write SetModified;
// property Picture : TPicture read FPicture write FPicture;
[JSONMarshalled(False)]
property Picture : Integer read FPicture write FPicture;
function Update : Boolean;
function Delete : Boolean;
constructor Create(AId : Integer; AFirstName, ALastName : string; AGender : TGender); overload;
constructor Create(AFirstName, ALastName : string; AGender : TGender); overload;
destructor destroy; override;
function ToJsonString: string;
end;
But clearly it has no effect on the marshalling, Picture is still there - what am I missing?
function TPerson.ToJsonString: string;
begin
result := TJson.ObjectToJsonString(self);
end;
08-03-2016 10:26:24 [NORMAL] AddPerson serialized {"firstName":"Donald","lastName":"Duck","id":24,"gender":"Female","modified":false,"picture":92415648}
You are using TJson.ObjectToJsonString from REST.Json unit and that one needs different attribute to skip fields named JSONMarshalledAttribute
You should change your code to [JSONMarshalledAttribute(False)]
Delphi has a bit of mix up between older Data.DBXJsonReflect and newer REST.Json units and you should not mix them together in same code. Pick only one of them.
REST.Json.TJson.ObjectToJsonString
REST.Json.Types.JSONMarshalledAttribute
Data.DBXJSONReflect.JSONMarshalled
Yes - I found the solution, when using DBX (and not REST) you'll need add this unit "Data.DBXJSON" rather than the "REST.JSON" and change the two "from/to" methods for un/marshaling the object something like this.
NOTE. ToJSONString leaks for some reason, I'll have to investigate that more.
function TPerson.ToJsonString: string;
var
JSONMarshal: TJSONMarshal;
begin
result := '';
JSONMarshal := TJSONMarshal.Create(TJSONConverter.Create);
try
Result := JSONMarshal.Marshal(self).ToString;
finally
JSONMarshal.Free;
end;
end;
class function TPerson.FromJsonString(AJSONString: string): TPerson;
var
JSONUnMarshal: TJSONUnMarshal;
begin
JSONUnMarshal := TJSONUnMarshal.Create;
try
Result := JSONUnMarshal.Unmarshal(TJSONObject.ParseJSONValue(AJSONString)) as TPerson;
finally
JSONUnMarshal.Free;
end;
end;
// interface
iccItem =
class
ID : String;
DATA : Variant;
constructor Create( _id : String; _data : Variant);
end;
iccDynamicObject =
class
private
FItems : TList;
function locate( _id : String) : iccItem;
public
constructor Create();
destructor Destroy(); override;
public
procedure define( _id : String; _dta : Variant);
//function get( _ndx : DWORD) : Variant; overload;// link to original data
function get( _id : String) : Variant; overload;
public
property Items[_id : String] : Variant read get write define; default;
end;
// implementation
{ iccDynamicObject }
constructor iccItem.Create( _id : String; _data : Variant);
begin
ID := _id;
DATA := _data;
end;
function iccDynamicObject.locate( _id : String) : iccItem;
var ndx : integer;
tmp : iccItem;
begin
result := nil;
for ndx := 0 to FItems.Count - 1 do
begin
tmp := iccItem( FItems[ndx]);
if tmp.ID = _id
then begin
result := tmp;
exit;
end;
end;
end;
constructor iccDynamicObject.Create();
begin
FItems := TList.Create();
end;
destructor iccDynamicObject.Destroy();
begin
{$MESSAGE 'clear here'}
FItems.Destroy();
inherited;
end;
procedure iccDynamicObject.define( _id : String; _dta : Variant);
var tmp : iccItem;
begin
tmp := locate( _id);
if tmp = nil
then FItems.Add( iccItem.Create( _id, _dta) )
else tmp.DATA := _dta;
end;
//function iccDynamicObject.get( _ndx : DWORD) : Variant;
//begin
// result.vPointer := nil;
//end;
function iccDynamicObject.get( _id : String) : Variant;
var tmp : iccItem;
begin
tmp := locate( _id);
if tmp = nil
then result.vaNull := true
else result := locate( _id).DATA;
end;
// using
procedure TForm1.FormCreate(Sender: TObject);
var c : iccDynamicObject;
begin
c := iccDynamicObject.Create;
c['asd'] := 123;
c.Destroy;
end;
Set breakpoint in DELPHI 2010 at iccDynamicObject.define() -> tmp := locate( _id);
will cause #Project Project1.exe raised exception class EVariantBadVarTypeError with message 'Invalid variant type'.#
Code was tested in DELPHI 7, and this problem was not encountered!
ps. code was rewritten in delphi-7 style without in-class types for demonstrating a problem...
SOLVED -> Do not use in-class generic types, such as
classDef<_type> =
class
type
// this
internalClass<_anotherType> =
class
private
FSomething : _anotherType;
end;
// or this one
internalClass2 =
class
private
FSomething : _type;
end;
private
FInternalClass : internalClass<_type>;
FInternalClass2 : internalClass;
end;
Such things will procure debugger or compiler to do UNEXCECTED THINGS!!!
Code compiles and work correctly. But in my case, with Unit growth code become unstable
and coerce me to make some code-refactoring, just a little, but more than inconvenient...
You are Noticed :)))
This is a known bug in D2010 which has been reported in QualityCentral and fixed in XE.
Try assigning tmp := nil; in the locate method next to where you assign nil to result. If this resolves the exception, I'll explain why.
This problem occured by unexpected debugger or compiler behavior, and such behavior was caused by bugs in Delphi 2010 (they might be fixed in Delphi XE, as David Heffernan mentioned).
I have only one conclusion: Do not use in-class generic types, such as:
classDef<_type> =
class
type
// this
internalClass<_anotherType> =
class
private
FSomething : _anotherType;
end;
// or this one
internalClass2 =
class
private
FSomething : _type;
end;
private
FInternalClass : internalClass<_type>;
FInternalClass2 : internalClass;
end;
Such things will cause the debugger or compiler to do unexpected things. The code compiles and works correctly. But in my case, with Unit growth code becoming unstable it has forced me to do some code-refactoring.
Did you try with a New VCL Forms Applications, including the code you provided?
I did...
1- setting the break point does not do anything (no harm either), because you have to read your item to call get(_id)
2- I added a line to that effect:
c['asd'] := 123;
i := c['asd']; // <=== added
c.Destroy;
3- the breakpoint worked as expected, without any exception
So I'm guessing there is something else going on....
I'm currently creating a class to write and read arrays
Opening a file, closing a file all works well.
Also, I'm able to write an array towards a bin file.
But returning an array from the class is a bridge to far.
So far, ther're 2 issues where I'm not able to work around
1) in the public section
function ReadArrFromFile : array of single;
==> identifier expected but array found & incompatible types single and dynamic array
2) In the implementation with function Tbinfiles.ReadArrFromFile : array of single,
==> I always get E2029 Identifier expected but ARRAY found
For 1), if I define array of single in the main program it's not causing any problem
2) same for the ReadArrFromFile works fine on the main program
I'm working with codegear RAD delphi 2007 & windows vista.
unit UbinFiles;
interface
type
TBinFiles = Class
private
pFileName : String; // File name (FILENAME.bin)
pFileType : string; // File type (of .. )
pFileLoc : string; // FileLocation path
pMyarr : array of single; // array to receive / provide results
pArrLen : integer; // To define arraylength
pFKA : file; // File Known As or the internal name
pRecsWritten : integer; // # of blocks written towards file
pRecsRead : integer; // # of blocks read from file
public
procedure SetFname(const Value: String);
procedure SetFtype(const Value: String);
procedure SetFLoc(const Value: String);
procedure SetArrLen(const Value: integer);
constructor Create; overload;
constructor Create(Fname : String); overload;
constructor Create(Fname : String ; Ftype : string); overload;
constructor Create(Fname : String ; Ftype : string ; FLoc : String); overload ;
procedure OpenMyFile;
procedure CloseMyFile;
procedure Write2MyFile(Myarr : array of single );
procedure ReadFromMyFile;
function CheckBackSpace(MyPath : string) : string ;
procedure TSTreadAnArray(Myarr : array of single);
//---first problem
function ReadArrFromFile : array of single;
published
property Fname : String read pFileName write SetFname;
property Ftype : String read pFileType write SetFtype;
property FLoc : String read pFileLoc write SetFLoc;
property ArrLen : integer read pArrLen write SetArrLen;
end;
implementation
uses
Dialogs, SysUtils, StrUtils; // controls required for this class
//
//---Constructors-----------------------------
//
constructor TBinFiles.Create; // void constructor
begin
inherited;
self.pFileName := 'MyBinary';
self.pFileType := '';
self.pFileLoc := 'C:\Users\';
self.pRecsWritten := 0;
self.pRecsRead := 0;
end;
constructor TBinFiles.Create(Fname: String); // contructor + Fname
begin
self.pFileName := Fname;
self.pFileType := '';
self.pFileLoc := 'C:\Users\';
self.pRecsWritten := 0;
self.pRecsRead := 0;
end;
constructor TBinFiles.Create(Fname: String ; Ftype : string); // constructor etc..
begin
self.pFileName := Fname;
self.pFileType := Ftype;
self.pFileLoc := 'C:\Users\';
self.pRecsWritten := 0;
self.pRecsRead := 0;
end;
constructor TBinFiles.Create(Fname: String ; Ftype : string ; FLoc : string);
begin
self.pFileName := Fname;
self.pFileType := Ftype;
self.pFileLoc := CheckBackSpace(FLoc);
self.pRecsWritten := 0;
self.pRecsRead := 0;
end;
//
//----setters---------------------------------------
//
procedure TBinFiles.SetFname(const Value: String); // pFileName
begin
pFileName := Value;
end;
procedure TBinFiles.SetFtype(const Value: String); // pFileType
begin
pFileType := Value;
end;
procedure TBinFiles.SetFLoc(const Value: String); // pFileLoc
begin
pFileLoc := Value;
end;
procedure TBinFiles.SetArrLen(const Value: integer);
begin
pArrLen := Value;
end;
//
//---general functions / procs----
//
procedure Tbinfiles.OpenMyFile;
begin
try
AssignFile(self.pFKA, self.pFileLoc + self.pFileName +'.bin');
ReWrite(self.pFKA);
except
on E : Exception do
begin
ShowMessage(E.ClassName+' error raised, with message : '+E.Message);
end;
End;
end;
procedure Tbinfiles.CloseMyFile;
begin
CloseFile(self.pFKA);
End;
procedure Tbinfiles.Write2MyFile(Myarr : array of single );
begin
BlockWrite(self.pFKA, Myarr, 1,self.pRecsWritten);
End;
procedure Tbinfiles.ReadFromMyFile;
begin
BlockRead(self.pFKA, self.pMyarr, 1,self.pRecsread);
End;
//------second problem----------------------------------------------<<<<<< doesn't work
function Tbinfiles.ReadArrFromFile : array of single ;
begin
BlockRead(self.pFKA, self.pMyarr, 1,self.pRecsread);
End;
function Tbinfiles.CheckBackSpace(MyPath : string) : string ;
begin
if AnsiRightStr(MyPath, 1) = '\'
then Result := MyPath
else Result := MyPath + '\'
;
end;
procedure Tbinfiles.TSTreadAnArray(Myarr : array of single );
var i:integer;
begin
for i := 0 to high(Myarr) do
begin
showmessage('Element ' + intToStr(i)+ floatToStr(MyArr[i]) );
end;
end;
end.
You can't have an array as a property, but you can have array properties:
TMyObject = class
private
function GetSingleArray(aIndex: Integer): Single;
procedure SetSingleArray(aIndex: Integer; const Value: Single);
function GetSingleArrayCount: Integer;
procedure SetSingleArrayCount(const Value: Integer);
public
property SingleArray[aIndex: Integer]: Single read GetSingleArray write SetSingleArray;
//returns or sets the length of the single array
property SingleArrayCount: Integer read GetSingleArrayCount write SetSingleArrayCount;
end;
You can use a named type - try TSingleDynArray from unit Types.
However using array properties (see The_Fox's answer) might be more appropriate.
1)At first declare array type..
type
TpMyarr = array of single;
...and than yo can do:
function ReadArrFromFile : TpMyarr;
2)Before writing in dinamic array call SetLength first.
3)There is no need to use 'self.' in your program!
4)Instead BlockRead/BlockWrite use TFileStream delphi class.