paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-11 20:26:00 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Merging revisions r43479 from trunk:

Browse Source 
------------------------------------------------------------------------
    r43479 | michael | 2019-11-15 16:17:52 +0100 (Fri, 15 Nov 2019) | 1 line
    
    * Fix bug #35128, correctly apply clipping rect
    ------------------------------------------------------------------------

git-svn-id: branches/fixes_3_2@43716 -
This commit is contained in:
michael 2019-12-23 13:23:16 +00:00
parent 7fff8e538e
commit 8e7c1a2d6f
2 changed files with 15 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
packages/fcl-image/src/clipping.pp
View File

@ -23,8 +23,8 @@ procedure SortRect (var rect : TRect);
procedure SortRect (var left,top, right,bottom : integer); procedure SortRect (var left,top, right,bottom : integer);
function PointInside (const x,y:integer; bounds:TRect) : boolean; function PointInside (const x,y:integer; bounds:TRect) : boolean;
procedure CheckRectClipping (ClipRect:TRect; var Rect:Trect); Function CheckRectClipping (ClipRect:TRect; var Rect:Trect) : Boolean;
procedure CheckRectClipping (ClipRect:TRect; var x1,y1, x2,y2 : integer); Function CheckRectClipping (ClipRect:TRect; var x1,y1, x2,y2 : integer) : Boolean;
procedure CheckLineClipping (ClipRect:TRect; var x1,y1, x2,y2 : integer); procedure CheckLineClipping (ClipRect:TRect; var x1,y1, x2,y2 : integer);
implementation implementation
@ -60,13 +60,14 @@ begin
(y >= bottom) and (y <= top); (y >= bottom) and (y <= top);
end; end;
procedure CheckRectClipping (ClipRect:TRect; var Rect:Trect); Function CheckRectClipping (ClipRect:TRect; var Rect:Trect) : Boolean;
begin begin
with ClipRect do with ClipRect do
CheckRectClipping (ClipRect, left,top,right,bottom); Result:=CheckRectClipping (ClipRect, left,top,right,bottom);
end; end;
procedure CheckRectClipping (ClipRect:TRect; var x1,y1, x2,y2 : integer); Function CheckRectClipping (ClipRect:TRect; var x1,y1, x2,y2 : integer) : boolean;
procedure ClearRect; procedure ClearRect;
begin begin
x1 := -1; x1 := -1;
@ -75,8 +76,10 @@ procedure CheckRectClipping (ClipRect:TRect; var x1,y1, x2,y2 : integer);
y2 := -1; y2 := -1;
end; end;
begin begin
Result:=true;
SortRect (ClipRect); SortRect (ClipRect);
SortRect (x1,y1, x2,y2); SortRect (x1,y1, x2,y2);
with ClipRect do with ClipRect do
begin begin
if ( x1 < Left ) then // left side needs to be clipped if ( x1 < Left ) then // left side needs to be clipped
@ -88,7 +91,10 @@ begin
if ( y2 > bottom ) then // bottom side needs to be clipped if ( y2 > bottom ) then // bottom side needs to be clipped
y2 := bottom; y2 := bottom;
if (x1 > x2) or (y1 > y2) then if (x1 > x2) or (y1 > y2) then
begin
ClearRect; ClearRect;
Result:=False;
end;
end; end;
end; end;

5
packages/fcl-image/src/fpcanvas.inc
View File

@ -781,15 +781,18 @@ procedure TFPCustomCanvas.Draw (x,y:integer; image:TFPCustomImage);
var xx,xi,yi,xm,ym,r,t : integer; var xx,xi,yi,xm,ym,r,t : integer;
begin begin
xm := x + image.width-1; xm := x + image.width-1;
if (xm<0) or (x>width) then exit;
if xm >= width then if xm >= width then
xm := width - 1; xm := width - 1;
ym := y + image.height-1; ym := y + image.height-1;
if (ym<0) or (y>width) then exit;
if ym >= height then if ym >= height then
ym := height - 1; ym := height - 1;
xi := x; xi := x;
yi := y; yi := y;
if clipping then if clipping then
CheckRectClipping (ClipRect, xi,yi, xm,ym); if not CheckRectClipping (ClipRect, xi,yi, xm,ym) then
exit;
for r := xi to xm do for r := xi to xm do
begin begin
xx := r - x; xx := r - x;