diff --git a/fcl/image/fpbrush.inc b/fcl/image/fpbrush.inc index 8f5187011a..f8aaaf41a0 100644 --- a/fcl/image/fpbrush.inc +++ b/fcl/image/fpbrush.inc @@ -32,7 +32,7 @@ begin self.Style := Style; self.Image := Image; end; - inherited; + inherited DoCopyProps(From); end; function TFPCustomBrush.CopyBrush : TFPCustomBrush; diff --git a/fcl/image/fpcanvas.inc b/fcl/image/fpcanvas.inc index a7a9d35aa4..a9b3cdc3b9 100644 --- a/fcl/image/fpcanvas.inc +++ b/fcl/image/fpcanvas.inc @@ -1,3 +1,4 @@ +{%MainUnit fpcanvas.pp} { $Id$ This file is part of the Free Pascal run time library. @@ -30,17 +31,19 @@ end; destructor TFPCustomCanvas.Destroy; begin FRemovingHelpers := True; + // first remove all helper references + RemoveHelpers; + // then free helpers FDefaultFont.Free; FDefaultBrush.Free; FDefaultPen.Free; - RemoveHelpers; FHelpers.Free; FRemovingHelpers := False; inherited; end; procedure TFPCustomCanvas.CheckHelper (AHelper:TFPCanvasHelper); -var r : integer; +// remove references to AHelper begin if AHelper = FPen then FPen := nil @@ -57,9 +60,7 @@ begin else if AHelper = FDefaultBrush then FDefaultBrush := CreateDefaultBrush; end; - r := FHelpers.IndexOf (AHelper); - if (r >= 0) then - FHelpers.delete (r); + FHelpers.Remove (AHelper); end; procedure TFPCustomCanvas.RemoveHelpers; @@ -120,6 +121,11 @@ begin end; end; +function TFPCustomCanvas.GetClipRect: TRect; +begin + Result:=FClipRect; +end; + function TFPCustomCanvas.CreateFont : TFPCustomFont; begin result := DoCreateDefaultFont; @@ -147,9 +153,14 @@ procedure TFPCustomCanvas.SetFont (AValue:TFPCustomFont); begin if (AValue <> FFont) and AllowFont(AValue) then begin - AValue.AllocateResources (self); - FFont := AValue; - AddHelper (AValue); + if FManageResources then + FFont.Assign(AValue) + else + begin + AValue.AllocateResources (self); + FFont := AValue; + AddHelper (AValue); + end; end; end; @@ -178,9 +189,14 @@ procedure TFPCustomCanvas.SetBrush (AValue:TFPCustomBrush); begin if (AValue <> FBrush) and AllowBrush(AValue) then begin - AValue.AllocateResources (self); - FBrush := AValue; - AddHelper (AValue); + if FManageResources then + FBrush.Assign(AValue) + else + begin + AValue.AllocateResources (self); + FBrush := AValue; + AddHelper (AValue); + end; end; end; @@ -209,9 +225,14 @@ procedure TFPCustomCanvas.SetPen (AValue:TFPCustomPen); begin if (AValue <> FPen) and AllowPen (AValue) then begin - AValue.AllocateResources (self); - FPen := AValue; - AddHelper (AValue); + if FManageResources then + FPen.Assign(AValue) + else + begin + AValue.AllocateResources (self); + FPen := AValue; + AddHelper (AValue); + end; end; end; @@ -223,6 +244,16 @@ begin result := FDefaultPen; end; +procedure TFPCustomCanvas.SetClipRect(const AValue: TRect); +begin + FClipRect:=AValue; +end; + +procedure TFPCustomCanvas.SetPenPos(const AValue: TPoint); +begin + FPenPos:=AValue; +end; + function TFPCustomCanvas.DoAllowPen (APen : TFPCustomPen) : boolean; begin result := false; @@ -255,6 +286,11 @@ begin raise TFPCanvasException.Create (ErrNoLock); end; +function TFPCustomCanvas.Locked: boolean; +begin + Result:=FLocks>0; +end; + procedure TFPCustomCanvas.TextOut (x,y:integer;text:string); begin if Font is TFPCustomDrawFont then @@ -293,19 +329,19 @@ end; procedure TFPCustomCanvas.DoLineTo (x,y:integer); begin - DoLine (FCurrent.X,FCurrent.y, x,y); + DoLine (FPenPos.X,FPenPos.y, x,y); end; procedure TFPCustomCanvas.MoveTo (x,y:integer); begin - FCurrent.x := x; - FCurrent.y := y; + FPenPos.x := x; + FPenPos.y := y; DoMoveTo (x,y); end; procedure TFPCustomCanvas.MoveTo (p:TPoint); begin - FCurrent := p; + FPenPos := p; DoMoveTo (p.x,p.y); end; @@ -313,11 +349,11 @@ procedure TFPCustomCanvas.LineTo (x,y:integer); begin if Pen.Style <> psClear then if Pen is TFPCustomDrawPen then - TFPCustomDrawPen(Pen).DrawLine (FCurrent.x, FCurrent.y, x, y) + TFPCustomDrawPen(Pen).DrawLine (FPenPos.x, FPenPos.y, x, y) else DoLineTo (x,y); - FCurrent.x := x; - FCurrent.y := y; + FPenPos.x := x; + FPenPos.y := y; end; procedure TFPCustomCanvas.LineTo (p:TPoint); @@ -332,11 +368,11 @@ begin TFPCustomDrawPen(Pen).DrawLine (x1,y1, x2,y2) else DoLine (x1,y1, x2,y2); - FCurrent.x := x2; - FCurrent.y := y2; + FPenPos.x := x2; + FPenPos.y := y2; end; -procedure TFPCustomCanvas.Line (p1,p2:TPoint); +procedure TFPCustomCanvas.Line (const p1,p2:TPoint); begin Line (p1.x,p1.y,p2.x,p2.y); end; @@ -354,7 +390,7 @@ begin TFPCustomDrawPen(Pen).Polyline (points,false) else DoPolyline (points); - FCurrent := points[high(points)]; + FPenPos := points[high(points)]; end; procedure TFPCustomCanvas.Clear; @@ -538,7 +574,8 @@ begin end; end; -procedure TFPCustomCanvas.CopyRect (x,y:integer; canvas:TFPCustomCanvas; SourceRect:TRect); +procedure TFPCustomCanvas.CopyRect (x,y:integer; canvas:TFPCustomCanvas; + SourceRect:TRect); var xx,r,t : integer; begin SortRect (SourceRect); diff --git a/fcl/image/fpcanvas.pp b/fcl/image/fpcanvas.pp index ea1323c0f6..964cabed8d 100644 --- a/fcl/image/fpcanvas.pp +++ b/fcl/image/fpcanvas.pp @@ -32,8 +32,11 @@ type TFPCustomCanvas = class; + { TFPCanvasHelper } + TFPCanvasHelper = class(TPersistent) private + FDelayAllocate: boolean; FFPColor : TFPColor; FAllocated, FFixedCanvas : boolean; @@ -41,10 +44,10 @@ type FFlags : word; FOnChange: TNotifyEvent; FOnChanging: TNotifyEvent; - function GetAllocated : boolean; procedure NotifyCanvas; protected // flags 0-15 are reserved for FPCustomCanvas + function GetAllocated: boolean; virtual; procedure SetFlags (index:integer; AValue:boolean); virtual; function GetFlags (index:integer) : boolean; virtual; procedure CheckAllocated (ValueNeeded:boolean); @@ -52,17 +55,18 @@ type procedure DoAllocateResources; virtual; procedure DoDeAllocateResources; virtual; procedure DoCopyProps (From:TFPCanvasHelper); virtual; - procedure SetFPColor (AValue:TFPColor); virtual; + procedure SetFPColor (const AValue:TFPColor); virtual; procedure Changing; dynamic; procedure Changed; dynamic; Procedure Lock; Procedure UnLock; public constructor Create; virtual; - destructor destroy; override; + destructor Destroy; override; // prepare helper for use - procedure AllocateResources (ACanvas : TFPCustomCanvas); - // free all resource used bby this helper + procedure AllocateResources (ACanvas : TFPCustomCanvas; + CanDelay: boolean = true); + // free all resource used by this helper procedure DeallocateResources; property Allocated : boolean read GetAllocated; // properties cannot be changed when allocated @@ -73,6 +77,7 @@ type property FPColor : TFPColor read FFPColor Write SetFPColor; property OnChanging: TNotifyEvent read FOnChanging write FOnChanging; property OnChange: TNotifyEvent read FOnChange write FOnChange; + property DelayAllocate: boolean read FDelayAllocate write FDelayAllocate; end; TFPCustomFont = class (TFPCanvasHelper) @@ -149,9 +154,12 @@ type end; TFPCustomBrushClass = class of TFPCustomBrush; - TFPCustomCanvas = class + { TFPCustomCanvas } + + TFPCustomCanvas = class(TPersistent) private FClipping, + FManageResources: boolean; FRemovingHelpers : boolean; FDefaultFont, FFont : TFPCustomFont; @@ -159,7 +167,7 @@ type FBrush : TFPCustomBrush; FDefaultPen, FPen : TFPCustomPen; - FCurrent : TPoint; + FPenPos : TPoint; FClipRect : TRect; FHelpers : TList; FLocks : integer; @@ -183,12 +191,15 @@ type function DoAllowFont (AFont : TFPCustomFont) : boolean; virtual; function DoAllowPen (APen : TFPCustomPen) : boolean; virtual; function DoAllowBrush (ABrush : TFPCustomBrush) : boolean; virtual; - procedure SetColor (x,y:integer; Value:TFPColor); Virtual; abstract; + procedure SetColor (x,y:integer; const Value:TFPColor); Virtual; abstract; function GetColor (x,y:integer) : TFPColor; Virtual; abstract; procedure SetHeight (AValue : integer); virtual; abstract; function GetHeight : integer; virtual; abstract; procedure SetWidth (AValue : integer); virtual; abstract; function GetWidth : integer; virtual; abstract; + function GetClipRect: TRect; virtual; + procedure SetClipRect(const AValue: TRect); virtual; + procedure SetPenPos(const AValue: TPoint); virtual; procedure DoLockCanvas; virtual; procedure DoUnlockCanvas; virtual; procedure DoTextOut (x,y:integer;text:string); virtual; abstract; @@ -218,6 +229,7 @@ type destructor destroy; override; procedure LockCanvas; procedure UnlockCanvas; + function Locked: boolean; function CreateFont : TFPCustomFont; function CreatePen : TFPCustomPen; function CreateBrush : TFPCustomBrush; @@ -243,7 +255,7 @@ type procedure LineTo (x,y:integer); procedure LineTo (p:TPoint); procedure Line (x1,y1,x2,y2:integer); - procedure Line (p1,p2:TPoint); + procedure Line (const p1,p2:TPoint); procedure Line (const points:TRect); // other procedures procedure CopyRect (x,y:integer; canvas:TFPCustomCanvas; SourceRect:TRect); @@ -254,11 +266,12 @@ type property Pen : TFPCustomPen read GetPen write SetPen; property Brush : TFPCustomBrush read GetBrush write SetBrush; property Colors [x,y:integer] : TFPColor read GetColor write SetColor; - property ClipRect : TRect read FClipRect write FClipRect; + property ClipRect : TRect read GetClipRect write SetClipRect; property Clipping : boolean read FClipping write FClipping; - property PenPos : TPoint read FCurrent write FCurrent; + property PenPos : TPoint read FPenPos write SetPenPos; property Height : integer read GetHeight write SetHeight; property Width : integer read GetWidth write SetWidth; + property ManageResources: boolean read FManageResources write FManageResources; end; TFPCustomDrawFont = class (TFPCustomFont) @@ -280,12 +293,12 @@ type TFPCustomDrawPen = class (TFPCustomPen) private procedure DrawLine (x1,y1,x2,y2:integer); - procedure Polyline (points:array of TPoint; close:boolean); + procedure Polyline (const points:array of TPoint; close:boolean); procedure Ellipse (left,top, right,bottom:integer); procedure Rectangle (left,top, right,bottom:integer); protected procedure DoDrawLine (x1,y1,x2,y2:integer); virtual; abstract; - procedure DoPolyline (points:array of TPoint; close:boolean); virtual; abstract; + procedure DoPolyline (const points:array of TPoint; close:boolean); virtual; abstract; procedure DoEllipse (left,top, right,bottom:integer); virtual; abstract; procedure DoRectangle (left,top, right,bottom:integer); virtual; abstract; end; @@ -298,12 +311,12 @@ type procedure Rectangle (left,top, right,bottom:integer); procedure FloodFill (x,y:integer); procedure Ellipse (left,top, right,bottom:integer); - procedure Polygon (points:array of TPoint); + procedure Polygon (const points:array of TPoint); public procedure DoRectangle (left,top, right,bottom:integer); virtual; abstract; procedure DoEllipse (left,top, right,bottom:integer); virtual; abstract; procedure DoFloodFill (x,y:integer); virtual; abstract; - procedure DoPolygon (points:array of TPoint); virtual; abstract; + procedure DoPolygon (const points:array of TPoint); virtual; abstract; end; TFPEmptyBrush = class (TFPCustomBrush) diff --git a/fcl/image/fpcdrawh.inc b/fcl/image/fpcdrawh.inc index 4ccc7bb2d5..cd8f1b632f 100644 --- a/fcl/image/fpcdrawh.inc +++ b/fcl/image/fpcdrawh.inc @@ -20,7 +20,7 @@ begin DoDrawLine (x1,y1,x2,y2); end; -procedure TFPCustomDrawPen.Polyline (points:array of TPoint; close:boolean); +procedure TFPCustomDrawPen.Polyline (const points:array of TPoint; close:boolean); begin DoPolyLine (points, false); end; @@ -52,7 +52,7 @@ begin DoEllipse (left,top,right,bottom); end; -procedure TFPCustomDrawBrush.Polygon (points:array of TPoint); +procedure TFPCustomDrawBrush.Polygon (const points:array of TPoint); begin DoPolygon (points); end; diff --git a/fcl/image/fphelper.inc b/fcl/image/fphelper.inc index 6ba6de050f..52f0be348a 100644 --- a/fcl/image/fphelper.inc +++ b/fcl/image/fphelper.inc @@ -1,3 +1,4 @@ +{%MainUnit fpcanvas.pp} { $Id$ This file is part of the Free Pascal run time library. @@ -36,17 +37,26 @@ begin end; procedure TFPCanvasHelper.NotifyCanvas; +// called to unbind from canvas begin - FCanvas.CheckHelper (self); + if FCanvas<>nil then + FCanvas.CheckHelper (self); end; procedure TFPCanvasHelper.CheckAllocated (ValueNeeded:boolean); + + procedure RaiseErrAllocation; + begin + Raise TFPFontException.CreateFmt (ErrAllocation, + [EFont, ErrAlloc[ValueNeeded]]); + end; + begin if (Allocated <> ValueNeeded) then - Raise TFPFontException.CreateFmt (ErrAllocation, [EFont, ErrAlloc[ValueNeeded]]); + RaiseErrAllocation; end; -procedure TFPCanvasHelper.SetFPColor (AValue:TFPColor); +procedure TFPCanvasHelper.SetFPColor(const AValue:TFPColor); begin FFPColor := AValue; end; @@ -92,12 +102,14 @@ begin result := FAllocated; end; -procedure TFPCanvasHelper.AllocateResources (ACanvas : TFPCustomCanvas); +procedure TFPCanvasHelper.AllocateResources (ACanvas : TFPCustomCanvas; + CanDelay: boolean); begin if FFixedCanvas and FAllocated then DeallocateResources; + FCanvas := ACanvas; + if DelayAllocate and CanDelay then exit; try - FCanvas := ACanvas; DoAllocateResources; FAllocated := True; except @@ -120,7 +132,6 @@ end; procedure TFPCanvasHelper.DoCopyProps (From:TFPCanvasHelper); begin - FCanvas := nil; FPColor := from.FPColor; end; diff --git a/fcl/image/fpimgcanv.pp b/fcl/image/fpimgcanv.pp index 1bfd7517d7..bb575de1d2 100644 --- a/fcl/image/fpimgcanv.pp +++ b/fcl/image/fpimgcanv.pp @@ -25,7 +25,7 @@ type private FImage : TFPCustomImage; protected - procedure SetColor (x,y:integer; AValue:TFPColor); override; + procedure SetColor (x,y:integer; const AValue:TFPColor); override; function GetColor (x,y:integer) : TFPColor; override; procedure SetHeight (AValue : integer); override; function GetHeight : integer; override; @@ -52,7 +52,7 @@ begin inherited destroy; end; -procedure TFPImageCanvas.SetColor (x,y:integer; AValue:TFPColor); +procedure TFPImageCanvas.SetColor (x,y:integer; const AValue:TFPColor); begin if (x >= 0) and (x < width) and (y >= 0) and (y < height) then if not clipping or PointInside (x,y, ClipRect) then