TCollection as published property

[KKAA]

Hi guys.
I have collection:

Code: [Select]

  TRange = class(TCollectionItem)
  private
    FColorIndex1: Integer;
    FColorIndex2: Integer;
    FRange: String;
    procedure SetColorIndex1(AValue: Integer);
    procedure SetColorIndex2(AValue: Integer);
    procedure SetRange(AValue: String);
  public
    procedure Assign(Source: TPersistent); override;
  published
    property ColorIndex1: Integer read FColorIndex1 write SetColorIndex1;
    property ColorIndex2: Integer read FColorIndex2 write SetColorIndex2;
    property Range: String read FRange write SetRange;
  end;

  TRanges = class(TCollection)
  private
    function GetItems(Index: Integer): TRange;
    procedure SetItems(Index: Integer; AValue: TRange);
  public
    function Add: TRange;
    property Items[Index: Integer]: TRange read GetItems write SetItems; default;
  end;
as published property of object class(TPersistent):

Code: [Select]

  TCastObject = class(TPersistent)
  private
    FisImage: Boolean;
    FPicture: TPicture;
    FRanges: TRanges;
    procedure SetisImage(AValue: Boolean);
    procedure SetPicture(AValue: TPicture);
    procedure SetRanges(AValue: TRanges);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
  published
    property Picture: TPicture read FPicture write SetPicture;
    property Ranges: TRanges read FRanges write SetRanges;
    property isImage: Boolean read FisImage write SetisImage;
  end; This object declared as published property of TComponent:

Code: [Select]

  TPinContainer = class(TComponent)
  private
    FPinCast: TCastObject;
    procedure SetPinCast(AValue: TCastObject);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property PinCast: TCastObject read FPinCast write SetPinCast;
  end;

I write this component into stream using WriteComponent method. This code works perfectly, but then, suddenly, it stop working.
When i write component only first item of Collection got into stream. If i disable all other properties in Object, then all records of Collection got there.
This code works in Delphi. I don't see any errors or misspell in it.
Why did it happen? Help me please...

[Thaddy]

Well, a declaration (interface section) isn't much use. There is nothing wrong with that.
We need the implementation section to comment on any possible causes..

[KKAA]

Well, a declaration (interface section) isn't much use. There is nothing wrong with that.
We need the implementation section to comment on any possible causes..

Ok, there is full source:

Code: [Select]

unit PinContainer;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Graphics;

type

  { TRange }

  TRange = class(TCollectionItem)
  private
    FColorIndex1: Integer;
    FColorIndex2: Integer;
    FRange: String;
    procedure SetColorIndex1(AValue: Integer);
    procedure SetColorIndex2(AValue: Integer);
    procedure SetRange(AValue: String);
  public
    procedure Assign(Source: TPersistent); override;
  published
    property ColorIndex1: Integer read FColorIndex1 write SetColorIndex1;
    property ColorIndex2: Integer read FColorIndex2 write SetColorIndex2;
    property Range: String read FRange write SetRange;
  end;

  { TRanges }

  TRanges = class(TCollection)
  private
    function GetItems(Index: Integer): TRange;
    procedure SetItems(Index: Integer; AValue: TRange);
  public
    function Add: TRange;
    property Items[Index: Integer]: TRange read GetItems write SetItems; default;
  end;

  { TCastObject }

  TCastObject = class(TPersistent)
  private
    FisImage: Boolean;
    FPicture: TPicture;
    FRanges: TRanges;
    procedure SetisImage(AValue: Boolean);
    procedure SetPicture(AValue: TPicture);
    procedure SetRanges(AValue: TRanges);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
  published
    property Picture: TPicture read FPicture write SetPicture;
    property Ranges: TRanges read FRanges write SetRanges;
    property isImage: Boolean read FisImage write SetisImage;
  end;

    { TPinContainer }

    TPinContainer = class(TComponent)
  private
    FPinCast: TCastObject;
    procedure SetPinCast(AValue: TCastObject);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property PinCast: TCastObject read FPinCast write SetPinCast;
  end;

implementation

{ TPinContainer }

procedure TPinContainer.SetPinCast(AValue: TCastObject);
begin
  FPinCast.Assign(AValue);
end;

constructor TPinContainer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FPinCast:=TCastObject.Create;
end;

destructor TPinContainer.Destroy;
begin
  FreeAndNil(FPinCast);
  inherited Destroy;
end;

{ TCastObject }

procedure TCastObject.SetisImage(AValue: Boolean);
begin
  if FisImage=AValue then Exit;
  FisImage:=AValue;
end;

procedure TCastObject.SetPicture(AValue: TPicture);
begin
  FPicture.Assign(AValue);
end;

procedure TCastObject.SetRanges(AValue: TRanges);
begin
  FRanges.Assign(AValue);
end;

constructor TCastObject.Create;
begin
  FRanges:=TRanges.Create(TRange);
  FPicture:=TPicture.Create;
end;

destructor TCastObject.Destroy;
begin
  FreeAndNil(FRanges);
  FreeAndNil(FPicture);
  inherited Destroy;
end;

procedure TCastObject.Assign(Source: TPersistent);
begin
  if Source is TCastObject then
  begin
    FRanges.Assign((Source as TCastObject).FRanges);
    FPicture.Assign((Source as TCastObject).FPicture);
    FisImage:=(Source as TCastObject).FisImage;
  end
  else inherited Assign(Source);
end;

{ TRanges }

function TRanges.GetItems(Index: Integer): TRange;
begin
  Result:=GetItem(Index) as TRange;
end;

procedure TRanges.SetItems(Index: Integer; AValue: TRange);
begin
  SetItem(Index, AValue);
end;

function TRanges.Add: TRange;
begin
  Result:=inherited Add as TRange;
end;

{ TRange }

procedure TRange.SetColorIndex1(AValue: Integer);
begin
  if FColorIndex1=AValue then Exit;
  FColorIndex1:=AValue;
end;

procedure TRange.SetColorIndex2(AValue: Integer);
begin
  if FColorIndex2=AValue then Exit;
  FColorIndex2:=AValue;
end;

procedure TRange.SetRange(AValue: String);
begin
  if FRange=AValue then Exit;
  FRange:=AValue;
end;

procedure TRange.Assign(Source: TPersistent);
begin
  if Source is TRange then
  begin
    FRange:=(Source as TRange).FRange;
    FColorIndex1:=(Source as TRange).FColorIndex1;
    FColorIndex2:=(Source as TRange).FColorIndex2;
  end
  else inherited Assign(Source);
end;

end.
there is code for write/read:

Code: [Select]

procedure LoadFromFile(AComponent: TComponent; Filename: String);
var
  fs: TFileStream;
begin
  fs:=TFileStream.Create(Filename, fmOpenRead);
  try
    if fs.Size>0
      then fs.ReadComponent(AComponent);
  finally
    FreeAndNil(fs);
  end;
end;

procedure SaveToFile(AComponent: TComponent; FileName: String);
var
  fs: TFileStream;
begin
  fs:=TFileStream.Create(FileName, fmOpenWrite or fmCreate);
  try
    fs.WriteComponent(AComponent);
  finally
    FreeAndNil(fs);
  end;
end;
As i say before, it works perfectly until day before yesterday and i don't change anything in IDE or FPC, just turned on heaptrc. I don't know what happened 
P.S. And it still works on Delphi...

[Basile B.]

In a sample project it loads without problem, even with heaptrc.
The code is really fine, there is no error. Perhaps the error comes
from elsewhere.

I join the sample project.
Maybe you could try to reproduce the error in a simple application like this.

[howardpc]

@BBasile, an interesting example.
BTW you forgot a final

Code: [Select]

pn.Free;
which gives a bad memory leak.

Also, should not this implementation:

Code: [Select]

constructor TCastObject.Create;
begin
  FRanges:=TRanges.Create(TRange);
  FPicture:=TPicture.Create;
end;   

include the following statement?

Code: [Select]

inherited Create;


[Basile B.]

No, TCastObject is a TPersistent, which has no virtual constructor. The OP error doesn't come from this.

I doubt the error comes from the code that the guy has posted. The sample posted previously is just a rough copy of that.

[KKAA]

Ok, 10x for reply BBasile, your sample did work, i forgot to add begin..end in my cycle. But code i post earlier, it's my second attempt, the first one i add to your sample. That code also works on Delphi. But in my copy of Lazarus it adds an empty fields.
Please test it...

[Basile B.]

you forgot to add the pn.free at the end so when the sample exit the leak tracer write a bunch of lines, but otherwise, once added, still no error !

[KKAA]

Oh, you mean, this line?

Code: [Select]

FreeAndNil(pn)
This is ridiculous, why is this code works on your copy of lazarus and stops working on mine? 


PS Please, test it again and look on the size of the resulting file. Should be approx 60kb

PPS in attachment resulting file on my mashine

[Basile B.]

The output file on mine is ok, i mean much bigger, reloadable. (47Ko)

if i change the sample program to this

Code: [Select]

begin
  pn := TPinContainer.Create(nil);
  pn.PinCast.isImage:=True;
  //pn.PinCast.Picture.LoadFromFile('pmb.jpg');
  //for i:=1 to 10 do
  //  with pn.PinCast.Ranges.Add do
  //  begin
  //    ColorIndex1:=i;
  //    ColorIndex2:=i-1;
  //    Range:=IntToStr(i);
  //  end;
  //SaveToFile(pn, 'test.txt');
  //pn.PinCast.Ranges.Clear;
  LoadFromFile(pn, 'test.txt');
  writeln(pn.PinCast.Ranges.Count);
  readln;
  FreeAndNil(pn);
end.
       

it still displays 10 items (with the file produced on my computer). If i use the file you've produced then it crashes.

This is definitively a problem related to your setup, your computer, or i don't know what...I can't help more. From the beginning i was sure that the code is ok.

By a pure hasard, did you change something to the LCL/FCL source code ?

[KKAA]

Oops i attached wrong project
This is right one
Sorry