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

* Fix bug #35128, correctly apply clipping rect

Browse Source 
git-svn-id: trunk@43479 -
This commit is contained in:
michael 2019-11-15 15:17:52 +00:00
parent a09e40945c
commit 42c97b0760
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);
function PointInside (const x,y:integer; bounds:TRect) : boolean;
procedure CheckRectClipping (ClipRect:TRect; var Rect:Trect);
procedure CheckRectClipping (ClipRect:TRect; var x1,y1, x2,y2 : integer);
Function CheckRectClipping (ClipRect:TRect; var Rect:Trect) : Boolean;
Function CheckRectClipping (ClipRect:TRect; var x1,y1, x2,y2 : integer) : Boolean;
procedure CheckLineClipping (ClipRect:TRect; var x1,y1, x2,y2 : integer);
implementation
@ -60,13 +60,14 @@ begin
(y >= bottom) and (y <= top);
end;
procedure CheckRectClipping (ClipRect:TRect; var Rect:Trect);
Function CheckRectClipping (ClipRect:TRect; var Rect:Trect) : Boolean;
begin
with ClipRect do
CheckRectClipping (ClipRect, left,top,right,bottom);
Result:=CheckRectClipping (ClipRect, left,top,right,bottom);
end;
procedure CheckRectClipping (ClipRect:TRect; var x1,y1, x2,y2 : integer);
Function CheckRectClipping (ClipRect:TRect; var x1,y1, x2,y2 : integer) : boolean;
procedure ClearRect;
begin
x1 := -1;
@ -75,8 +76,10 @@ procedure CheckRectClipping (ClipRect:TRect; var x1,y1, x2,y2 : integer);
y2 := -1;
end;
begin
Result:=true;
SortRect (ClipRect);
SortRect (x1,y1, x2,y2);
with ClipRect do
begin
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
y2 := bottom;
if (x1 > x2) or (y1 > y2) then
begin
ClearRect;
Result:=False;
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;
begin
xm := x + image.width-1;
if (xm<0) or (x>width) then exit;
if xm >= width then
xm := width - 1;
ym := y + image.height-1;
if (ym<0) or (y>width) then exit;
if ym >= height then
ym := height - 1;
xi := x;
yi := y;
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
begin
xx := r - x;