paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-10 04:48:36 +02:00
Code Issues Packages Projects Releases Wiki Activity

gtk intf: made creation/freeing of GDI objects more consistent and more strict. gtk2 intf: brush and pen are now created on demand

Browse Source 
git-svn-id: trunk@11128 -
This commit is contained in:
mattias 2007-05-11 16:52:05 +00:00
parent 52d30339d8
commit 9fdf9fcfdf
18 changed files with 737 additions and 327 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
designer/designerprocs.pas
View File

@ -400,9 +400,9 @@ end;
procedure TDesignerDeviceContext.Restore;
begin
if FSavedDC<>0 then begin
FCanvas.Handle:=0;
RestoreDC(DC,FSavedDC);
FSavedDC:=0;
FCanvas.Handle:=0;
end;
end;

13
lcl/dynhasharray.pp
View File

@ -56,6 +56,7 @@ type
THashFunction = function(Sender: TDynHashArray; Item: Pointer): integer;
TOwnerHashFunction = function(Item: Pointer): integer of object;
TOnGetKeyForHashItem = function(Item: pointer): pointer;
TOnEachHashItem = function(Sender: TDynHashArray; Item: Pointer): boolean;
PDynHashArrayItem = ^TDynHashArrayItem;
TDynHashArrayItem = record
@ -118,6 +119,7 @@ type
procedure Delete(ADynHashArrayItem: PDynHashArrayItem);
procedure AssignTo(List: TList);
procedure AssignTo(List: TFPList);
procedure ForEach(const Func: TOnEachHashItem);
function SlowAlternativeHashMethod(Sender: TDynHashArray;
Item: Pointer): integer;
@ -583,6 +585,17 @@ begin
end;
end;
procedure TDynHashArray.ForEach(const Func: TOnEachHashItem);
var
HashItem: PDynHashArrayItem;
begin
HashItem:=FFirstItem;
while HashItem<>nil do begin
if not Func(Self,HashItem^.Item) then break;
HashItem:=HashItem^.Next;
end;
end;
function TDynHashArray.First: Pointer;
begin
if FFirstItem<>nil then

20
lcl/graphics.pp
View File

@ -449,8 +449,10 @@ type
TFont = class(TFPCustomFont)
private
FCanUTF8: boolean;
FCanUTF8Valid: boolean;
FHandle: HFont;
FIsMonoSpace: boolean;
FIsMonoSpaceValid: boolean;
FPitch: TFontPitch;
FStyle: TFontStylesBase;
FCharSet: TFontCharSet;
@ -461,7 +463,9 @@ type
FColor: TColor;
FHeight: integer; // FHeight = -(FSize * FPixelsPerInch) div 72
procedure FreeHandle;
function GetCanUTF8: boolean;
procedure GetData(var FontData: TFontData);
function GetIsMonoSpace: boolean;
function IsNameStored: boolean;
procedure SetData(const FontData: TFontData);
protected
@ -497,16 +501,10 @@ type
procedure EndUpdate;
function HandleAllocated: boolean;
function IsDefault: boolean;
// Extra properties
// TODO: implement them through GetTextMetrics, not here
//Function GetWidth(Value: String): Integer;
//property Width: Integer read FWidth write FWidth;
//property XBias: Integer read FXBias write FXBias;
//property YBias: Integer read FYBias write FYBias;
property Handle: HFONT read GetHandle write SetHandle;
property PixelsPerInch: Integer read FPixelsPerInch write FPixelsPerInch;
property CanUTF8: boolean read FCanUTF8;
property IsMonoSpace: boolean read FIsMonoSpace;
property CanUTF8: boolean read GetCanUTF8;
property IsMonoSpace: boolean read GetIsMonoSpace;
published
property CharSet: TFontCharSet read GetCharSet write SetCharSet default DEFAULT_CHARSET;
property Color: TColor read FColor write SetColor default clWindowText;
@ -873,6 +871,7 @@ type
FPen: TPen;
FFont: TFont;
FBrush: TBrush;
FSavedHandleStates: TFPList;
procedure BrushChanged(ABrush: TObject);
procedure FontChanged(AFont: TObject);
procedure PenChanged(APen: TObject);
@ -930,6 +929,9 @@ type
Procedure CreateRegion; virtual;
procedure DeselectHandles; virtual;
procedure PenChanging(APen: TObject); virtual;
procedure FontChanging(APen: TObject); virtual;
procedure BrushChanging(APen: TObject); virtual;
procedure RegionChanging(APen: TObject); virtual;
procedure RealizeAutoRedraw; virtual;
procedure RequiredState(ReqState: TCanvasState); virtual;
procedure SetHandle(NewHandle: HDC); virtual;
@ -944,6 +946,8 @@ type
procedure Refresh; virtual;
procedure Changing; virtual;
procedure Changed; virtual;
procedure SaveHandleState; virtual;
procedure RestoreHandleState; virtual;
// extra drawing methods (there are more in the ancestor TFPCustomCanvas)
procedure Arc(ALeft, ATop, ARight, ABottom, angle1, angle2: Integer); virtual;

12
lcl/grids.pas
View File

@ -47,8 +47,8 @@ interface
uses
Types, Classes, SysUtils, Math, LCLStrConsts, LCLProc, LCLType, LCLIntf,
Controls, GraphType, Graphics, Forms, DynamicArray, LMessages, XMLCfg,
StdCtrls, LResources, MaskEdit, Buttons, Clipbrd;
FPCanvas, Controls, GraphType, Graphics, Forms, DynamicArray, LMessages,
XMLCfg, StdCtrls, LResources, MaskEdit, Buttons, Clipbrd;
const
//GRIDFILEVERSION = 1; // Original
@ -6779,22 +6779,24 @@ end;
procedure TCustomDrawGrid.DrawFocusRect(aCol, aRow: Integer; ARect: TRect);
var
DCIndex: Integer;
FOldFocusColor: TColor;
OldPenMode: TFPPenMode;
begin
// Draw focused cell if we have the focus
if Self.Focused or (EditorAlwaysShown and ((Feditor=nil) or not Feditor.Focused)) then
begin
CalcFocusRect(aRect);
if FUseXORFeatures then begin
DCIndex := SaveDC(Canvas.Handle);
Canvas.SaveHandleState;
FOldFocusColor := FFocusColor;
FFocusColor:= clWhite;
OldPenMode:=Canvas.Pen.Mode;
Canvas.Pen.Mode := pmXOR;
end;
DrawRubberRect(Canvas, aRect, FFocusColor);
if FUseXORFeatures then begin
RestoreDC(Canvas.Handle, DCIndex);
Canvas.Pen.Mode := OldPenMode;
Canvas.RestoreHandleState;
FFocusColor := FOldFocusColor;
end;
end;

81
lcl/include/canvas.inc
View File

@ -992,9 +992,24 @@ var
Options : Longint;
fRect : TRect;
DCIndex: Integer;
procedure SaveState;
begin
if DCIndex<>0 then exit;
RequiredState([csHandleValid]);
DCIndex:=SaveDC(Handle);
end;
procedure RestoreState;
begin
if DCIndex=0 then exit;
RestoreDC(Handle,DCIndex);
end;
begin
//debugln(['TCanvas.TextRect ',DbgSName(Self),' Text="',Text,'" ',dbgs(ARect),' X=',X,',Y=',Y]);
Changing;
Options := 0;
case Style.Alignment of
taRightJustify : Options := DT_RIGHT;
@ -1016,9 +1031,12 @@ begin
If not Style.ShowPrefix then
Options := Options or DT_NOPREFIX;
DCIndex:=0;
if Style.SystemFont or Style.Clipping or (not Style.Opaque) then
SaveState;
If Style.SystemFont then begin
Options := Options or DT_INTERNAL;
RequiredState([csHandleValid]);
SelectObject(Self.Handle, GetStockObject(DEFAULT_GUI_FONT));
Exclude(FState, csFontValid);
end
@ -1047,7 +1065,6 @@ begin
end;
if Style.Clipping then begin
DCIndex := SaveDC(Self.Handle);
IntersectRect(ARect, ARect, fRect);
with ARect do
InterSectClipRect(Self.Handle, Left, Top, Right, Bottom);
@ -1072,10 +1089,7 @@ begin
SetBkMode(FHandle, OPAQUE)
end;
if Style.Clipping then begin
if DCIndex <> -1 then
RestoreDC(Self.Handle, DCIndex);
end;
RestoreState;
Changed;
end;
@ -1240,6 +1254,36 @@ begin
end;
end;
procedure TCanvas.FontChanging(APen: TObject);
begin
if [csFontValid, csHandleValid] * FState = [csFontValid, csHandleValid] then
begin
Exclude(FState, csFontValid);
SelectObject(FHandle, FSavedFontHandle);
FSavedFontHandle := 0;
end;
end;
procedure TCanvas.BrushChanging(APen: TObject);
begin
if [csBrushValid, csHandleValid] * FState = [csBrushValid, csHandleValid] then
begin
Exclude(FState, csBrushValid);
SelectObject(FHandle, FSavedBrushHandle);
FSavedBrushHandle := 0;
end;
end;
procedure TCanvas.RegionChanging(APen: TObject);
begin
if [csRegionValid, csHandleValid] * FState = [csRegionValid, csHandleValid] then
begin
Exclude(FState, csRegionValid);
SelectObject(FHandle, FSavedRegionHandle);
FSavedRegionHandle := 0;
end;
end;
{------------------------------------------------------------------------------
Method: TCanvas.PenChanged
Params: APen: The changed pen
@ -1285,14 +1329,17 @@ begin
FFont := TFont(inherited Font);
FPen := TPen(inherited Pen);
FBrush := TBrush(inherited Brush);
FFont.OnChanging := @FontChanging;
FFont.OnChange := @FontChanged;
FSavedFontHandle := 0;
FPen.OnChanging := @PenChanging;
FPen.OnChange := @PenChanged;
FSavedPenHandle := 0;
FBrush.OnChanging := @BrushChanging;
FBrush.OnChange := @BrushChanged;
FSavedBrushHandle := 0;
FRegion := TRegion.Create;
FRegion.OnChanging := @RegionChanging;
FRegion.OnChange := @RegionChanged;
FSavedRegionHandle := 0;
FCopyMode := cmSrcCopy;
@ -1358,6 +1405,7 @@ begin
//DebugLn('[TCanvas.Destroy] ',ClassName,' Self=',DbgS(Self));
Handle := 0;
FreeThenNil(FRegion);
FreeThenNil(FSavedHandleStates);
if FLock <> 0 then
DeleteCriticalSection(FLock);
inherited Destroy;
@ -1485,6 +1533,27 @@ begin
if Assigned(FOnChange) then FOnChange(Self);
end;
procedure TCanvas.SaveHandleState;
var
DCIndex: LongInt;
begin
if FSavedHandleStates=nil then FSavedHandleStates:=TFPList.Create;
DeselectHandles;
RequiredState([csHandleValid]);
DCIndex:=SaveDC(Handle);
FSavedHandleStates.Add(Pointer(PtrInt(DCIndex)));
end;
procedure TCanvas.RestoreHandleState;
var
DCIndex: LongInt;
begin
DCIndex:=integer(PtrInt(FSavedHandleStates[FSavedHandleStates.Count-1]));
FSavedHandleStates.Delete(FSavedHandleStates.Count-1);
DeselectHandles;
RestoreDC(Handle,DCIndex);
end;
procedure TCanvas.Changing;
begin
if Assigned(FOnChanging) then FOnChanging(Self);

29
lcl/include/font.inc
View File

@ -1022,18 +1022,21 @@ begin
lfPitchAndFamily := DEFAULT_PITCH;
end;
// ask the interface for the nearest font
// ask the font cache for the nearest font
CachedFont:=FontResourceCache.FindFontDesc(ALogFont,Name);
//DebugLn(['TFont.GetHandle in cache: ',CachedFont<>nil]);
if CachedFont<>nil then begin
CachedFont.Item.IncreaseRefCount;
FHandle := CachedFont.Item.Handle;
end else begin
// ask the interface for the nearest font
FHandle := CreateFontIndirectEx(ALogFont,Name);
FontResourceCache.Add(FHandle,ALogFont,Name);
end;
FFontHandleCached:=true;
FCanUTF8:=FontCanUTF8(FHandle);
FIsMonoSpace:=FontIsMonoSpace(FHandle);
FCanUTF8Valid:=false;
FIsMonoSpaceValid:=false;
if IsMonoSpace then ;
end;
Result := FHandle;
@ -1050,6 +1053,8 @@ procedure TFont.FreeHandle;
begin
if FHandle <> 0
then begin
// Changing triggers deselecting the current handle
Changing;
if FFontHandleCached then begin
FontResourceCache.FindFont(FHandle).DecreaseRefCount;
FFontHandleCached:=false;
@ -1059,6 +1064,15 @@ begin
end;
end;
function TFont.GetCanUTF8: boolean;
begin
if not FCanUTF8Valid then begin
FCanUTF8:=FontCanUTF8(Handle);
FCanUTF8Valid:=true;
end;
Result:=FCanUTF8;
end;
function TFont.GetCharSet: TFontCharSet;
begin
Result:=FCharSet;
@ -1084,6 +1098,15 @@ begin
FontData.Name:=LeftStr(Name,SizeOf(FontData.Name)-1);
end;
function TFont.GetIsMonoSpace: boolean;
begin
if not FIsMonoSpaceValid then begin
FIsMonoSpace:=FontIsMonoSpace(Handle);
FIsMonoSpaceValid:=true;
end;
Result:=FIsMonoSpace;
end;
function TFont.IsNameStored: boolean;
begin
Result:=DefFontData.Name<>Name;

211
lcl/interfaces/gtk/gtkdef.pp
View File

@ -53,6 +53,8 @@ type
TGDIType = (gdiBitmap, gdiBrush, gdiFont, gdiPen, gdiRegion, gdiPalette);
TGDIBitmapType = (gbBitmap, gbPixmap{obsolete:, gbImage});
TDeviceContext = class;
{$IFDEF Gtk1}
TGtkIntfFont = PGDKFont;
{$ELSE}
@ -86,9 +88,14 @@ type
end;
PGDIColor = ^TGDIColor;
{ Create a GDIObject with NewGDIObject. Then RefCount is 1.
Free a GDIObject with DeleteObject. This will decrease the RefCount
and when 0 calls DisposeGDIObject. }
PGDIObject = ^TGDIObject;
TGDIObject = record
RefCount: integer;
DCCount: integer; // number of DeviceContexts using this GDIObject
Owner: TDeviceContext;
{$ifdef TraceGdiCalls}
StackAddrs: TCallBacksArray;
{$endif}
@ -188,6 +195,26 @@ type
{ TDeviceContext }
TDeviceContext = class
private
FClipRegion: PGdiObject;
FCurrentBitmap: PGdiObject;
FCurrentBrush: PGdiObject;
FCurrentFont: PGdiObject;
FCurrentPalette: PGdiObject;
FCurrentPen: PGdiObject;
fOwnedGDIObjects: array[TGDIType] of PGdiObject;
function GetGDIObjects(ID: TGDIType): PGdiObject;
function GetOwnedGDIObjects(ID: TGDIType): PGdiObject;
procedure SetClipRegion(const AValue: PGdiObject);
procedure SetCurrentBitmap(const AValue: PGdiObject);
procedure SetCurrentBrush(const AValue: PGdiObject);
procedure SetCurrentFont(const AValue: PGdiObject);
procedure SetCurrentPalette(const AValue: PGdiObject);
procedure SetCurrentPen(const AValue: PGdiObject);
procedure ChangeGDIObject(var GDIObject: PGdiObject;
const NewValue: PGdiObject);
procedure SetGDIObjects(ID: TGDIType; const AValue: PGdiObject);
procedure SetOwnedGDIObjects(ID: TGDIType; const AValue: PGdiObject);
public
WithChildWindows: boolean;// this DC covers sub gdkwindows
@ -208,24 +235,29 @@ type
{$endif}
// drawing settings
CurrentBitmap: PGdiObject;
CurrentFont: PGdiObject;
CurrentPen: PGdiObject;
CurrentBrush: PGdiObject;
CurrentPalette: PGdiObject;
property CurrentBitmap: PGdiObject read FCurrentBitmap write SetCurrentBitmap;
property CurrentFont: PGdiObject read FCurrentFont write SetCurrentFont;
property CurrentPen: PGdiObject read FCurrentPen write SetCurrentPen;
property CurrentBrush: PGdiObject read FCurrentBrush write SetCurrentBrush;
property CurrentPalette: PGdiObject read FCurrentPalette write SetCurrentPalette;
property ClipRegion: PGdiObject read FClipRegion write SetClipRegion;
property GDIObjects[ID: TGDIType]: PGdiObject read GetGDIObjects write SetGDIObjects;
CurrentTextColor: TGDIColor;
CurrentBackColor: TGDIColor;
ClipRegion: hRGN;
DCTextMetric: TDevContextTextMetric; // only valid if dcfTextMetricsValid set
// control
SelectedColors: TDevContextSelectedColorsType;
SavedContext: TDeviceContext; // linked list of saved DCs
DCFlags: TDeviceContextsFlags;
property OwnedGDIObjects[ID: TGDIType]: PGdiObject read GetOwnedGDIObjects write SetOwnedGDIObjects;
procedure Clear;
function GetGC: pgdkGC;
function GetFont: PGdiObject;
function GetBrush: PGdiObject;
function GetPen: PGdiObject;
function GetBitmap: PGdiObject;
end;
@ -398,10 +430,10 @@ procedure DisposeDeviceContext(DeviceContext: TDeviceContext);
type
TCreateGCForDC = procedure(DC: TDeviceContext) of object;
TCreateFontForDC = procedure(DC: TDeviceContext) of object;
TCreateGDIObjectForDC = procedure(DC: TDeviceContext; aGDIType: TGDIType) of object;
var
CreateGCForDC: TCreateGCForDC = nil;
CreateFontForDC: TCreateFontForDC = nil;
CreateGDIObjectForDC: TCreateGDIObjectForDC = nil;
{$IFDEF DebugLCLComponents}
var
@ -412,6 +444,9 @@ var
procedure GtkDefDone;
function dbgs(g: TGDIType): string; overload;
implementation
@ -423,8 +458,8 @@ type
protected
procedure FreeFirstItem; override;
public
procedure DisposeGDIObject(AGDIObject: PGDIObject);
function NewGDIObject: PGDIObject;
procedure DisposeGDIObjectMem(AGDIObject: PGDIObject);
function NewGDIObjectMem: PGDIObject;
end;
const
@ -436,7 +471,7 @@ begin
GDIObjectMemManager:=TGDIObjectMemManager.Create;
GDIObjectMemManager.MinimumFreeCount:=1000;
end;
Result:=GDIObjectMemManager.NewGDIObject;
Result:=GDIObjectMemManager.NewGDIObjectMem;
{$IFDEF DebugLCLComponents}
DebugGdiObjects.MarkCreated(Result,'NewPGDIObject');
{$ENDIF}
@ -447,7 +482,7 @@ begin
{$IFDEF DebugLCLComponents}
DebugGdiObjects.MarkDestroyed(GDIObject);
{$ENDIF}
GDIObjectMemManager.DisposeGDIObject(GDIObject);
GDIObjectMemManager.DisposeGDIObjectMem(GDIObject);
end;
{ TGDIObjectMemManager }
@ -464,9 +499,9 @@ begin
{$IfDef RangeChecksOn}{$R+}{$Endif}
end;
procedure TGDIObjectMemManager.DisposeGDIObject(AGDIObject: PGDIObject);
procedure TGDIObjectMemManager.DisposeGDIObjectMem(AGDIObject: PGDIObject);
begin
//DebugLn('TGDIObjectMemManager.DisposeGDIObject ',DbgS(AGDIObject));
//DebugLn('TGDIObjectMemManager.DisposeGDIObjectMem ',DbgS(AGDIObject));
if AGDIObject^.RefCount<>0 then
RaiseGDBException('');
if (FFreeCount<FMinFree) or (FFreeCount<((FCount shr 3)*FMaxFreeRatio)) then
@ -478,7 +513,7 @@ begin
end else begin
// free list full -> free the ANode
Dispose(AGDIObject);
//DebugLn('TGDIObjectMemManager.DisposeGDIObject B FFreedCount=',FFreedCount);
//DebugLn('TGDIObjectMemManager.DisposeGDIObjectMem B FFreedCount=',FFreedCount);
{$R-}
inc(FFreedCount);
{$IfDef RangeChecksOn}{$R+}{$Endif}
@ -486,7 +521,7 @@ begin
dec(FCount);
end;
function TGDIObjectMemManager.NewGDIObject: PGDIObject;
function TGDIObjectMemManager.NewGDIObjectMem: PGDIObject;
begin
if FFirstFree<>nil then begin
// take from free list
@ -496,14 +531,14 @@ begin
end else begin
// free list empty -> create new node
New(Result);
// DebugLn('TGDIObjectMemManager.NewGDIObject FAllocatedCount=',FAllocatedCount);
// DebugLn('TGDIObjectMemManager.NewGDIObjectMem FAllocatedCount=',FAllocatedCount);
{$R-}
inc(FAllocatedCount);
{$IfDef RangeChecksOn}{$R+}{$Endif}
end;
FillChar(Result^, SizeOf(TGDIObject), 0);
inc(FCount);
//DebugLn('TGDIObjectMemManager.NewGDIObject ',DbgS(Result));
//DebugLn('TGDIObjectMemManager.NewGDIObjectMem ',DbgS(Result));
end;
@ -598,7 +633,103 @@ end;
{ TDeviceContext }
procedure TDeviceContext.SetClipRegion(const AValue: PGdiObject);
begin
ChangeGDIObject(fClipRegion,AValue);
end;
function TDeviceContext.GetGDIObjects(ID: TGDIType): PGdiObject;
begin
case ID of
gdiBitmap: Result:=CurrentBitmap;
gdiFont: Result:=CurrentFont;
gdiBrush: Result:=CurrentBrush;
gdiPen: Result:=CurrentPen;
gdiPalette: Result:=CurrentPalette;
gdiRegion: Result:=ClipRegion;
end;
end;
function TDeviceContext.GetOwnedGDIObjects(ID: TGDIType): PGdiObject;
begin
Result:=fOwnedGDIObjects[ID];
end;
procedure TDeviceContext.SetCurrentBitmap(const AValue: PGdiObject);
begin
ChangeGDIObject(FCurrentBitmap,AValue);
end;
procedure TDeviceContext.SetCurrentBrush(const AValue: PGdiObject);
begin
ChangeGDIObject(FCurrentBrush,AValue);
end;
procedure TDeviceContext.SetCurrentFont(const AValue: PGdiObject);
begin
ChangeGDIObject(FCurrentFont,AValue);
end;
procedure TDeviceContext.SetCurrentPalette(const AValue: PGdiObject);
begin
ChangeGDIObject(FCurrentPalette,AValue);
end;
procedure TDeviceContext.SetCurrentPen(const AValue: PGdiObject);
begin
ChangeGDIObject(FCurrentPen,AValue);
end;
procedure TDeviceContext.ChangeGDIObject(var GDIObject: PGdiObject;
const NewValue: PGdiObject);
begin
if GdiObject=NewValue then exit;
if GdiObject<>nil then begin
dec(GdiObject^.DCCount);
if GdiObject^.DCCount<0 then
RaiseGDBException('');
end;
//if GdiObject<>nil then
// DebugLn(['TDeviceContext.ChangeGDIObject DC=',dbgs(Self),' OldGDIObject=',dbgs(GdiObject),' Old.DCCount=',GdiObject^.DCCount]);
GdiObject:=NewValue;
if GdiObject<>nil then
inc(GdiObject^.DCCount);
//if GdiObject<>nil then
// DebugLn(['TDeviceContext.ChangeGDIObject DC=',dbgs(Self),' NewGDIObject=',dbgs(GdiObject),' New.DCCount=',GdiObject^.DCCount]);
end;
procedure TDeviceContext.SetGDIObjects(ID: TGDIType; const AValue: PGdiObject);
begin
case ID of
gdiBitmap: ChangeGDIObject(fCurrentBitmap,AValue);
gdiFont: ChangeGDIObject(fCurrentFont,AValue);
gdiBrush: ChangeGDIObject(fCurrentBrush,AValue);
gdiPen: ChangeGDIObject(fCurrentPen,AValue);
gdiPalette: ChangeGDIObject(fCurrentPalette,AValue);
gdiRegion: ChangeGDIObject(fClipRegion,AValue);
end;
end;
procedure TDeviceContext.SetOwnedGDIObjects(ID: TGDIType;
const AValue: PGdiObject);
begin
if fOwnedGDIObjects[ID]=AValue then exit;
if fOwnedGDIObjects[ID]<>nil then
fOwnedGDIObjects[ID]^.Owner:=nil;
fOwnedGDIObjects[ID]:=AValue;
if fOwnedGDIObjects[ID]<>nil then
fOwnedGDIObjects[ID]^.Owner:=Self;
end;
procedure TDeviceContext.Clear;
var
g: TGDIType;
procedure WarnOwnedGDIObject;
begin
DebugLn(['TDeviceContext.Clear ',dbghex(PtrInt(Self)),' OwnedGDIObjects[',ord(g),']<>nil']);
end;
begin
DCWidget:=nil;
Drawable:=nil;
@ -616,13 +747,17 @@ begin
CurrentPen:=nil;
CurrentBrush:=nil;
CurrentPalette:=nil;
ClipRegion:=nil;
FillChar(CurrentTextColor,SizeOf(CurrentTextColor),0);
FillChar(CurrentBackColor,SizeOf(CurrentBackColor),0);
ClipRegion:=0;
SelectedColors:=dcscCustom;
SavedContext:=nil;
DCFlags:=[];
for g:=Low(TGDIType) to high(TGDIType) do
if OwnedGDIObjects[g]<>nil then
WarnOwnedGDIObject;
end;
function TDeviceContext.GetGC: pgdkGC;
@ -635,10 +770,31 @@ end;
function TDeviceContext.GetFont: PGdiObject;
begin
if CurrentFont=nil then
CreateFontForDC(Self);
CreateGDIObjectForDC(Self,gdiFont);
Result:=CurrentFont;
end;
function TDeviceContext.GetBrush: PGdiObject;
begin
if CurrentBrush=nil then
CreateGDIObjectForDC(Self,gdiBrush);
Result:=CurrentBrush;
end;
function TDeviceContext.GetPen: PGdiObject;
begin
if CurrentPen=nil then
CreateGDIObjectForDC(Self,gdiPen);
Result:=CurrentPen;
end;
function TDeviceContext.GetBitmap: PGdiObject;
begin
if CurrentBitmap=nil then
CreateGDIObjectForDC(Self,gdiBitmap);
Result:=CurrentBitmap;
end;
procedure GtkDefInit;
begin
{$IFDEF DebugLCLComponents}
@ -661,6 +817,19 @@ begin
{$ENDIF}
end;
function dbgs(g: TGDIType): string;
begin
case g of
gdiBitmap: Result:='gdiBitmap';
gdiBrush: Result:='gdiBrush';
gdiFont: Result:='gdiFont';
gdiPen: Result:='gdiPen';
gdiRegion: Result:='gdiRegion';
gdiPalette: Result:='gdiPalette';
else Result:='<?? unknown gdi type '+dbgs(ord(g))+'>';
end;
end;
initialization
GtkDefInit;

14
lcl/interfaces/gtk/gtkfontcache.pas
View File

@ -82,6 +82,7 @@ type
function FindADescriptor(TheGtkFont: TGtkIntfFont): TGtkFontCacheDescriptor;
function Add(TheGtkFont: TGtkIntfFont; const LogFont: TLogFont;
const LongFontName: string): TGtkFontCacheDescriptor;
function AddWithoutName(TheGtkFont: TGtkIntfFont): TGtkFontCacheDescriptor;
procedure Reference(TheGtkFont: TGtkIntfFont);
procedure Unreference(TheGtkFont: TGtkIntfFont);
procedure DumpDescriptors;
@ -243,6 +244,8 @@ function TGtkFontCache.Add(TheGtkFont: TGtkIntfFont; const LogFont: TLogFont;
var
Item: TGtkFontCacheItem;
begin
if TheGtkFont=nil then
RaiseGDBException('TGtkFontCache.Add TheGtkFont=nil');
if FindGtkFontDesc(LogFont,LongFontName)<>nil then
RaiseGDBException('TGtkFontCache.Add font desc added twice');
@ -268,6 +271,17 @@ begin
end;
end;
function TGtkFontCache.AddWithoutName(TheGtkFont: TGtkIntfFont
): TGtkFontCacheDescriptor;
var
LogFont: TLogFont;
LongFontName: string;
begin
FillChar(LogFont,SizeOf(LogFont),0);
LongFontName:=dbghex(PtrInt(TheGtkFont));
Result:=Add(TheGtkFont,LogFont,LongFontName);
end;
procedure TGtkFontCache.Reference(TheGtkFont: TGtkIntfFont);
var
Item: TGtkFontCacheItem;

10
lcl/interfaces/gtk/gtkint.pp
View File

@ -164,12 +164,19 @@ type
// device contexts
function IsValidDC(const DC: HDC): Boolean;virtual;
function NewDC: TDeviceContext;virtual;
function FindDCWithGDIObject(GDIObject: PGdiObject): TDeviceContext;virtual;
procedure DisposeDC(aDC: TDeviceContext);virtual;
function CreateDCForWidget(TheWidget: PGtkWidget; TheWindow: PGdkWindow;
WithChildWindows: boolean): HDC;
procedure OnCreateGCForDC(DC: TDeviceContext);
procedure OnCreateGDIObjectForDC(DC: TDeviceContext; aGDIType: TGDIType);
procedure OnCreateFontForDC(DC: TDeviceContext);
procedure OnCreateBrushForDC(DC: TDeviceContext);
procedure OnCreatePenForDC(DC: TDeviceContext);
procedure OnCreateGDIBitmapForDC(DC: TDeviceContext);
function GetDoubleBufferedDC(Handle: HWND): HDC;
function IsNullBrush(DC: TDeviceContext): boolean;
function IsNullPen(DC: TDeviceContext): boolean;
// GDIObjects
function IsValidGDIObject(const GDIObject: HGDIOBJ): Boolean;virtual;
@ -183,6 +190,7 @@ type
function CreateDefaultBrush: PGdiObject;virtual;
function CreateDefaultFont: PGdiObject;virtual;
function CreateDefaultPen: PGdiObject;virtual;
function CreateDefaultGDIBitmap: PGdiObject;virtual;
procedure UpdateDCTextMetric(DC: TDeviceContext); virtual;
{$Ifdef GTK2}
function GetDefaultFontDesc(IncreaseReferenceCount: boolean): PPangoFontDescription;
@ -245,7 +253,7 @@ type
procedure ResizeChild(Sender : TObject; Left,Top,Width,Height : Integer);virtual;
procedure RemoveCallbacks(Widget: PGtkWidget); virtual;
function ROP2ModeToGdkFunction(Mode: Integer): TGdkFunction;
function gdkFunctionToROP2Mode(aFunction: TGdkFunction): Integer;
function gdkFunctionToROP2Mode(const aFunction: TGdkFunction): Integer;
// for gtk specific components:
procedure SetLabelCaption(const ALabel: PGtkLabel; const ACaption: String;

215
lcl/interfaces/gtk/gtkobject.inc
View File

@ -176,7 +176,7 @@ begin
FDeviceContexts := TDynHashArray.Create(-1);
FDeviceContexts.Options:=FDeviceContexts.Options+[dhaoCacheContains];
CreateGCForDC:=@OnCreateGCForDC;
CreateFontForDC:=@OnCreateFontForDC;
CreateGDIObjectForDC:=@OnCreateGDIObjectForDC;
FGDIObjects := TDynHashArray.Create(-1);
FGDIObjects.Options:=FGDIObjects.Options+[dhaoCacheContains];
@ -352,8 +352,6 @@ end;
destructor TGtkWidgetSet.Destroy;
const
ProcName = '[TGtkWidgetSet.Destroy]';
GDITYPENAME: array[TGDIType] of String = (
'gdiBitmap', 'gdiBrush', 'gdiFont', 'gdiPen', 'gdiRegion', 'gdiPalette');
var
n: Integer;
pTimerInfo : PGtkITimerinfo;
@ -364,7 +362,7 @@ var
NextQueueItem : TGtkMessageQueueItem;
begin
CreateGCForDC:=nil;
CreateFontForDC:=nil;
CreateGDIObjectForDC:=nil;
ReAllocMem(FExtUTF8OutCache,0);
FExtUTF8OutCacheSize:=0;
@ -390,12 +388,13 @@ begin
QueueItem := NextQueueItem;
end;
// warn about unremoved paint messages
if fMessageQueue.HasPaintMessages then begin
DebugLn(ProcName, Format(rsWarningUnremovedPaintMessages,
[IntToStr(fMessageQueue.NumberOfPaintMessages)]));
end;
{$ifndef TraceGdiCalls}
// warn about unreleased DC
if (FDeviceContexts.Count > 0)
then begin
DebugLn(ProcName, Format(rsWarningUnreleasedDCsDump,
@ -412,8 +411,8 @@ begin
end;
DebugLn();
end;
{$endif}
// warn about unreleased gdi objects
if (FGDIObjects.Count > 0)
then begin
DebugLn(ProcName,Format(rsWarningUnreleasedGDIObjectsDump,
@ -440,11 +439,11 @@ begin
end;
{$ifndef TraceGdiCalls}
DebugLn();
{$endif}
for GDIType := Low(GDIType) to High(GDIType) do
if GDITypeCount[GDIType] > 0 then
DebugLn(ProcName,Format(' %s: %d', [GDITYPENAME[GDIType], GDITypeCount[GDIType]]));
{$endif}
DebugLn(ProcName,Format(' %s: %d', [dbgs(GDIType), GDITypeCount[GDIType]]));
end;
@ -455,6 +454,7 @@ begin
fMessageQueue.RemoveMessage(fMessageQueue.FirstMessageItem,FPMF_All,true);
end;
// warn about unreleased timers
n := FTimerData.Count;
if (n > 0) then
begin
@ -469,28 +469,6 @@ begin
end;
{$ifdef TraceGdiCalls}
if (FGDIObjects.Count > 0)
then begin
//DebugLn('BackTrace for unreleased gdi objects follows:');
for GDIType := Low(TGDIType) to High(TGDIType) do begin
if GDITypeCount[GDIType]<>0 then begin
n:=0;
HashItem := FGDIObjects.FirstHashItem;
while (HashItem <> nil) and (n<MaxTraces) do begin
DebugLn(GdiTypeName[gdiType],': ', dbgs(HashItem^.Item));
DumpBackTrace(PgdiObject(HashItem^.Item)^.StackAddrs);
DebugLn();
HashItem := HashItem^.Next;
inc(n);
end;
if (n>=MaxTraces) then begin
DebugLn('... Truncated ',GDITYPENAME[GDIType],' leakage dump.');
DebugLn();
end;
end;
end;
end;
if FDeviceContexts.Count>0 then begin
//DebugLn('BackTrace for unreleased device contexts follows:');
n:=0;
@ -507,6 +485,28 @@ begin
DebugLn();
end;
end;
if (FGDIObjects.Count > 0)
then begin
//DebugLn('BackTrace for unreleased gdi objects follows:');
for GDIType := Low(TGDIType) to High(TGDIType) do begin
if GDITypeCount[GDIType]<>0 then begin
n:=0;
HashItem := FGDIObjects.FirstHashItem;
while (HashItem <> nil) and (n<MaxTraces) do begin
DebugLn(dbgs(gdiType),': ', dbgs(HashItem^.Item));
DumpBackTrace(PgdiObject(HashItem^.Item)^.StackAddrs);
DebugLn();
HashItem := HashItem^.Next;
inc(n);
end;
if (n>=MaxTraces) then begin
DebugLn('... Truncated ',dbgs(GDIType),' leakage dump.');
DebugLn();
end;
end;
end;
end;
{$endif}
FreeAndNil(FWidgetsWithResizeRequest);
@ -2120,11 +2120,11 @@ begin
gdk_drawable_get_size(GdiObject^.GDIPixmapObject,@Width, @Height);
Depth := gdk_drawable_get_depth(GdiObject^.GDIPixmapObject);
If GdiObject^.Visual <> nil then
GDK_Visual_UnRef(GdiObject^.Visual);
If GdiObject^.Visual <> nil then
GDK_Visual_UnRef(GdiObject^.Visual);
If GdiObject^.Colormap <> nil then
GDK_Colormap_UnRef(GdiObject^.Colormap);
If GdiObject^.Colormap <> nil then
GDK_Colormap_UnRef(GdiObject^.Colormap);
GdiObject^.Visual := gdk_window_get_visual(GdiObject^.GDIpixmapObject);
If GdiObject^.Visual = nil then
@ -3081,10 +3081,9 @@ var
CurrentBrush := PGdiObject(Brush);
SelectedColors := dcscCustom;
SelectGDKBrushProps(DC);
If not CurrentBrush^.IsNullBrush then begin
If not IsNullBrush(TDeviceContext(DC)) then
gdk_draw_rectangle(TempPixmap, GetGC, 1, 0, 0, Width, Height);
end;
// Restore current brush
SelectedColors := dcscCustom;
CurrentBrush := OldCurrentBrush;
@ -3101,11 +3100,15 @@ var
DebugLn('SrcDevBitmapToDrawable Start');
{$ENDIF}
SrcGDIBitmap:=SrcDevContext.CurrentBitmap;
if (SrcGDIBitmap=nil) then begin
if (SrcGDIBitmap=nil)then begin
DebugLn('SrcDevBitmapToDrawable NOTE: SrcDevContext.CurrentBitmap=nil');
exit;
end;
SrcPixmap:=SrcGDIBitmap^.GDIPixmapObject;
if (SrcPixmap=nil)then begin
DebugLn('SrcDevBitmapToDrawable NOTE: SrcDevContext.CurrentBitmap^.GDIPixmapObject=nil');
exit;
end;
MaskPixmap:=nil;
if (Mask<>0) then
MaskPixmap:=PGdiObject(Mask)^.GDIBitmapMaskObject;
@ -4282,7 +4285,7 @@ begin
// Remove control accelerators - has to be done due to GTK+ bug?
//DebugLn('TGtkWidgetSet.DestroyLCLComponent B Widget=',GetWidgetDebugReport(Widget));
{$IFNDef GTK2}
{$IFDef GTK1}
Accelerators:= gtk_accel_group_entries_from_object(PGtkObject(Widget));
while Accelerators <> nil do begin
AccelEntry:= Accelerators^.data;
@ -6295,22 +6298,22 @@ end;
------------------------------------------------------------------------------}
procedure TGtkWidgetSet.SelectGDKBrushProps(DC: HDC);
begin
if (TDeviceContext(DC).SelectedColors=dcscBrush) or
TDeviceContext(DC).CurrentBrush^.IsNullBrush
if (TDeviceContext(DC).SelectedColors=dcscBrush)
or IsNullBrush(TDeviceContext(DC))
then
exit;
with TDeviceContext(DC), CurrentBrush^ do
with TDeviceContext(DC) do
begin
//DebugLn('TGtkWidgetSet.SelectGDKBrushProps Setting BKColor ...');
EnsureGCColor(DC, dccCurrentBackColor, True, True);//BKColor
//DebugLn('TGtkWidgetSet.SelectGDKBrushProps Setting Brush Color ...');
EnsureGCColor(DC, dccGDIBrushColor, GDIBrushFill = GDK_Solid, False);//Brush Color
EnsureGCColor(DC, dccGDIBrushColor, GetBrush^.GDIBrushFill = GDK_Solid, False);//Brush Color
If GDIBrushFill <> GDK_Solid then
If GDIBrushPixmap <> nil then begin
gdk_gc_set_fill(GetGC, GDIBrushFill);
gdk_gc_set_Stipple(GetGC,GDIBrushPixmap);
If GetBrush^.GDIBrushFill <> GDK_Solid then
If GetBrush^.GDIBrushPixmap <> nil then begin
gdk_gc_set_fill(GetGC, GetBrush^.GDIBrushFill);
gdk_gc_set_Stipple(GetGC, GetBrush^.GDIBrushPixmap);
end
end;
TDeviceContext(DC).SelectedColors:=dcscBrush;
@ -6354,7 +6357,7 @@ procedure TGtkWidgetSet.SelectGDKPenProps(DC: HDC);
begin
if TDeviceContext(DC).SelectedColors<>dcscPen then begin
with TDeviceContext(DC), CurrentPen^ do begin
with TDeviceContext(DC), GetPen^ do begin
EnsureGCColor(DC, dccCurrentBackColor, True, True);//BKColor
EnsureGCColor(DC, dccGDIPenColor, False, False);//Pen Color
end;
@ -6364,7 +6367,7 @@ begin
if (not (dcfPenSelected in TDeviceContext(DC).DCFlags)) then begin
Exclude(TDeviceContext(DC).DCFlags,dcfPenInvalid);
if TDeviceContext(DC).GetGC<>nil then begin
with TDeviceContext(DC), CurrentPen^ do
with TDeviceContext(DC), GetPen^ do
begin
IsNullPen := GDIPenStyle = PS_NULL;
if (GDIPenStyle = PS_SOLID) or (GDIPenStyle = PS_INSIDEFRAME)
@ -6406,8 +6409,34 @@ begin
Assert(False, Format('Trace:> [TGtkWidgetSet.NewDC]', []));
Result:=NewDeviceContext;
FDeviceContexts.Add(Result);
//DebugLn('[TGtkWidgetSet.NewDC] ',DbgS(Result),' ',FDeviceContexts.Count);
// Assert(False, Format('Trace:< [TGtkWidgetSet.NewDC] FDeviceContexts[%d] --> 0x%p', [n, Result]));
{$ifdef TraceGdiCalls}
FillStackAddrs(get_caller_frame(get_frame), @Result.StackAddrs);
{$endif}
//DebugLn(['[TGtkWidgetSet.NewDC] ',DbgS(Result),' ',FDeviceContexts.Count]);
// Assert(False, Format('Trace:< [TGtkWidgetSet.NewDC] FDeviceContexts[%d] --> 0x%p', [n, Result]));
end;
function TGTKWidgetSet.FindDCWithGDIObject(GDIObject: PGdiObject
): TDeviceContext;
var
HashItem: PDynHashArrayItem;
DC: TDeviceContext;
g: TGDIType;
Cnt: Integer;
begin
Result:=nil;
if GdiObject=nil then exit;
HashItem:=FDeviceContexts.FirstHashItem;
Cnt:=0;
while HashItem<>nil do begin
DC:=TDeviceContext(HashItem^.Item);
for g:=Low(TGDIType) to High(TGDIType) do
if DC.GDIObjects[g]=GdiObject then exit(DC);
inc(Cnt);
HashItem:=HashItem^.Next;
end;
if Cnt<>FDeviceContexts.Count then
RaiseGDBException('');
end;
{------------------------------------------------------------------------------
@ -6485,14 +6514,13 @@ begin
aDC.Drawable := TheWindow;
{$IFDEF Gtk1}
aDC.GetGC;
{$ELSE}
// GC is created on demand
{$ENDIF}
end;
with aDC do
begin
{$ifdef TraceGdiCalls}
FillStackAddrs(get_caller_frame(get_frame), @StackAddrs);
{$endif}
gdk_color_black(gdk_colormap_get_system, @CurrentTextColor.Color);
BuildColorRefFromGDKColor(CurrentTextColor);
gdk_color_white(gdk_colormap_get_system, @CurrentBackColor.Color);
@ -6501,13 +6529,12 @@ begin
{$Ifdef GTK1}
aDC.GetFont;
aDC.GetBrush;
aDC.GetPen;
{$ELSE}
// font is created on demand
// font, brush, pen are created on demand
{$EndIf}
aDC.CurrentBrush := CreateDefaultBrush;
aDC.CurrentPen := CreateDefaultPen;
Result := HDC(aDC);
Assert(False, Format('trace:< [TGtkWidgetSet.CreateDCForWidget] Got 0x%x', [Result]));
end;
@ -6547,6 +6574,18 @@ begin
end;
end;
procedure TGTKWidgetSet.OnCreateGDIObjectForDC(DC: TDeviceContext;
aGDIType: TGDIType);
begin
case aGDIType of
gdiFont: OnCreateFontForDC(DC);
gdiBrush: OnCreateBrushForDC(DC);
gdiPen: OnCreatePenForDC(DC);
gdiBitmap: OnCreateGDIBitmapForDC(DC);
else RaiseGDBException('TGTKWidgetSet.OnCreateGDIObjectForDC');
end;
end;
procedure TGTKWidgetSet.OnCreateFontForDC(DC: TDeviceContext);
{$IFDEF Gtk2}
var
@ -6562,18 +6601,42 @@ begin
DC.CurrentFont^.GDIFontObject := DC.GCValues.Font;
FontCache.Reference(DC.CurrentFont^.GDIFontObject);
end else
DC.CurrentFont := CreateDefaultFont;
DC.CurrentFont:=CreateDefaultFont;
{$ELSE}
if DC.DCWidget<>nil then begin
ClientWidget:=GetFixedWidget(DC.DCWidget);
DC.CurrentFont:=NewGDIObject(gdiFont);
DC.CurrentFont^.GDIFontObject:=
gtk_widget_create_pango_layout(ClientWidget,nil);
FontCache.Reference(DC.CurrentFont^.GDIFontObject);
FontCache.AddWithoutName(DC.CurrentFont^.GDIFontObject);
if FontCache.FindGTKFont(GetGtkFont(DC))=nil then
RaiseGDBException('');
end else
DC.CurrentFont := CreateDefaultFont;
DC.CurrentFont:=CreateDefaultFont;
//DebugLn(['TGTKWidgetSet.OnCreateFontForDC DC=',dbghex(PtrInt(DC)),' Font=',dbghex(PtrInt(DC.CurrentFont))]);
{$ENDIF}
DC.OwnedGDIObjects[gdiFont]:=DC.CurrentFont;
end;
procedure TGTKWidgetSet.OnCreateBrushForDC(DC: TDeviceContext);
begin
if DC.CurrentBrush<>nil then exit;
DC.CurrentBrush := CreateDefaultBrush;
DC.OwnedGDIObjects[gdiBrush]:=DC.CurrentBrush;
end;
procedure TGTKWidgetSet.OnCreatePenForDC(DC: TDeviceContext);
begin
if DC.CurrentPen<>nil then exit;
DC.CurrentPen := CreateDefaultPen;
DC.OwnedGDIObjects[gdiPen]:=DC.CurrentPen;
end;
procedure TGTKWidgetSet.OnCreateGDIBitmapForDC(DC: TDeviceContext);
begin
if DC.CurrentBitmap<>nil then exit;
DC.CurrentBitmap := CreateDefaultGDIBitmap;
DC.OwnedGDIObjects[gdiBitmap]:=DC.CurrentBitmap;
end;
{------------------------------------------------------------------------------
@ -6677,6 +6740,16 @@ begin
{$ENDIF}
end;
function TGTKWidgetSet.IsNullBrush(DC: TDeviceContext): boolean;
begin
Result:=(DC.CurrentBrush<>nil) and (DC.CurrentBrush^.IsNullBrush);
end;
function TGTKWidgetSet.IsNullPen(DC: TDeviceContext): boolean;
begin
Result:=(DC.CurrentPen<>nil) and (DC.CurrentPen^.IsNullBrush);
end;
{------------------------------------------------------------------------------
Function: NewGDIObject
Params: none
@ -6694,7 +6767,7 @@ begin
Result^.GDIType := GDIType;
inc(Result^.RefCount);
FGDIObjects.Add(Result);
//DebugLn('[TGtkWidgetSet.NewGDIObject] ',DbgS(Result),' ',FGDIObjects.Count);
//DebugLn('[TGtkWidgetSet.NewGDIObject] ',DbgS(Result),' ',FGDIObjects.Count);
Assert(False, Format('Trace:< [TGtkWidgetSet.NewGDIObject] FGDIObjects --> 0x%p', [Result]));
end;
@ -6774,6 +6847,11 @@ begin
BuildColorRefFromGDKColor(Result^.GDIPenColor);
end;
function TGTKWidgetSet.CreateDefaultGDIBitmap: PGdiObject;
begin
Result := NewGDIObject(gdiBitmap);
end;
{------------------------------------------------------------------------------
procedure TGtkWidgetSet.UpdateDCTextMetric(DC: TDeviceContext);
@ -7002,12 +7080,12 @@ end;
function TGtkWidgetSet.DCClipRegionValid(DC: HDC): boolean;
var
ClipRegion: hRGN;
CurClipRegion: hRGN;
begin
Result:=false;
if not IsValidDC(DC) then exit;
ClipRegion:=TDeviceContext(DC).ClipRegion;
if (ClipRegion<>0) and (not IsValidGDIObject(ClipRegion)) then exit;
CurClipRegion:=HRGN(TDeviceContext(DC).ClipRegion);
if (CurClipRegion<>0) and (not IsValidGDIObject(CurClipRegion)) then exit;
Result:=true;
end;
@ -7422,7 +7500,7 @@ begin
LinesList.Free;
end;
function TGtkWidgetSet.ROP2ModeToGdkFunction(Mode: IntegeR): TGdkFunction;
function TGtkWidgetSet.ROP2ModeToGdkFunction(Mode: Integer): TGdkFunction;
begin
case Mode of
R2_COPYPEN: result := GDK_COPY;
@ -7445,7 +7523,8 @@ begin
end;
end;
function TGtkWidgetSet.GdkFunctionToROP2Mode(aFunction: TGdkFunction): Integer;
function TGtkWidgetSet.GdkFunctionToROP2Mode(const aFunction: TGdkFunction
): Integer;
begin
case aFunction of
GDK_COPY: result := R2_COPYPEN;

76
lcl/interfaces/gtk/gtkproc.inc
View File

@ -1078,7 +1078,6 @@ procedure MergeClipping(DestinationDC: TDeviceContext; DestinationGC: PGDKGC;
var
temp_gc : PGDKGC;
temp_color : TGDKColor;
Region: PGdiObject;
RGNType : Longint;
OffsetXY: TPoint;
//ClipMergeMaskWidth, ClipMergeMaskHeight: integer;
@ -1112,9 +1111,8 @@ begin
// copy the destination clipping mask into the temporary mask
with DestinationDC do begin
If (ClipRegion <> 0) then begin
Region:=PGDIObject(ClipRegion);
RGNType := RegionType(Region^.GDIRegionObject);
If (ClipRegion <> nil) then begin
RGNType := RegionType(ClipRegion^.GDIRegionObject);
If (RGNType <> ERROR) and (RGNType <> NULLREGION) then begin
// destination has a clipping mask
{$IFDEF VerboseStretchCopyArea}
@ -1126,11 +1124,11 @@ begin
// The clip region of dest is always at 0,0 in dest
OffsetXY:=Point(-X,-Y);
// 1. Move the region
gdk_region_offset(Region^.GDIRegionObject,OffsetXY.X,OffsetXY.Y);
gdk_region_offset(ClipRegion^.GDIRegionObject,OffsetXY.X,OffsetXY.Y);
// 2. Apply region to temporary mask
gdk_gc_set_clip_region(temp_gc, Region^.GDIRegionObject);
gdk_gc_set_clip_region(temp_gc, ClipRegion^.GDIRegionObject);
// 3. Undo moving the region
gdk_region_offset(Region^.GDIRegionObject,-OffsetXY.X,-OffsetXY.Y);
gdk_region_offset(ClipRegion^.GDIRegionObject,-OffsetXY.X,-OffsetXY.Y);
end;
end;
end;
@ -1413,15 +1411,21 @@ begin
end;
{------------------------------------------------------------------------------
Function: CopyDCData
Function: CopyDCData - used by RestoreDC and SaveDC
Params: DestinationDC: a dc to copy data to
SourceDC: a dc to copy data from
FreeObjects: boolean
ClearSource: set true to make a move operation
MoveGDIOwnerShip: set true to pass the ownership of the GDI objects
to Destination
Returns: True if succesful
Creates a copy DC from the given DC
------------------------------------------------------------------------------}
function CopyDCData(DestinationDC, SourceDC: TDeviceContext): Boolean;
function CopyDCData(SourceDC, DestinationDC: TDeviceContext;
ClearSource, MoveGDIOwnerShip: boolean): Boolean;
var
g: TGDIType;
CurGDIObject: PGDIObject;
begin
// Assert(False, Format('Trace:> [CopyDCData] DestDC:0x%x, SourceDC:0x%x', [Integer(DestinationDC), Integer(SourceDC)]));
Result := (DestinationDC <> nil) and (SourceDC <> nil);
@ -1442,10 +1446,10 @@ begin
DCFlags:=DCFlags-[dcfPenSelected];
end;
if (SourceDC.GC <> nil) and (Drawable <> nil) then begin
BeginGDKErrorTrap;
{$IFDEF DebugGDK} BeginGDKErrorTrap; {$ENDIF}
gdk_gc_get_values(SourceDC.GC, @GCValues);
GC := gdk_gc_new_with_values(Drawable, @GCValues, 3 { $3FF});
EndGDKErrorTrap;
{$IFDEF DebugGDK} EndGDKErrorTrap; {$ENDIF}
DCFlags:=DCFlags-[dcfPenSelected];
end;
@ -1458,24 +1462,24 @@ begin
DCTextMetric := SourceDC.DCTextMetric;
end else
Exclude(DCFlags,dcfTextMetricsValid);
// ToDo: should the bitmap be freed automatically?
CurrentBitmap := SourceDC.CurrentBitmap;
//DebugLn(['CopyDCData DC=',dbghex(PtrInt(DestinationDC)),' OldFont=',dbghex(PtrInt(CurrentFont2)),' NewFont=',dbghex(PtrInt(SourceDC.CurrentFont2))]);
if (CurrentFont<>nil) and (CurrentFont<>SourceDC.CurrentFont) then
DeleteObject(HGDIObj(CurrentFont));
CurrentFont := SourceDC.CurrentFont;
if (CurrentPen<>nil) and (CurrentPen<>SourceDC.CurrentPen) then
DeleteObject(HGDIObj(CurrentPen));
CurrentPen := SourceDC.CurrentPen;
if (CurrentBrush<>nil) and (CurrentBrush<>SourceDC.CurrentBrush) then
DeleteObject(HGDIObj(CurrentBrush));
CurrentBrush := SourceDC.CurrentBrush;
if (CurrentPalette<>nil) and (CurrentPalette<>SourceDC.CurrentPalette) then
DeleteObject(HGDIObj(CurrentPalette));
CurrentPalette := SourceDC.CurrentPalette;
for g:=Low(TGDIType) to High(TGDIType) do begin
GDIObjects[g]:=SourceDC.GDIObjects[g];
if ClearSource then
SourceDC.GDIObjects[g]:=nil;
if MoveGDIOwnerShip then begin
if OwnedGDIObjects[g]<>nil then begin
DeleteObject(HGDIOBJ(OwnedGDIObjects[g]));
end;
CurGDIObject:=SourceDC.OwnedGDIObjects[g];
if CurGDIObject<>nil then begin
SourceDC.OwnedGDIObjects[g]:=nil;
OwnedGDIObjects[g]:=CurGDIObject;
end;
end;
end;
CopyGDIColor(SourceDC.CurrentTextColor,CurrentTextColor);
CopyGDIColor(SourceDC.CurrentBackColor,CurrentBackColor);
ClipRegion := SourceDC.ClipRegion;
SelectedColors := dcscCustom;
SavedContext := nil;
@ -1519,7 +1523,6 @@ end;
------------------------------------------------------------------------------}
Procedure SelectGDIRegion(const DC: HDC);
var
Region: PGdiObject;
RGNType : Longint;
begin
with TDeviceContext(DC) do
@ -1529,11 +1532,10 @@ begin
{$ENDIF}
gdk_gc_set_clip_region(GetGC, nil);
gdk_gc_set_clip_rectangle (GetGC, nil);
If (ClipRegion <> 0) then begin
Region:=PGDIObject(ClipRegion);
RGNType := RegionType(Region^.GDIRegionObject);
If (ClipRegion <> nil) then begin
RGNType := RegionType(ClipRegion^.GDIRegionObject);
If (RGNType <> ERROR) and (RGNType <> NULLREGION) then begin
gdk_gc_set_clip_region(GetGC, PGDIObject(ClipRegion)^.GDIRegionObject);
gdk_gc_set_clip_region(GetGC, ClipRegion^.GDIRegionObject);
end;
end;
{$IFDEF DebugGDK}
@ -1704,8 +1706,8 @@ begin
case ColorType of
dccCurrentBackColor: GDIColor:=@CurrentBackColor;
dccCurrentTextColor: GDIColor:=@CurrentTextColor;
dccGDIBrushColor : GDIColor:=@(CurrentBrush^.GDIBrushColor);
dccGDIPenColor : GDIColor:=@(CurrentPen^.GDIPenColor);
dccGDIBrushColor : GDIColor:=@(GetBrush^.GDIBrushColor);
dccGDIPenColor : GDIColor:=@(GetPen^.GDIPenColor);
end;
end;
if GDIColor=nil then exit;
@ -4066,6 +4068,10 @@ var
AWinControl: TWinControl;
Mess: TLMessage;
begin
{$IFDEF DebugLCLComponents}
if DebugGtkWidgets.FindInfo(Widget)=nil then
DebugLn(['DestroyWidget ',GetWidgetDebugReport(Widget)]);
{$ENDIF}
Info:=GetWidgetInfo(Widget);
if Info<>nil then begin
if (Info^.LCLObject is TWinControl) then begin

3
lcl/interfaces/gtk/gtkproc.pp
View File

@ -392,7 +392,8 @@ procedure FinalizePaintTagMsg(Msg: PMsg);
// DC
function GetDCOffset(DC: TDeviceContext): TPoint;
function CopyDCData(DestinationDC, SourceDC: TDeviceContext): Boolean;
function CopyDCData(SourceDC, DestinationDC: TDeviceContext;
ClearSource, MoveGDIOwnerShip: boolean): Boolean;
// region
Function RegionType(RGN: PGDKRegion): Longint;

343
lcl/interfaces/gtk/gtkwinapi.inc
View File

@ -67,7 +67,7 @@ begin
If (dcfPenSelected in DCFlags) then begin
Result := True;
if (CurrentPen^.IsNullPen) then exit;
if IsNullPen(TDeviceContext(DC)) then exit;
DCOrigin:=GetDCOffset(TDeviceContext(DC));
inc(Left,DCOrigin.X);
@ -1230,18 +1230,17 @@ begin
*)
with pNewDC do
begin
{$ifdef TraceGdiCalls}
FillStackAddrs(get_caller_frame(get_frame), @StackAddrs);
{$endif}
gdk_color_black(gdk_colormap_get_system, @CurrentTextColor.Color);
BuildColorRefFromGDKColor(CurrentTextColor);
gdk_color_white(gdk_colormap_get_system, @CurrentBackColor.Color);
BuildColorRefFromGDKColor(CurrentBackColor);
end;
{$IFDEF Gtk1}
pNewDC.GetFont;
pNewDC.CurrentBrush := CreateDefaultBrush;
pNewDC.CurrentPen := CreateDefaultPen;
pNewDC.GetBrush;
pNewDC.GetPen;
{$ENDIF}
Result := HDC(pNewDC);
@ -2387,13 +2386,62 @@ function TGtkWidgetSet.DeleteObject(GDIObject: HGDIOBJ): Boolean;
begin
{$ifdef TraceGdiCalls}
DebugLn();
DebugLn('TraceCall for invalid object: ');
DebugLn('TGtkWidgetSet.DeleteObject: TraceCall for invalid object: ');
DumpBackTrace(PgdiObject(GdiObject)^.StackAddrs);
DebugLn();
DebugLn('Exception will follow:');
DebugLn();
{$endif}
RaiseGDBException('TGtkWidgetSet.DeleteObject invalid GdiObject='+DbgS(GdiObject));
RaiseGDBException('TGtkWidgetSet.DeleteObject invalid GdiObject='+dbghex(GdiObject));
end;
procedure RaiseGDIObjectIsStillUsed;
var
CurGDIObject: PGDIObject;
DC: TDeviceContext;
begin
{$ifdef TraceGdiCalls}
DebugLn();
DebugLn('TGtkWidgetSet.DeleteObject: TraceCall for still used object: ');
DumpBackTrace(PgdiObject(GdiObject)^.StackAddrs);
DebugLn();
DebugLn('Exception will follow:');
DebugLn();
{$endif}
// do not raise an exception, because this is a common bug in many programs
// just give a warning
CurGDIObject:=PGdiObject(GdiObject);
debugln('TGtkWidgetSet.DeleteObject GdiObject='+dbgs(CurGDIObject)
+' '+dbgs(CurGDIObject^.GDIType)
+' is still used. DCCount='+dbgs(CurGDIObject^.DCCount));
DC:=FindDCWithGDIObject(CurGDIObject);
if DC<>nil then begin
DebugLn(['DC: ',dbgs(Pointer(DC)),' ',
GetWidgetDebugReport(DC.DCWidget)]);
end else begin
DebugLn(['No DC found with this GDIObject => either the DCCount is wrong or the DC is not in the DC list']);
end;
//DumpStack;
RaiseGDBException('');
end;
procedure RaiseInvalidGDIOwner;
var
o: PGDIObject;
begin
{$ifdef TraceGdiCalls}
DebugLn();
DebugLn('TGtkWidgetSet.DeleteObject: TraceCall for invalid object: ');
DumpBackTrace(PgdiObject(GdiObject)^.StackAddrs);
DebugLn();
DebugLn('Exception will follow:');
DebugLn();
{$endif}
o:=PGdiObject(GdiObject);
RaiseGDBException('TGtkWidgetSet.DeleteObject invalid owner of'
+' GdiObject='+dbgs(o)
+' Owner='+dbgs(o^.Owner)
+' Owner.OwnedGDIObjects='+dbgs(o^.Owner.OwnedGDIObjects[o^.GDIType]));
end;
var
@ -2417,8 +2465,20 @@ begin
if not GDIObjectExists then begin
RaiseInvalidGDIObject;
end;
with PGdiObject(GDIObject)^ do
begin
if DCCount>0 then begin
RaiseGDIObjectIsStillUsed;
exit(false);
end;
if Owner<>nil then begin
if Owner.OwnedGDIObjects[GDIType]<>PGdiObject(GDIObject) then
RaiseInvalidGDIOwner;
Owner.OwnedGDIObjects[GDIType]:=nil;
end;
case GDIType of
gdiFont:
begin
@ -2481,8 +2541,8 @@ begin
EndGDKErrorTrap;
{$ENDIF}
RGBTable.Free;
IndexTable.Free;
FreeAndNil(RGBTable);
FreeAndNil(IndexTable);
end;
else begin
Result:= false;
@ -2933,19 +2993,18 @@ begin
//Draw interiour
if ((grfFlags and BF_MIDDLE) = BF_MIDDLE) and
not CurrentBrush^.IsNullBrush
not IsNullBrush(TDeviceContext(DC))
then begin
Width := R.Right - R.Left + 1;
Height := R.Bottom - R.Top + 1;
SelectGDKBrushProps(DC);
If not CurrentBrush^.IsNullBrush then
if (CurrentBrush^.GDIBrushFill = GDK_SOLID)
and (IsBackgroundColor(TColor(CurrentBrush^.GDIBrushColor.ColorRef)))
then
StyleFillRectangle(Drawable, GetGC, CurrentBrush^.GDIBrushColor.ColorRef,
R.Left, R.Top, Width, Height)
else
gdk_draw_rectangle(Drawable, GetGC, 1, R.Left, R.Top, Width, Height);
if (GetBrush^.GDIBrushFill = GDK_SOLID)
and (IsBackgroundColor(TColor(GetBrush^.GDIBrushColor.ColorRef)))
then
StyleFillRectangle(Drawable, GetGC, GetBrush^.GDIBrushColor.ColorRef,
R.Left, R.Top, Width, Height)
else
gdk_draw_rectangle(Drawable, GetGC, 1, R.Left, R.Top, Width, Height);
end;
// adjust rect if needed
@ -3182,10 +3241,10 @@ begin
CopyRect(Rect, theRect);
Result := 1;
exit;
end else begin
TempDC := SaveDC(DC);
end;
TempDC := SaveDC(DC);
if (Flags and DT_NOCLIP) <> DT_NOCLIP then begin
if theRect.Right > Rect.Right then
theRect.Right := Rect.Right;
@ -3223,7 +3282,7 @@ begin
finally
Reallocmem(Lines, 0);
if TempBrush <> HBRUSH(-1) then
SelectObject(DC, TempBrush);
SelectObject(DC, TempBrush);// DeleteObject not needed here, because it was a default Brush
if TempPen <> HPEN(-1) then
DeleteObject(SelectObject(DC, TempPen));
if TempDC <> HDC(-1) then
@ -3798,25 +3857,27 @@ begin
end;
// first draw interior in brush color
SelectGDKBrushProps(DC);
DCOrigin:=GetDCOffset(TDeviceContext(DC));
{$IFDEF DebugGDKTraps}
BeginGDKErrorTrap;
{$ENDIF}
If not CurrentBrush^.IsNullBrush then
If not IsNullBrush(TDeviceContext(DC)) then begin
SelectGDKBrushProps(DC);
gdk_draw_arc(Drawable, GetGC, 1, x+DCOrigin.X, y+DCOrigin.Y, Width, Height,
0, 360 shl 6);
end;
// Draw outline
SelectGDKPenProps(DC);
SelectGDKPenProps(DC);
If (dcfPenSelected in DCFlags) then begin
Result := True;
if (CurrentPen^.IsNullPen) then exit;
gdk_draw_arc(Drawable, GetGC, 0, x+DCOrigin.X, y+DCOrigin.Y, Width, Height,
0, 360 shl 6);
if not IsNullPen(TDeviceContext(DC)) then begin
gdk_draw_arc(Drawable, GetGC, 0, x+DCOrigin.X, y+DCOrigin.Y, Width, Height,
0, 360 shl 6);
end;
end else
Result := False;
@ -3892,7 +3953,7 @@ begin
begin
//DebugLn('TGtkWidgetSet.ExtSelectClipRGN A ClipRegValid=',dbgs(DCClipRegionValid(DC)),
// ' Mode=',dbgs(Mode),' RGN=',GDKRegionAsString(PGdiObject(RGN)^.GDIRegionObject));
If ClipRegion=0 then begin
If ClipRegion=nil then begin
// there is no clipping region in the DC
Case Mode of
RGN_COPY:
@ -4139,7 +4200,7 @@ begin
Height := Rect.Bottom - Rect.Top;
// Temporary hold the old brush to
// replace it with the given brush
OldCurrentBrush := CurrentBrush;
OldCurrentBrush := GetBrush;
if not CompareGDIBrushes(PGdiObject(Brush),OldCurrentBrush) then begin
BrushChanged:=true;
CurrentBrush := PGdiObject(Brush);
@ -4192,7 +4253,7 @@ begin
SelectGDKPenProps(DC);
If (dcfPenSelected in DCFlags) then begin
Result := 1;
if (not CurrentPen^.IsNullPen) then begin
if not IsNullPen(TDeviceContext(DC)) then begin
DCOrigin:=GetDCOffset(TDeviceContext(DC));
gdk_draw_rectangle(Drawable, GetGC, 0,
ARect.Left+DCOrigin.X, ARect.Top+DCOrigin.Y,
@ -4658,7 +4719,7 @@ begin
then with TDeviceContext(DC) do
begin
DCOrigin:=GetDCOffset(TDeviceContext(DC));
If Not IsValidGDIObject(ClipRegion) then begin
If ClipRegion=nil then begin
{$IFDEF DebugGDKTraps}
BeginGDKErrorTrap;
{$ENDIF}
@ -4670,8 +4731,8 @@ begin
Result := SIMPLEREGION;
end
else begin
Result := RegionType(PGDIObject(ClipRegion)^.GDIRegionObject);
gdk_region_get_clipbox(PGDIObject(ClipRegion)^.GDIRegionObject,
Result := RegionType(ClipRegion^.GDIRegionObject);
gdk_region_get_clipbox(ClipRegion^.GDIRegionObject,
@CRect);
lpRect^.Left := CRect.X-DCOrigin.X;
lpRect^.Top := CRect.Y-DCOrigin.Y;
@ -4761,14 +4822,14 @@ begin
Result := ERROR;
DebugLn('WARNING: [TGtkWidgetSet.GetClipRGN] Invalid HRGN');
end
else if (TDeviceContext(DC).ClipRegion<>0)
and (not IsValidGDIObject(TDeviceContext(DC).ClipRegion)) then
else if (TDeviceContext(DC).ClipRegion<>nil)
and (not IsValidGDIObject(HGDIOBJ(TDeviceContext(DC).ClipRegion))) then
Result := ERROR
else with TDeviceContext(DC) do
begin
CurRegionObject:=nil;
if ClipRegion<>0 then
CurRegionObject:=PGdiObject(ClipRegion)^.GDIRegionObject;
if ClipRegion<>nil then
CurRegionObject:=ClipRegion^.GDIRegionObject;
ARect:=Rect(0,0,0,0);
if CurRegionObject<>nil then begin
// create a copy of the current clipregion
@ -6745,10 +6806,9 @@ begin
then with TDeviceContext(DC) do
begin
SelectGDKPenProps(DC);
If (dcfPenSelected in DCFlags) then begin
Result := True;
if (CurrentPen^.IsNullPen) then exit;
if IsNullPen(TDeviceContext(DC)) then exit;
DCOrigin:=GetDCOffset(TDeviceContext(DC));
{$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF}
@ -7042,11 +7102,11 @@ begin
end;
// first draw interior in brush color
SelectGDKBrushProps(DC);
{$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF}
If not CurrentBrush^.IsNullBrush then
If not IsNullBrush(TDeviceContext(DC)) then begin
SelectGDKBrushProps(DC);
if Winding then begin
// store old clipping
Tmp := CreateEmptyRegion;
@ -7057,24 +7117,21 @@ begin
DeleteObject(RGN);
GetClipBox(DC, @ClipRect);
// draw polygon area
FillRect(DC, ClipRect, HBrush(CurrentBrush));
FillRect(DC, ClipRect, HBrush(GetBrush));
// restore old clipping
SelectClipRGN(DC, Tmp);
DeleteObject(Tmp);
end else
gdk_draw_polygon(Drawable, GetGC, 1, PointArray, NumPts);
end;
// draw outline
Result := True;
SelectGDKPenProps(DC);
If (dcfPenSelected in DCFlags) then begin
Result := True;
if (not CurrentPen^.IsNullPen) then begin
gdk_draw_polygon(Drawable, GetGC, 0, PointArray, NumPts);
end;
end else
Result:=false;
if not IsNullPen(TDeviceContext(DC)) then begin
gdk_draw_polygon(Drawable, GetGC, 0, PointArray, NumPts);
end;
{$IFDEF DebugGDKTraps}EndGDKErrorTrap;{$ENDIF}
@ -7106,7 +7163,7 @@ begin
If (dcfPenSelected in DCFlags) then begin
Result := True;
if (not CurrentPen^.IsNullPen) then begin
if not IsNullPen(TDeviceContext(DC)) then begin
{$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF}
gdk_draw_lines(Drawable, GetGC, PointArray, NumPts);
{$IFDEF DebugGDKTraps}EndGDKErrorTrap;{$ENDIF}
@ -7301,10 +7358,11 @@ begin
SelectGDKBrushProps(DC);
DCOrigin:=GetDCOffset(TDeviceContext(DC));
{$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF}
If not CurrentBrush^.IsNullBrush then
if (CurrentBrush^.GDIBrushFill = GDK_SOLID)
and (IsBackgroundColor(TColor(CurrentBrush^.GDIBrushColor.ColorRef))) then
StyleFillRectangle(Drawable, GetGC, CurrentBrush^.GDIBrushColor.ColorRef, Left+DCOrigin.X, Top+DCOrigin.Y, Width, Height)
If not IsNullBrush(TDeviceContext(DC)) then
if (GetBrush^.GDIBrushFill = GDK_SOLID)
and (IsBackgroundColor(TColor(GetBrush^.GDIBrushColor.ColorRef))) then
StyleFillRectangle(Drawable, GetGC, GetBrush^.GDIBrushColor.ColorRef,
Left+DCOrigin.X, Top+DCOrigin.Y, Width, Height)
else
gdk_draw_rectangle(Drawable, GetGC, 1, Left+DCOrigin.X, Top+DCOrigin.Y,
Width, Height);
@ -7314,7 +7372,7 @@ begin
If (dcfPenSelected in DCFlags) then begin
Result := True;
if (not CurrentPen^.IsNullPen) then
if not IsNullPen(TDeviceContext(DC)) then
gdk_draw_rectangle(Drawable, GetGC, 0, Left+DCOrigin.X, Top+DCOrigin.Y,
Width, Height);
end else
@ -7560,6 +7618,8 @@ end;
function TGtkWidgetSet.ReleaseDC(hWnd: HWND; DC: HDC): Integer;
var
aDC, pSavedDC: TDeviceContext;
g: TGDIType;
CurGDIObject: PGDIObject;
begin
//DebugLn('[TGtkWidgetSet.ReleaseDC] ',DbgS(DC),' ',FDeviceContexts.Count);
Assert(False, Format('trace:> [TGtkWidgetSet.ReleaseDC] DC:0x%x', [DC]));
@ -7570,42 +7630,37 @@ begin
if FDeviceContexts.Contains(Pointer(DC))
then begin
aDC := TDeviceContext(DC);
// Release all saved device contexts
// clear references to all GDI objects
for g:=Low(TGDIType) to high(TGDIType) do begin
{if aDC.GDIObjects[g]<>nil then
if FindDCWithGDIObject(aDC.GDIObjects[g])=nil then
RaiseGDBException('');}
aDC.GDIObjects[g]:=nil; // clear the reference, decrease DCCount
end;
// Release all saved device contexts (the owned GDI objects will be freed)
pSavedDC:=aDC.SavedContext;
if pSavedDC<>nil then begin
if pSavedDC.CurrentBitmap = aDC.CurrentBitmap
then
aDC.CurrentBitmap := nil;
if pSavedDC.CurrentFont = aDC.CurrentFont
then
aDC.CurrentFont := nil;
if (pSavedDC.CurrentPen = aDC.CurrentPen)
and (aDC.CurrentPen<>nil)
then
aDC.CurrentPen := nil;
if pSavedDC.CurrentBrush = aDC.CurrentBrush
then
aDC.CurrentBrush := nil;
if pSavedDC.CurrentPalette = aDC.CurrentPalette
then
aDC.CurrentPalette := nil;
if pSavedDC.ClipRegion = aDC.ClipRegion
then
pSavedDC.ClipRegion := 0;
ReleaseDC(0,HDC(pSavedDC));
aDC.SavedContext:=nil;
end;
// Release all graphic objects
DeleteObject(HGDIObj(aDC.CurrentBrush));
DeleteObject(HGDIObj(aDC.CurrentPen));
//DebugLn(['TGtkWidgetSet.ReleaseDC DC=',dbgs(TDeviceContext(aDC)),' ClipRegion=',dbgs(aDC.ClipRegion)]);
// free all owned GDI objects
for g:=Low(TGDIType) to high(TGDIType) do begin
CurGDIObject:=aDC.OwnedGDIObjects[g];
if CurGDIObject<>nil then begin
if CurGDIObject^.Owner<>aDC then
RaiseGDBException('');
DeleteObject(HGDIOBJ(CurGDIObject));
if aDC.OwnedGDIObjects[g]<>nil then
RaiseGDBException('');
end;
end;
//DebugLn(['TGtkWidgetSet.ReleaseDC DC=',dbghex(PtrInt(DC)),' Font=',dbghex(PtrInt(aDC.CurrentFont))]);
DeleteObject(HGDIObj(aDC.CurrentFont));
// bitmaps are not auto created, they are set via SelectObject
// -> user must free it
// ... DeleteObject(HGDIObj(aDC.CurrentBitmap));
DeleteObject(HGDIObj(aDC.CurrentPalette));
DeleteObject(HGDIObj(aDC.ClipRegion));
{FreeGDIColor(aDC.CurrentTextColor);
FreeGDIColor(aDC.CurrentBackColor);}
@ -7653,70 +7708,31 @@ end;
function TGtkWidgetSet.RestoreDC(DC: HDC; SavedDC: Integer): Boolean;
var
aDC, pSavedDC: TDeviceContext;
Count: Integer;
ClipRegionChanged: Boolean;
begin
Assert(False, Format('Trace:> [TGtkWidgetSet.RestoreDC] DC:0x%x, SavedDC: %d', [DC, SavedDC]));
Result := IsValidDC(DC) and (SavedDC <> 0);
if Result
then begin
pSavedDC := TDeviceContext(DC);
Count:=Abs(SavedDC);
while (Count>0) and (pSavedDC<>nil) do begin
aDC:=pSavedDC;
pSavedDC:=aDC.SavedContext;
dec(Count);
end;
Result := IsValidDC(DC) and (SavedDC > 0);
if not Result then exit;
while SavedDC>0 do begin
aDC:=TDeviceContext(DC);
pSavedDC:=aDC.SavedContext;
dec(SavedDC);
// TODO copy bitmap also
// TODO copy bitmap too
ClipRegionChanged:=false;
if (aDC.ClipRegion<>0) and (pSavedDC.ClipRegion <> aDC.ClipRegion) then
begin
// clipping region has changed
DeleteObject(aDC.ClipRegion);
ClipRegionChanged:=true;
aDC.ClipRegion := 0;
end;
if aDC.GC<>nil then begin
gdk_gc_unref(aDC.GC);
aDC.GC:=nil;
end;
Result := CopyDCData(aDC, pSavedDC);
ClipRegionChanged:=aDC.ClipRegion<>pSavedDC.ClipRegion;
// clear the GDIObjects in pSavedDC, so they are not freed by DeleteDC
Result := CopyDCData(pSavedDC, aDC, true, true);
aDC.SavedContext := pSavedDC.SavedContext;
pSavedDC.SavedContext := nil;
if ClipRegionChanged then
SelectGDIRegion(HDC(aDC));
//DebugLn('TGtkWidgetSet.RestoreDC A ',GDKRegionAsString(PGdiObject(aDC.ClipRegion)^.GDIRegionObject));
// free saved DC
//prevent deletion of copied objects:
if pSavedDC.CurrentBitmap = aDC.CurrentBitmap
then
pSavedDC.CurrentBitmap := nil;
if pSavedDC.CurrentFont = aDC.CurrentFont
then
pSavedDC.CurrentFont := nil;
if (pSavedDC.CurrentPen = aDC.CurrentPen)
and (pSavedDC.CurrentPen<>nil) then
pSavedDC.CurrentPen := nil;
if pSavedDC.CurrentBrush = aDC.CurrentBrush
then
pSavedDC.CurrentBrush := nil;
if pSavedDC.CurrentBrush = aDC.CurrentBrush
then
pSavedDC.CurrentBrush := nil;
{if pSavedDC.CurrentPalette = aDC.CurrentPalette
then pSavedDC.CurrentPalette := nil;}
if pSavedDC.ClipRegion = aDC.ClipRegion
then
pSavedDC.ClipRegion := 0;
DeleteDC(HGDIOBJ(pSavedDC));
end;
Assert(False, Format('Trace:< [TGtkWidgetSet.RestoreDC] DC:0x%x, Saved: %d --> %s', [Integer(DC), SavedDC, BOOL_TEXT[Result]]));
@ -7757,7 +7773,7 @@ begin
then begin
aDC := TDeviceContext(DC);
aSavedDC := NewDC;
CopyDCData(aSavedDC, aDC);
CopyDCData(aDC,aSavedDC,false,true);
aSavedDC.SavedContext:=aDC.SavedContext;
aDC.SavedContext:= aSavedDC;
Result:=1;
@ -7854,6 +7870,7 @@ Function TGtkWidgetSet.SelectClipRGN(DC : hDC; RGN : HRGN) : Longint;
var
RegObj: PGdkRegion;
DCOrigin: TPoint;
OldClipRegion: PGDIObject;
begin
If not IsValidDC(DC) then begin
Result := ERROR;
@ -7863,17 +7880,20 @@ begin
with TDeviceContext(DC) do
begin
// clear old clipregion
if (ClipRegion<>0)
and ((SavedContext=nil) or (SavedContext.ClipRegion<>ClipRegion)) then
DeleteObject(ClipRegion);
ClipRegion := 0;
if ClipRegion<>nil then begin
OldClipRegion:=ClipRegion;
ClipRegion := nil;// decrease DCCount
if (OldClipRegion=OwnedGDIObjects[gdiRegion]) then
DeleteObject(HGDIOBJ(OldClipRegion));
end;
If (RGN = 0) then begin
SelectGDIRegion(DC);
end
else If IsValidGDIObject(RGN) then begin
ClipRegion := CreateRegionCopy(RGN);
RegObj:=PGdiObject(ClipRegion)^.GDIRegionObject;
ClipRegion := PGdiObject(CreateRegionCopy(RGN));
OwnedGDIObjects[gdiRegion]:=ClipRegion;
RegObj:=ClipRegion^.GDIRegionObject;
DCOrigin:=GetDCOffset(TDeviceContext(DC));
//DebugLn('TGtkWidgetSet.SelectClipRGN A RegObj=',GDKRegionAsString(RegObj),' DCOrigin=',dbgs(DCOrigin),' RGN=',GDKRegionAsString(PGdiObject(RGN)^.GDIRegionObject));
gdk_region_offset(RegObj,DCOrigin.x,DCOrigin.Y);
@ -7923,9 +7943,7 @@ function TGtkWidgetSet.SelectObject(DC: HDC; GDIObj: HGDIOBJ): HGDIOBJ;
end;
{$ENDIF}
end;
var
NewDrawable: PGdkPixmap;
begin
Result := 0;
@ -7945,35 +7963,26 @@ begin
with TDeviceContext(DC) do
begin
Assert(False, Format('trace: [TGtkWidgetSet.SelectObject] DC: 0x%x, Type: Bitmap', [DC]));
if CurrentBitmap=nil then begin
// creating HBitmap on the fly (To find mem leaks)
CurrentBitmap:=NewGDIObject(gdiBitmap);
end;
Result := HBITMAP(CurrentBitmap);
Result := HBITMAP(GetBitmap);// always create, because a valid GDIObject is needed to restore
if CurrentBitmap<>PGDIObject(GDIObj) then begin
CurrentBitmap := PGDIObject(GDIObj);
with CurrentBitmap^ do
case GDIBitmapType of
gbPixmap: NewDrawable := GDIPixmapObject;
gbBitmap: NewDrawable := GDIBitmapObject;
gbPixmap: Drawable := GDIPixmapObject;
gbBitmap: Drawable := GDIBitmapObject;
else
NewDrawable := nil;
Drawable := nil;
end;
if NewDrawable<>nil then begin
if Drawable<>nil then begin
//DebugLn('TGtkWidgetSet.SelectObject DC=',DbgS(DC),8),' GDIBitmap=',DbgS(Cardinal(CurrentBitmap),
//' GDIBitmapType=',ord(CurrentBitmap^.GDIBitmapType),' Drawable=',DbgS(Drawable));
if GC <> nil then begin
gdk_gc_unref(GC);
GC:=nil;
end;
Drawable:=NewDrawable;
GC := gdk_gc_new(Drawable);
gdk_gc_set_function(GC, GDK_COPY);
SelectedColors := dcscCustom;
end else begin
// use defaults, free dummy gdiobject
DisposeGDIObject(CurrentBitmap);
CurrentBitmap:=nil;
end;
end;
end;
@ -7982,7 +7991,7 @@ begin
with TDeviceContext(DC), PGdiObject(GDIObj)^ do
begin
Assert(False, Format('trace: [TGtkWidgetSet.SelectObject] DC: 0x%x, Type: Brush', [DC]));
Result := HBRUSH(CurrentBrush);
Result := HBRUSH(GetBrush);// always create, because a valid GDIObject is needed to restore
if CurrentBrush<>PGDIObject(GDIObj) then begin
CurrentBrush := PGDIObject(GDIObj);
gdk_gc_set_fill(GetGC, GDIBrushFill);
@ -7998,7 +8007,7 @@ begin
with TDeviceContext(DC) do
begin
Assert(False, Format('trace: [TGtkWidgetSet.SelectObject] DC: 0x%x, Type: Font', [DC]));
Result := HFONT(GetFont);// always create: a valid GDIObject is needed to restore
Result := HFONT(GetFont);// always create, because a valid GDIObject is needed to restore
if CurrentFont<> PGDIObject(GDIObj) then begin
//DebugLn(['TGtkWidgetSet.SelectObject DC=',dbghex(DC),' Font Old=',dbghex(PtrInt(CurrentFont)),' New=',dbghex(GDIObj)]);
//dumpstack;
@ -8014,7 +8023,7 @@ begin
gdiPen:
with TDeviceContext(DC) do
begin
Result := HPEN(CurrentPen);
Result := HPEN(GetPen);// always create, because a valid GDIObject is needed to restore
if CurrentPen<> PGDIObject(GDIObj) then begin
CurrentPen := PGDIObject(GDIObj);
DCFlags:=DCFlags-[dcfPenSelected];
@ -8026,7 +8035,7 @@ begin
gdiRegion:
with TDeviceContext(DC) do
begin
Result := ClipRegion;
Result := HRGN(ClipRegion);
SelectClipRGN(DC, GDIObj)
end;
@ -9538,7 +9547,7 @@ begin
aRect := Rect(X+DCOrigin.X,Y+DCOrigin.Y,X + Sz.CX, Sz.CY);
//DebugLn('TGtkWidgetSet.TextOut ',ARect.Left,',',ARect.Top,',',ARect.RIght,',',ARect.Bottom);
FillRect(DC,aRect,hBrush(CurrentBrush));
FillRect(DC,aRect,hBrush(GetBrush));
UpdateDCTextMetric(TDeviceContext(DC));
TxtPt.X := X;
{$IfDef Win32}

3
lcl/interfaces/gtk/gtkwsextctrls.pp
View File

@ -234,6 +234,9 @@ var
AWidget: PGtkNoteBook;
begin
AWidget := PGtkNoteBook(gtk_notebook_new());
{$IFDEF DebugLCLComponents}
DebugGtkWidgets.MarkCreated(Pointer(AWidget),'notebook '+dbgsName(AWinControl));
{$ENDIF}
gtk_notebook_set_scrollable(AWidget, true);
gtk_notebook_popup_enable(AWidget);
if TCustomNotebook(AWinControl).PageCount=0 then

6
lcl/interfaces/gtk2/gtk2wscustommemo.inc
View File

@ -99,11 +99,13 @@ var
TempWidget: PGtkWidget;
WidgetInfo: PWidgetInfo;
begin
Widget := gtk_scrolled_window_new(nil, nil);
Result := TLCLIntfHandle(Widget);
if Result = 0 then Exit;
{$IFDEF DebugLCLComponents}
DebugGtkWidgets.MarkCreated(Widget,dbgsName(AWinControl));
{$ENDIF}
WidgetInfo := CreateWidgetInfo(Pointer(Result), AWinControl, AParams);
TempWidget := gtk_text_view_new();

2
lcl/interfaces/gtk2/gtk2wsextctrls.pp
View File

@ -27,7 +27,7 @@ unit Gtk2WSExtCtrls;
interface
uses
// libs
// libs
GLib2, Gtk2, Gdk2, Gtk2Int, gtkProc, GtkDef,
// LCL
ExtCtrls, Classes, Controls, LCLType,

22
lcl/interfaces/gtk2/gtk2wsstdctrls.pp
View File

@ -502,7 +502,10 @@ begin
p:= PGtkWidget(Result);
if Result = 0 then exit;
{$IFDEF DebugLCLComponents}
// already called by inherited: DebugGtkWidgets.MarkCreated(p,dbgsName(AWinControl));
{$ENDIF}
GTK_WIDGET_UNSET_FLAGS(PGtkScrolledWindow(p)^.hscrollbar, GTK_CAN_FOCUS);
GTK_WIDGET_UNSET_FLAGS(PGtkScrolledWindow(p)^.vscrollbar, GTK_CAN_FOCUS);
gtk_scrolled_window_set_policy(PGtkScrolledWindow(p),
@ -663,12 +666,14 @@ class function TGtk2WSCustomEdit.CreateHandle(const AWinControl: TWinControl;
var
p: PGtkWidget; // ptr to the newly created GtkWidget
begin
p := gtk_entry_new();
gtk_editable_set_editable (PGtkEditable(P), not TCustomEdit(AWinControl).ReadOnly);
gtk_widget_show_all(P);
Result := TLCLIntfHandle(P);
if result = 0 then exit;
gtk2WidgetSet.FinishComponentCreate(AWinControl, P);
p := gtk_entry_new();
gtk_editable_set_editable (PGtkEditable(P), not TCustomEdit(AWinControl).ReadOnly);
gtk_widget_show_all(P);
Result := TLCLIntfHandle(P);
{$IFDEF DebugLCLComponents}
DebugGtkWidgets.MarkCreated(p,dbgsName(AWinControl));
{$ENDIF}
gtk2WidgetSet.FinishComponentCreate(AWinControl, P);
end;
@ -1193,6 +1198,9 @@ begin
ACustomComboBox:=TCustomComboBox(AWinControl);
Box := gtk_event_box_new;
{$IFDEF DebugLCLComponents}
DebugGtkWidgets.MarkCreated(Box,dbgsName(AWinControl));
{$ENDIF}
WidgetInfo := CreateWidgetInfo(Box, AWinControl, AParams);

2
lcl/lclproc.pas
View File

@ -269,7 +269,7 @@ function ClassCase(const AClass: TClass; const ACase: array of TClass; const ADe
// MWE: define (missing) UTF16string similar to UTF8
// strictly spoken, a widestring <> utf16string
// todo: use it in exiting functions
// todo: use it in existing functions
type
UTF16String = type WideString;
PUTF16String = ^UTF16String;