Delphi TPair Exception - delphi

I have this spike to test TPair. You can copy+paste on a new Delphi XE Console-app. I have marked the line with the exception:
Project Project1.exe raised exception
class EAccessViolation with message
'Access violation at address 0045042D
in module 'Project1.exe'. Read of
address A9032D0C.
Any Idea ?
Thanks.
program Project1;
{$APPTYPE CONSOLE}
uses
SysUtils,
Generics.Defaults,
Generics.Collections;
type
TProduct = class
private
FName: string;
procedure SetName(const Value: string);
published
public
property Name: string read FName write SetName;
end;
type
TListOfProducts = TObjectDictionary<TProduct, Integer>;
{ TProduct }
procedure TProduct.SetName(const Value: string);
begin
FName := Value;
end;
var
MyDict: TListOfProducts;
MyProduct1: TProduct;
MyProduct2: TProduct;
MyProduct3: TProduct;
APair: TPair<TProduct, Integer>;
aKey: string;
begin
try
MyDict := TListOfProducts.Create([doOwnsKeys]);
MyProduct1 := TProduct.Create;
MyProduct1.Name := 'P1';
MyProduct2 := TProduct.Create;
MyProduct2.Name := 'P2';
MyProduct3 := TProduct.Create;
MyProduct3.Name := 'P3';
MyDict.Add(MyProduct1, 1);
MyDict.Add(MyProduct2, 2);
MyDict.Add(MyProduct3, 3);
APair := MyDict.ExtractPair(MyProduct1);
Writeln(APair.Key.Name); // <--- Error is Here.
Writeln(IntToStr(APair.Value));
Readln(aKey);
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.

This is a Delphi bug. TDictionary<TKey,TValue>.ExtractPair does not assign Result.
RRUZ located the bug in QC.
The code reads:
function TDictionary<TKey,TValue>.ExtractPair(const Key: TKey): TPair<TKey,TValue>;
var
hc, index: Integer;
begin
hc := Hash(Key);
index := GetBucketIndex(Key, hc);
if index < 0 then
Exit(TPair<TKey,TValue>.Create(Key, Default(TValue)));
DoRemove(Key, hc, cnExtracted);
end;
Result should be assigned when the call to DoRemove is made.
It's quite hard to work around this bug. ExtractPair is the only way to get an item out of the dictionary without destroying the key and so you have to call it. But since it won't return the extracted item, you need to first read the item, remember the value, and then call ExtractPair.

Related

Exception.RaiseOuterException vs. W1035 Return value of function '%s' might be undefined

This already is reported as RSP-25603: "Exception.RaiseOuterException can cause wrong W1035 warning".
Given the following (demo) function F, I have changed an exception raising statement to now chain exceptions:
--- before
+++ after
## -1,11 +1,11 ##
function F(X: NativeInt): NativeInt;
begin
try
Result := 1 div X;
except
on EDivByZero do
- {ECustom}Exception.Create('...');
+ Exception.RaiseOuterException({ECustom}Exception.Create('...'));
else
raise;
end;
end;
Now, Ctrl-F9 gives the warning W1035:
[dcc32 Warning]: W1035 Return value of function 'F' might be undefined
However, all cases are handled. The compiler fails to recognize Exception.RaiseOuterException as the raise operation it is.
Unfortunately FAcquireInnerException: Boolean is private to the Exception class, not even to be set to True in derived custom classes which I could keep raising directly (raise ECustomException.Create).
Is there any way to make the compiler understand, while keeping the exceptions chained? Otherwise I can think of {$Warn No_RetVal Off}. How else could I work around this warning?
One way I can think of to avoid the warning, without disabling it, is to do the following instead:
function F(X: NativeInt): NativeInt;
begin
try
Result := 1 div X;
except
on E: Exception do
begin
if E is EDivByZero then
Exception.RaiseOuterException({ECustom}Exception.Create('...'));
raise;
end;
end;
end;
UPDATE: Another way, as stated in a comment, would be to simply define a return value that is not actually reached at runtime, eg:
function F(X: NativeInt): NativeInt;
begin
try
Result := 1 div X;
except
on E: EDivByZero do
begin
Exception.RaiseOuterException({ECustom}Exception.Create('...'));
Result := 0; // <-- just to keep the compiler happy
end;
end;
end;
EChainedException solution
(as requested by Max)
Update
I have put out a FR for this at Embarcadero. Please vote if you like this proposed solution. RSP-31679
By using this class, the inner exception is always recorded "as if" you had called Exception.RaiseOuterException. This allows you to use the simple raise statement, this avoids the warning message being issued by the compiler.
Useage
Just derive your custom exceptions from EChainedException instead of Exception, and use raise rather then Exception.RaiseOuterException.
Sourcecode
The relevant code is below. My complete EChainedException is a bit more complicated than this for supporting detection of fatal exceptions and stacktracing etc. If it doesn't compile, let me know what's missing and I'll add the missing part.
unit uChainedException;
interface
uses Sysutils;
{$M+} // ensures RTTI info is present for EChainedException
type
EChainedException = class(Exception)
protected
procedure RaisingException(P: system.sysutils.PExceptionRecord); override;
end;
implementation
uses rtti;
var // rtti pointers for handling the inner exception
vInnerExceptionOffset: NativeInt = -1;
vAcquireInnerExceptionOffset: NativeInt = -1;
vRunningInIDEInitialized: Boolean;
vRunningInIDE: Boolean;
function RunningInIDE:boolean;
begin
if not vRunningInIDEInitialized then
begin
vRunningInIDE:=AnsiSameText(ExtractFileName(ParamStr(0)),'BDS.EXE');
vRunningInIDEInitialized:=True;
end;
Result:=vRunningInIDE;
end;
procedure EChainedException.RaisingException(P: System.sysutils.PExceptionRecord);
var
PBoolean: ^Boolean;
PObject : ^TObject;
begin
if (ExceptObject<>self) and (vAcquireInnerExceptionOffset >=0) then
begin
PBoolean := Pointer(NativeInt(Self)+vAcquireInnerExceptionOffset);
PBoolean^ := PBoolean^ or not RunningInIDE;
end;
inherited;
// in some rare cases (like reraise exception from another thread)
// it may happen that the innerexception points to self
// this is corrected here.
if InnerException=self then
begin
PObject := Pointer(NativeInt(Self)+vInnerExceptionOffset);
PObject^ := nil;
end;
end;
procedure UnprepAutoInnerException;
begin
vInnerExceptionOffset:=-1;
vAcquireInnerExceptionOffset:=-1;
end;
procedure PrepAutoInnerException;
var
lRTTIContext: TRttiContext;
lInnerException:TRttiField;
lAcquireInnerException:TRttiField;
lClass: TRttiInstanceType;
begin
try
lRTTIContext.Create; //Notice vRTTIContext is a record, .Create initializes properties
try
lClass:=lRTTIContext.GetType(Exception) as TRttiInstanceType;
lInnerException:=lClass.GetField('FInnerException');
vInnerExceptionOffset := lInnerException.Offset;
lAcquireInnerException:=lClass.GetField('FAcquireInnerException');
vAcquireInnerExceptionOffset := lAcquireInnerException.Offset;
except
UnprepAutoInnerException;
raise;
end;
finally
lRTTIContext.Free;
end;
end;
initialization
PrepAutoInnerException;
finalization
UnprepAutoInnerException;
end.
Looking at this code I find it could use some modernizing, eg by using class vars instead of globals, and by using inline locale variables.
The entire unit is back from Delphi 6 days and contains many $ifdefs, and left out because it would surpass the answer.
I still wonder why exception chaining is not the default in delphi/rad studio like it is in other languages. Most likely because it would break existing code somehow.
I (also) answer my own question as I will take yet another approach. It provides for the following requirements:
I like to keep the raise statements, as they initially were,
so there won't be any necessary code changes here, and
which also means there won't be newly introduced warnings like W1035 or W1036.
I don't want to rebuild the inner RTL mechanics, however
I want to interfere with the RTL mechanics as little as possible.
I want to be flexible in controlling for chaining exceptions
sometimes forced or by default, on the exception implementation side, as well as
sometimes by argument, on the exception usage side, to extend functionality.
In my solution:
I accept to break through the Exception fields' visibility, FAcquireInnerException specifically.
I rely on RTTI to verify the fields' alignment (in ExceptionFields, according to Exception).
Here I provide a condensed implementation to copy-and-paste:
EException's constructor showcases the use of ExceptionFields:
ExceptionFields(Self).FAcquireInnerException := True;
-- to be used in any Exception-derived exception, and it will trigger the RTL mechanics to set the InnerException while it is raising the exception. Also, EException may serve as a common root for custom exception classes, if desired. Some constructors are reintroduced to be extended with const AcquireInnerException: Boolean = True, to hand-over the control to the caller while providing a default for the desired chaining.
Run ExceptionFields.VerifyFieldAlignments, if you want to verify the alignments of
the ("re-") declared externally accessible fields in ExceptionFields and
their (private) counterparts in Exception.
If it cannot verify this, it will raise an exception. It is run in EException's class constructor. Move it as propriate to you, if you do not use EException, yet want to keep the verification.
(Condensed) implementation:
unit Exceptions;
interface
uses
System.SysUtils;
type
EException = class (Exception)
public
class constructor Create;
constructor Create(const Msg: String; const AcquireInnerException: Boolean = True);
constructor CreateFmt(const Msg: String; const Args: array of const; const AcquireInnerException: Boolean = True); overload;
constructor CreateRes(const Msg: PResStringRec; const AcquireInnerException: Boolean = True);
constructor CreateResFmt(const Msg: PResStringRec; const Args: array of const; const AcquireInnerException: Boolean = True); overload;
end;
type
ExceptionFields = class (TObject)
{$Hints Off} // H2219
strict private
FMessage: String;
FHelpContext: Integer;
FInnerException: Exception;
FStackInfo: Pointer;
{$Hints On}
public
FAcquireInnerException: Boolean;
private
class procedure VerifyFieldAlignments;
end;
implementation
uses
System.Generics.Collections,
System.RTTI,
System.TypInfo;
{ ExceptionFields }
class procedure ExceptionFields.VerifyFieldAlignments;
procedure RaiseTypeNotFound(const ClassName: String);
begin
raise Exception.CreateFmt(
'Typ nicht gefunden: %s',
[ClassName]
);
end;
procedure RaiseFieldNotFound(const ClassName, FieldName: String);
begin
raise Exception.CreateFmt(
'Feld nicht gefunden: %s.%s',
[ClassName, FieldName]
);
end;
procedure RaiseFieldNotAligned(const LeftClassName: String; const LeftField: TPair<String, Integer>; const RightClassName: String; const RightField: TRTTIField);
begin
raise Exception.CreateFmt(
'Feld nicht ausgerichtet: %s.%s+%d (tatsächlich) vs. %s.%s+%d (erwartet)',
[
LeftClassName,
LeftField.Key,
LeftField.Value,
RightClassName,
RightField.Name,
RightField.Offset
]
);
end;
type
TMemberVisibilities = set of TMemberVisibility;
function GetDeclaredFields(const RTTIContext: TRTTIContext; const &Class: TClass; const IncludedVisibilities: TMemberVisibilities = [mvPublic, mvPublished]): TArray<TPair<String, Integer>>;
var
RTTIType: TRTTIType;
RTTIFields: TArray<TRTTIField>;
Index: NativeInt;
RTTIField: TRTTIField;
begin
RTTIType := RTTIContext.GetType(&Class);
if not Assigned(RTTIType) then
RaiseTypeNotFound(&Class.ClassName);
RTTIFields := RTTIType.GetDeclaredFields;
SetLength(Result, Length(RTTIFields));
Index := 0;
for RTTIField in RTTIFields do
if RTTIField.Visibility in IncludedVisibilities then
begin
Result[Index] := TPair<String, Integer>.Create(
RTTIField.Name,
RTTIField.Offset
);
Inc(Index);
end;
SetLength(Result, Index);
end;
const
Left: TClass = ExceptionFields;
Right: TClass = Exception;
var
RTTIContext: TRTTIContext;
DeclaredFields: TArray<TPair<String, Integer>>;
RTTIType: TRTTIType;
DeclaredField: TPair<String, Integer>;
RTTIField: TRTTIField;
begin
RTTIContext := TRTTIContext.Create;
try
DeclaredFields := GetDeclaredFields(RTTIContext, Left);
RTTIType := RTTIContext.GetType(Right);
if not Assigned(RTTIType) then
RaiseTypeNotFound(Right.ClassName);
for DeclaredField in DeclaredFields do
begin
RTTIField := RTTIType.GetField(DeclaredField.Key);
if not Assigned(RTTIField) then
RaiseFieldNotFound(Right.ClassName, DeclaredField.Key);
if DeclaredField.Value <> RTTIField.Offset then
RaiseFieldNotAligned(
Left.ClassName, DeclaredField,
RTTIType.Name, RTTIField
);
end;
finally
RTTIContext.Free;
end;
end;
{ EException }
class constructor EException.Create;
begin
inherited;
ExceptionFields.VerifyFieldAlignments;
end;
constructor EException.Create(const Msg: String;
const AcquireInnerException: Boolean);
begin
inherited Create(Msg);
ExceptionFields(Self).FAcquireInnerException := AcquireInnerException;
end;
constructor EException.CreateFmt(const Msg: String;
const Args: array of const;
const AcquireInnerException: Boolean);
begin
inherited CreateFmt(Msg, Args);
ExceptionFields(Self).FAcquireInnerException := AcquireInnerException;
end;
constructor EException.CreateRes(const Msg: PResStringRec;
const AcquireInnerException: Boolean);
begin
inherited CreateRes(Msg);
ExceptionFields(Self).FAcquireInnerException := AcquireInnerException;
end;
constructor EException.CreateResFmt(const Msg: PResStringRec;
const Args: array of const;
const AcquireInnerException: Boolean);
begin
inherited CreateResFmt(Msg, Args);
ExceptionFields(Self).FAcquireInnerException := AcquireInnerException;
end;
end.
And a demo:
program ExceptionsDemo;
{$AppType Console}
{$R *.res}
uses
System.SysUtils,
Exceptions in 'Exceptions.pas';
type
EDemoException = class (EException)
end;
begin
try
try
try
raise EZeroDivide.Create('Level 3');
except
raise EException.Create('Level 2', False);
end;
except
raise EDemoException.Create('Level 1');
end;
except
on E: Exception do
begin
WriteLn(E.ClassName, ': ', E.Message);
while Assigned(E.InnerException) do
begin
E := E.InnerException;
WriteLn(E.ClassName, ': ', E.Message);
end;
end;
end;
ReadLn;
end.
Output -- the last line is only there on raise EException.Create('Level 2', True):
EDemoException: Level 1
EException: Level 2
EZeroDivide: Level 3
Thank you to all repliers!

Record the value in the field through RTTI

We need to create a class using rtti with preset values. The values are taken from the attribute. All seems fine works exactly the time when you need to add value in the field. Find the right property and gets the value of the attribute is true. But the record is not operated. Tell me where wrong?
program DemoGenerator;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils,
System.Rtti;
Type
// My attribute
DemoDataAttribute = class(TCustomAttribute)
private
FGenerator: String;
public
constructor Create(Generator: String);
published
property Generator: string read FGenerator write FGenerator;
end;
//
TSomeType = Class
private
fPhone: string;
published
[DemoData('+1800764328')]
property Phone: string read fPhone write fPhone;
End;
//
TMegaSuperClass = Class
Function Go<T: Class, constructor>: T;
End;
Procedure Test;
var
LMsc: TMegaSuperClass;
New: TSomeType;
Begin
LMsc := TMegaSuperClass.Create;
try
New := LMsc.Go<TSomeType>;
Writeln('New.Phone: ' + New.Phone);
finally
LMsc.Free;
// New.Free;
end;
End;
{ DemoDataAttribute }
constructor DemoDataAttribute.Create(Generator: String);
begin
FGenerator := Generator;
end;
{ TMegaSuperClass }
function TMegaSuperClass.Go<T>: T;
var
LContext: TRttiContext;
LClass: TRttiInstanceType;
LProp: TRttiProperty;
LAttr: TCustomAttribute;
LField: TRttiField;
begin
// Init Rtti
LContext := TRttiContext.Create;
LClass := LContext.GetType(T) as TRttiInstanceType;
Writeln('LClass: ' + LClass.ToString);
// Result
Result := T.Create;
for LProp in LClass.GetProperties do
begin
Writeln('LProp: ' + LProp.ToString);
for LAttr in LProp.GetAttributes do
begin
Writeln('LAttr: ' + LAttr.ToString);
if LAttr is DemoDataAttribute then
Begin
Writeln('Attr value: ' + DemoDataAttribute(LAttr).Generator);
// How write value?
LProp.SetValue(#Result, DemoDataAttribute(LAttr).Generator);
End;
end;
end;
end;
begin
try
{ TODO -oUser -cConsole Main : Insert code here }
Test;
Readln;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
Console output:
TSomeType
property Phone: string
DemoDataAttribute
value: +1800764328
Phone:
Like this:
LProp.SetValue(Pointer(Result), DemoDataAttribute(LAttr).Generator);
The first argument to SetValue is declared as Instance: Pointer. A class reference is simply the pointer to the instance, which is what you want.

Unexpected failure of custom registered Reverter using TJSONUnMarshal

The code below is from the JSonMarshall project in chapter 7 of Marco Cantu's Delphi 2010 Handbook. The source code is available from here http://cc.embarcadero.com/item/27600. I have made two changes to it:
Add JSon to the implementation Uses clause to get it to compile.
Added the line
theName := 'XXX'; // added by me
to the TDataWithList.Create constructor to assist debugging
I am running the code in Delphi Seattle (without update 1)
The purpose of the project is to demo a custom converter and reverter for the TDataWithList declared type. The custom converter seems to work fine, judging by the result output to Memo1.
However, attempting to run the reverter results in a "Read of address 00000000" AV on the line
sList.Add (Args[I]);
in btnUnmarshalReverterClick. The immediate cause of this is that contrary to what
the author evidently intended, when the above line executes, sList is Nil.
My question is simply why is sList Nil and how to fix this problem?
I have tried, not entirely successfully, to trace through the DBXJSONReflect source
to find out why.
After
Obj := ObjectInstance(FRTTICtx, objType);
in function TJSONUnMarshal.CreateObject, TDataWithList(obj).theName is 'XXX'
as I'd expect and TDataWithList(obj).theLList is an initialized, but empty,
TStringList.
However, by the time the anonymous method in btnUnmarshalReverterClick is called, TDataWithList(Data).theList is Nil.
Update: The reason that TDataWithList(Data).theList (incorrectly, imo) becomes Nil is that it is set to Nil in TJSONPopulationCustomizer.PrePopulate by a call to PrePopulateObjField. So I suppose the question is, why does PrePopulate allow an object's field which has been initialized in its constructor to be overwritten as if it knows better that the object's constructor.
Update2:
There may be an additional problem, in that as far as I can tell, in
TInternalJSONPopulationCustomizer.PrePopulateObjField, the assignment which overwrites TListWithData.theList with Nil, namely
rttiField.SetValue(Data, TValue.Empty);
does not seem to result in the TStringlist destructor being called.
Btw, I get the same error running the project in XE4, which is the earliest version I have which includes JSonUnMarshal.
Code:
type
[...]
TDataWithList = class
private
theName: String;
theList: TStringList;
public
constructor Create (const aName: string); overload;
constructor Create; overload;
function ToString: string; override;
destructor Destroy; override;
end;
[...]
procedure TFormJson.btnMarshalConverterClick(Sender: TObject);
var
theData: TDataWithList;
jMarshal: TJSONMarshal;
jValue: TJSONValue;
begin
theData := TDataWithList.Create('john');
try
jMarshal := TJSONMarshal.Create(
TJSONConverter.Create); // converter is owned
try
jMarshal.RegisterConverter(TDataWithList, 'theList',
function (Data: TObject; Field: string): TListOfStrings
var
I: Integer;
sList: TStringList;
begin
sList := TDataWithList(Data).theList;
SetLength(Result, sList.Count);
for I := 0 to sList.Count - 1 do
Result[I] := sList[I];
end);
jValue := jMarshal.Marshal(theData);
try
Memo1.Lines.Text := jValue.ToString;
finally
jValue.Free;
end;
finally
jMarshal.Free;
end;
finally
theData.Free;
end;
end;
procedure TFormJson.btnUnmarshalReverterClick(Sender: TObject);
var
jUnmarshal: TJSONUnMarshal;
jValue: TJSONValue;
anObject: TObject;
begin
jValue := TJSONObject.ParseJSONValue(
TEncoding.ASCII.GetBytes (Memo1.Lines.Text), 0);
try
jUnmarshal := TJSONUnMarshal.Create;
try
jUnmarshal.RegisterReverter(TDataWithList, 'theList',
procedure (Data: TObject; Field: string; Args: TListOfStrings)
var
I: Integer;
sList: TStringList;
begin
sList := TDataWithList(Data).theList;
for I := 0 to Length(Args) - 1 do
sList.Add (Args[I]);
end);
anObject := jUnmarshal.Unmarshal(jValue);
try
ShowMessage ('Class: ' + anObject.ClassName +
sLineBreak + anObject.ToString);
finally
anObject.Free;
end;
finally
jUnmarshal.Free;
end;
finally
jValue.Free;
end;
end;
function TMyData.ToString: string;
begin
Result := theName + ':' + IntToStr (theValue);
end;
{ TDataWithList }
constructor TDataWithList.Create(const aName: string);
var
I: Integer;
begin
theName := aName;
theList := TStringList.Create;
for I := 0 to 9 do
theList.Add(IntToStr (Random (1000)));
end;
constructor TDataWithList.Create;
begin
// core initialization, used for default construction
theName := 'XXX'; // added by me
theList := TStringList.Create;
end;
destructor TDataWithList.Destroy;
begin
theList.Free;
inherited;
end;
function TDataWithList.ToString: string;
begin
Result := theName + sLineBreak + theList.Text;
end;
rttiField.SetValue(Data, TValue.Empty); simply overrides the field value because as the name implies it's a field, not a property with get / set methods. The destructor of TStringList is not called due to simple pointer assignment.
The solution here is to declare a property:
TDataWithList = class
...
strict private
theList: TStringList;
...
public
property Data: TStringList read ... write SetData
...
end;
TDataWithList.SetData(TStringList aValue);
begin
theList.Assign(aValue);
end;

Delphi Pascal XE4 Compiler bug?

I wonder if I have found an Embarcadero compiler bug ...
The problem looks like it is related to generics.
Here is my source code
unit u_DateCount;
interface
uses
SysUtils,
u_JavaScriptable
;
type
TDateCount = class (TJavaScriptable)
strict private
public
NoOfSamples : Integer;
TheDate : TDate;
function ToString():String; override;
end;
implementation
function TDateCount.ToString():String;
var
myYear, myMonth, myDay : Word;
begin
DecodeDate(TheDate, myYear, myMonth, myDay);
Result := Format('[new Date(%d, %d ,0), %d]', [myYear, myMonth, NoOfSamples]);
end;
end.
unit u_Javascriptable;
interface
type
TJavaScriptable = class
strict private
public
function ToString:String; override;
end;
implementation
function TJavaScriptable.ToString:String;
begin
Result := '';
end;
end.
unit u_LineChart;
interface
uses
System.IOUtils,
SysUtils,
System.Generics.Collections,
u_JavaScriptable
;
type
TLineChart<RecordType : TJavaScriptable> = class
strict private
Template : String;
function ConvertRecordsToString():String;
public
Records : TList<RecordType>;
function ToString():String;
constructor Create(templatePath : String);
destructor Destroy(); override;
end;
implementation
function TLineChart<RecordType>.ConvertRecordsToString():String;
var
I: Integer;
begin
//Open brackets
Result := '[ ';
//The first record
if Records.Count > 0 then
begin
Result := Result + Records[0].ToString();
end;
//Loop over records
for I := 1 to Records.Count - 1 do
begin
Result := Result + ', ' + Records[I].ToString();
end;
//Close bracket
Result := Result + ' ]';
end;
function TLineChart<RecordType>.ToString():String;
begin
Result := Format(Template, [ConvertRecordsToString()]);
end;
constructor TLineChart<RecordType>.Create(templatePath : String);
begin
inherited Create();
Template := TFile.ReadAllText(templatePath);
Records := TList<RecordType>.Create();
end;
destructor TLineChart<RecordType>.Destroy();
var
I: Integer;
begin
if Assigned(Records) then
begin
for I := 0 to Records.Count - 1 do
begin
Records[I].Destroy();
end;
Records.Clear();
Records.Destroy();
Records := nil;
end;
inherited;
end;
end.
And finally the main program
program Project4;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils,
u_Javascriptable in 'u_Javascriptable.pas',
u_LineChart in 'u_LineChart.pas',
u_DateCount in 'u_DateCount.pas';
var
lineChart : TLineChart<TDateCount>;
begin
lineChart := TLineChart<TDateCount>.Create('linechart.html');
try
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
The error message I get when I try to compile this is
[dcc32 Fatal Error] Project4.dpr(30): F2084 Internal Error:
AV097530AC-R00000014-0
Usually when I see an error message similar to this, I can fix it by closing the embarcadero IDE and restarting it. However this did not seem to work this time.
The problem is in the implementation of TLineChart<RecordType>.Destroy().
Change Records[I].Destroy(); to Records[I].Free(); and it works.
Or you just do it correct and use TObjectList<RecordType>.Create; in the constructor which takes care of destroying all elements in it when destroying the list.
Never call Destroy directly. Use Free. While it should not result in a compiler error it is wrong anyway.
If the compiler reports an "internal error," that's always a compiler bug. You should open a ticket in QC for this. Hopefully they can get it fixed for XE5.
Since this works in XE3 but not XE4, I'm going to presume this is an XE4 bug. Until this is fixed, the solution is to use a different version of the compiler such as XE3.

Delphi extract key from TObjectDictionary

sharing the code on this question as reference: Delphi TPair Exception
How can I retrieve the key and value from a TObjectDictionary concrete entry without using TPair and without extracting/remove/delete the pair from the list ?
{$APPTYPE CONSOLE}
uses
SysUtils,
Generics.Defaults,
Generics.Collections;
type
TProduct = class
private
FName: string;
procedure SetName(const Value: string);
published
public
property Name: string read FName write SetName;
end;
type
TListOfProducts = TObjectDictionary<TProduct, Integer>;
{ TProduct }
procedure TProduct.SetName(const Value: string);
begin
FName := Value;
end;
var
MyDict: TListOfProducts;
MyProduct1: TProduct;
MyProduct2: TProduct;
MyProduct3: TProduct;
APair: TPair<TProduct, Integer>;
aKey: string;
begin
try
MyDict := TListOfProducts.Create([doOwnsKeys]);
MyProduct1 := TProduct.Create;
MyProduct1.Name := 'P1';
MyProduct2 := TProduct.Create;
MyProduct2.Name := 'P2';
MyProduct3 := TProduct.Create;
MyProduct3.Name := 'P3';
MyDict.Add(MyProduct1, 1);
MyDict.Add(MyProduct2, 2);
MyDict.Add(MyProduct3, 3);
//the code to look for a **concrete product** (ie: MyProduct1) goes here..
Readln;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
Thanks.
=========================
= Code with the answer =
{$APPTYPE CONSOLE}
uses
SysUtils,
Generics.Defaults,
Generics.Collections;
type
TProduct = class
private
FName: string;
procedure SetName(const Value: string);
published
public
property Name: string read FName write SetName;
end;
type
TListOfProducts = TObjectDictionary<TProduct, Integer>;
{ TProduct }
procedure TProduct.SetName(const Value: string);
begin
FName := Value;
end;
var
MyDict: TListOfProducts;
MyProduct1: TProduct;
MyProduct2: TProduct;
MyProduct3: TProduct;
MySearchedProduct: TProduct; // From Answer.
APair: TPair<TProduct, Integer>;
aProductName: string;
begin
try
MyDict := TListOfProducts.Create([doOwnsKeys]);
MyProduct1 := TProduct.Create;
MyProduct1.Name := 'P1';
MyProduct2 := TProduct.Create;
MyProduct2.Name := 'P2';
MyProduct3 := TProduct.Create;
MyProduct3.Name := 'P3';
MyDict.Add(MyProduct1, 1);
MyDict.Add(MyProduct2, 2);
MyDict.Add(MyProduct3, 3);
Writeln('Enter the Product Name to search: ');
//the code to look for a **concrete product** goes here..
Readln(aProductName);
for MySearchedProduct in Mydict.Keys do
if (MySearchedProduct.Name = aProductName) then
break;
if MySearchedProduct.Name = aProductName then
WriteLn('I have found the product: ' + MySearchedProduct.Name)
else
WriteLn('I have not found a product with that name.');
Readln;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
You can use The Keys and Values properties of MyDict.
In a loop like this:
var
MyProduct: TProduct;
Value: Integer;
begin
for Value in MyDict.Values do
writeln(Value);
for MyProduct in MyDict.Keys do
writeln(MyProduct.Name);
Or by index using ToArray:
writeln(MyDict.Keys.ToArray[1].Name);
writeln(MyDict.Values.ToArray[1]);
The Key and Value are saved in the dictionary as a TPair<TKey,TValue>. If you need to work with both key and value, the logical thing to do is use a TPair;
Looks like this:
for APair in MyDict do
begin
// Your stuff goes here.
end;
If for some reason you don't want to use TPair to extract the pairs you may use something like this, but this is absolutely not a good idea - you're doing lots of dictionary queries for no good reason:
for AKey in MyDict.Keys do
begin
AValue := MyDict[AKey];
// Do something with both AKey and AValue
end;
Looping through the keys could be extrimely slow if your dictionary contains lots of members. I suggest keeping the key in the Pair along with the real value. Considering the example provided it might look like this:
type
TListOfProducts = TObjectDictionary<TProduct, TPair<TProduct,Integer>>;

Resources