Changeset 521 for GraphicTest/Packages/bgrabitmap/bgragtkbitmap.pas

Timestamp:

Apr 17, 2019, 12:58:41 AM (5 years ago)

Author:

chronos

Message:

• Modified: Propagate project build mode options to used packages.
• Added: Check memory leaks using heaptrc.
• Modified: Update BGRABitmap package.

Location:

GraphicTest

Files:

• . (modified) (1 prop)
• Packages/bgrabitmap/bgragtkbitmap.pas (modified) (8 diffs)

GraphicTest

@@ -8 +8 @@
 GraphicTest.lps
 GraphicTest.dbg
+heaptrclog.trc

@@ -8 +8 @@
 GraphicTest.lps
 GraphicTest.dbg
+heaptrclog.trc

GraphicTest/Packages/bgrabitmap/bgragtkbitmap.pas

@@ -38 +38 @@
     FPixBuf: Pointer;
     procedure DrawTransparent(ACanvas: TCanvas; Rect: TRect);
-    procedure DrawOpaque(ACanvas: TCanvas; Rect: TRect);
+    procedure DrawOpaque(ACanvas: TCanvas; ARect: TRect; ASourceRect: TRect);
+    procedure DrawOpaque(ACanvas: TCanvas; ARect: TRect);
   protected
     procedure ReallocData; override;
@@ -46 +47 @@
       AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer);
       override;
+    procedure DrawPart(ARect: TRect; ACanvas: TCanvas; x, y: integer; Opaque: boolean); override;
     procedure Draw(ACanvas: TCanvas; x, y: integer; Opaque: boolean = True); override;
     procedure Draw(ACanvas: TCanvas; Rect: TRect; Opaque: boolean = True); override;
-    procedure DataDrawOpaque(ACanvas: TCanvas; Rect: TRect; AData: Pointer;
-      ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); override;
+    procedure DataDrawOpaque(ACanvas: TCanvas; ARect: TRect; AData: Pointer;
+      ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer); overload; override;
+    procedure DataDrawOpaque(ACanvas: TCanvas; ARect: TRect; ADataFirstRow: Pointer;
+      ARowStride: integer; AWidth, AHeight: integer); overload;
     procedure GetImageFromCanvas(CanvasSource: TCanvas; x, y: integer); override;
   end;
@@ -55 +59 @@
 implementation
 
-uses BGRABitmapTypes, BGRADefaultBitmap, LCLType,
+uses BGRABitmapTypes, BGRADefaultBitmap, BGRAFilterScanner, LCLType,
   LCLIntf, IntfGraphics,
   {$IFDEF LCLgtk2}
@@ -64 +68 @@
   {$ENDIF}
   FPImage, Dialogs;
-
-{$IFDEF LCLgtk2}
-type TGtkDeviceContext = TGtk2DeviceContext;
-{$ENDIF}
 
 procedure TBGRAGtkBitmap.ReallocData;
@@ -116 +116 @@
   end;
 
+  LoadFromBitmapIfNeeded;
+
   If not TBGRAPixel_RGBAOrder then SwapRedBlue;
   
@@ -130 +132 @@
 end;
 
-procedure TBGRAGtkBitmap.DrawOpaque(ACanvas: TCanvas; Rect: TRect);
-begin
-  DataDrawOpaque(ACanvas,Rect,Data,LineOrder,Width,Height);
+procedure TBGRAGtkBitmap.DrawOpaque(ACanvas: TCanvas; ARect: TRect;
+  ASourceRect: TRect);
+begin
+  DataDrawOpaque(ACanvas,ARect,Data,LineOrder,Width,Height);
+end;
+
+procedure TBGRAGtkBitmap.DrawOpaque(ACanvas: TCanvas; ARect: TRect);
+begin
+  DrawOpaque(ACanvas, ARect, rect(0,0,Width,Height));
 end;
 
@@ -166 +174 @@
 end;
 
+procedure TBGRAGtkBitmap.DrawPart(ARect: TRect; ACanvas: TCanvas; x,
+  y: integer; Opaque: boolean);
+var
+  rowStride,w,h: Integer;
+begin
+  if Opaque then
+  begin
+    if LineOrder = riloTopToBottom then
+      rowStride := Width*sizeof(TBGRAPixel)
+    else
+      rowStride := -Width*sizeof(TBGRAPixel);
+    w:= ARect.Right-ARect.Left;
+    h:= ARect.Bottom-ARect.Top;
+    DataDrawOpaque(ACanvas, rect(x,y,x+w,y+h), Scanline[ARect.Top]+ARect.Left, rowStride, w,h);
+  end
+  else
+    inherited DrawPart(ARect, ACanvas, x, y, Opaque);
+end;
+
 procedure TBGRAGtkBitmap.Draw(ACanvas: TCanvas; x, y: integer; Opaque: boolean);
 begin
@@ -186 +213 @@
 end;
 
-procedure TBGRAGtkBitmap.DataDrawOpaque(ACanvas: TCanvas; Rect: TRect;
+procedure TBGRAGtkBitmap.DataDrawOpaque(ACanvas: TCanvas; ARect: TRect;
   AData: Pointer; ALineOrder: TRawImageLineOrder; AWidth, AHeight: integer);
-var ptr: TBGRAPtrBitmap;
+var
+  rowStride: Integer;
+  firstRow: Pointer;
+begin
+  if ALineOrder = riloTopToBottom then
+  begin
+    rowStride := AWidth*sizeof(TBGRAPixel);
+    firstRow := AData;
+  end
+  else
+  begin
+    rowStride := -AWidth*sizeof(TBGRAPixel);
+    firstRow := PBGRAPixel(AData) + (AWidth*(AHeight-1));
+  end;
+
+  DataDrawOpaque(ACanvas, ARect, firstRow, rowStride, AWidth, AHeight);
+end;
+
+procedure TBGRAGtkBitmap.DataDrawOpaque(ACanvas: TCanvas; ARect: TRect;
+  ADataFirstRow: Pointer; ARowStride: integer; AWidth, AHeight: integer);
+
+  procedure DataSwapRedBlue;
+  var
+    y: Integer;
+    p: PByte;
+  begin
+    p := PByte(ADataFirstRow);
+    for y := 0 to AHeight-1 do
+    begin
+      TBGRAFilterScannerSwapRedBlue.ComputeFilterAt(PBGRAPixel(p),PBGRAPixel(p),AWidth,False);
+      inc(p, ARowStride);
+    end;
+  end;
+
+  procedure DrawStretched;
+  var
+    dataStart: Pointer;
+    ptr: TBGRAPtrBitmap;
     stretched: TBGRACustomBitmap;
-    temp: integer;
-    pos: TPoint;
-    dest: HDC;
-begin
-  if (AHeight = 0) or (AWidth = 0) or (Rect.Left = Rect.Right) or
-    (Rect.Top = Rect.Bottom) then
-    exit;
-
-  if Rect.Right < Rect.Left then
-  begin
-    temp := Rect.Left;
-    Rect.Left := Rect.Right;
-    Rect.Right := temp;
-  end;
-
-  if Rect.Bottom < Rect.Top then
-  begin
-    temp := Rect.Top;
-    Rect.Top := Rect.Bottom;
-    Rect.Bottom := temp;
-  end;
-
-  if (AWidth <> Rect.Right-Rect.Left) or (AHeight <> Rect.Bottom-Rect.Top) then
-  begin
-    ptr := TBGRAPtrBitmap.Create(AWidth,AHeight,AData);
-    ptr.LineOrder := ALineOrder;
-    stretched := ptr.Resample(Rect.Right-Rect.Left,Rect.Bottom-Rect.Top);
+  begin
+    if ARowStride < 0 then
+      dataStart := PByte(ADataFirstRow) + ARowStride*(Height-1)
+    else
+      dataStart := ADataFirstRow;
+
+    if ARowStride <> abs(AWidth*sizeof(TBGRAPixel)) then
+      raise exception.Create('DataDrawOpaque not supported when using custom row stride and resample');
+
+    ptr := TBGRAPtrBitmap.Create(AWidth,AHeight,dataStart);
+    if ARowStride < 0 then
+      ptr.LineOrder := riloBottomToTop
+    else
+      ptr.LineOrder := riloTopToBottom;
+    stretched := ptr.Resample(ARect.Right-ARect.Left,ARect.Bottom-ARect.Top);
     ptr.free;
-    DataDrawOpaque(ACanvas,Rect,AData,stretched.LineOrder,stretched.Width,stretched.Height);
+    DataDrawOpaque(ACanvas,ARect,stretched.Data,stretched.LineOrder,stretched.Width,stretched.Height);
     stretched.Free;
-    exit;
-  end;
-
-  dest := ACanvas.Handle;
-  pos := rect.TopLeft;
-  LPtoDP(dest, pos, 1);
-  If ALineOrder = riloBottomToTop then VerticalFlip;
-  If not TBGRAPixel_RGBAOrder then SwapRedBlue;
-  gdk_draw_rgb_32_image(TGtkDeviceContext(dest).Drawable,
-    TGtkDeviceContext(Dest).GC, pos.x,pos.y,
-    AWidth,AHeight, GDK_RGB_DITHER_NORMAL,
-    AData, AWidth*sizeof(TBGRAPixel));
-  If not TBGRAPixel_RGBAOrder then SwapRedBlue;
-  If ALineOrder = riloBottomToTop then VerticalFlip;
+  end;
+
+var
+  temp: integer;
+  pos: TPoint;
+  dest: HDC;
+
+begin
+  if (AHeight = 0) or (AWidth = 0) or (ARect.Left = ARect.Right) or
+    (ARect.Top = ARect.Bottom) then exit;
+
+  if ARect.Right < ARect.Left then
+  begin
+    temp := ARect.Left;
+    ARect.Left := ARect.Right;
+    ARect.Right := temp;
+  end;
+
+  if ARect.Bottom < ARect.Top then
+  begin
+    temp := ARect.Top;
+    ARect.Top := ARect.Bottom;
+    ARect.Bottom := temp;
+  end;
+
+  if (AWidth <> ARect.Right-ARect.Left) or (AHeight <> ARect.Bottom-ARect.Top) then
+    DrawStretched
+  else
+  begin
+    dest := ACanvas.Handle;
+    pos := ARect.TopLeft;
+    LPtoDP(dest, pos, 1);
+    if not TBGRAPixel_RGBAOrder then DataSwapRedBlue;
+    gdk_draw_rgb_32_image(TGtkDeviceContext(dest).Drawable,
+      TGtkDeviceContext(Dest).GC, pos.x,pos.y,
+      AWidth,AHeight, GDK_RGB_DITHER_NORMAL,
+      ADataFirstRow, ARowStride);
+    if not TBGRAPixel_RGBAOrder then DataSwapRedBlue;
+    ACanvas.Changed;
+  end;
 end;
 

@@ -8 +8 @@
 GraphicTest.lps
 GraphicTest.dbg
+heaptrclog.trc