Crash when deleting Graphics32 layers - delphi

Question

I've hit an issue when trying to delete layers using Graphics32. It seems that unless you delete layers in reverse order (from the last added to the first) an exception is thrown. I created the simplest application to test this and it is repeatable every time.
I created a simple form with a TImgView32 component (properties all at default) then a button which does the following:
procedure TMainForm.btnDeleteTestClick(Sender: TObject);
var
Layer1: TCustomLayer;
Layer2: TCustomLayer;
begin
Layer1 := TCustomLayer.Create(ImageView.Layers);
Layer2 := TCustomLayer.Create(ImageView.Layers);
Layer1.Free;
Layer2.Free;
end;
If I reverse the order (Layer2.Free then Layer1.Free) it works fine, but this way round it crashes every time. It's also the same whether I use TCustomLayer, TPositionedLayer, TBitmapLayer, or whatever.
I've traved the error and the fault seems to originate here:
function TPointerMap.Delete(BucketIndex, ItemIndex: Integer): PData;
begin
with FBuckets[BucketIndex] do begin
Result := Items[ItemIndex].Data;
if FCount = 0 then Exit;
Dec(Count);
if Count = 0 then SetLength(Items, 0)
else if (ItemIndex < Count) then
Move(Items[ItemIndex + 1], Items[ItemIndex], (Count - ItemIndex - 1) * SizeOf(TPointerBucketItem));
end;
Dec(FCount);
end;
Any idea what is causing this or if I'm doing something wrong? I'm running Delphi XE, by the way.

Answer 1

Here's the code for TCustomLayer.Destroy
destructor TCustomLayer.Destroy;
var
I: Integer;
begin
if Assigned(FFreeNotifies) then
begin
for I := FFreeNotifies.Count - 1 downto 0 do
begin
TCustomLayer(FFreeNotifies[I]).Notification(Self);
if FFreeNotifies = nil then Break;
end;
FFreeNotifies.Free;
FFreeNotifies := nil;
end;
SetLayerCollection(nil); <<-- bug, see below.
inherited; <<---- See note below.
end;
Notice that there's a bug in SetLayerCollection.
Buggy code
procedure TCustomLayer.SetLayerCollection(Value: TLayerCollection);
begin
if FLayerCollection <> Value then begin
if Assigned(FLayerCollection) then begin
if FLayerCollection.MouseListener = Self then
FLayerCollection.MouseListener := nil;
FLayerCollection.RemoveItem(Self);
end;
if Assigned(Value) then Value.InsertItem(Self);
end;
/// FLayerCollection is never set!
end;
The line SetLayerCollection(nil); does not actually set the LayerCollection!
The internal FLayerCollection can suffer from a use after free condition, which is possibly what's happening to you.
Change the code for SetLayerCollection like so:
Bug fix
procedure TCustomLayer.SetLayerCollection(Value: TLayerCollection);
begin
if FLayerCollection <> Value then begin
if Assigned(FLayerCollection) then begin
if FLayerCollection.MouseListener = Self then begin
FLayerCollection.MouseListener := nil;
end;
FLayerCollection.RemoveItem(Self);
end;
if Assigned(Value) then begin
Value.InsertItem(Self)
end;
FLayerCollection:= Value; // add this line.
end;
end;
Note
My hypothesis is that the following snippet causes the error:
SetLayerCollection(nil);
inherited;
SetLayerCollection(value); leaves FLayerCollection unchanged.
The inherited destructor somehow calls something having to do with LayerCollection.
Let me know if this fixes the error.
I've filed a new issue: https://github.com/graphics32/graphics32/issues/13
Update: issue is off by one error in TPointerMap.Delete
The actual issue is here:
https://github.com/graphics32/graphics32/issues/14
The code for TPointerMap.Delete is incorrect:
function TPointerMap.Delete(BucketIndex, ItemIndex: Integer): PData;
begin
with FBuckets[BucketIndex] do
begin
Result := Items[ItemIndex].Data;
if FCount = 0 then Exit; <<-- error: how can result be valid if count = 0?
Dec(Count);
if Count = 0 then
SetLength(Items, 0)
else
if (ItemIndex < Count) then
//Oops off by 1 error! ---------------------------------------VVVVV
Move(Items[ItemIndex + 1], Items[ItemIndex], (Count - ItemIndex - 1) * SizeOf(TPointerBucketItem));
end;
Dec(FCount); <<-- The use of with makes this statement confusing.
end;
The code should be changed as follows:
function TPointerMap.Delete(BucketIndex, ItemIndex: Integer): PData;
var
Bucket: TPointerBucket ;
begin
if FCount = 0 then Exit(nil);
//Perhaps add some code to validate BucketIndex & ItemIndex?
Assert(BucketIndex < Length(FBuckets));
Bucket:= FBuckets[BucketIndex];
if ItemIndex >= Bucket.
Assert(ItemIndex < Length(Bucket.Items));
Result := Bucket.Items[ItemIndex].Data;
Dec(Bucket.Count);
if Bucket.Count = 0 then
SetLength(Bucket.Items, 0)
else
/// assume array like so: 0 1 2 3 4 , itemindex = 0
/// result should be 1 2 3 4
/// move(1,0,4) (because 4 items should be moved.
/// Thus move (itemindex+1, intemindex, count-itemindex)
if (ItemIndex < Bucket.Count) then
Move(Items[ItemIndex + 1], Items[ItemIndex], (Bucket.Count - ItemIndex) * SizeOf(TPointerBucketItem));
end;
Dec(FCount);
end;