paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-17 17:59:16 +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; procedure TDesignerDeviceContext.Restore;
begin begin
if FSavedDC<>0 then begin if FSavedDC<>0 then begin
FCanvas.Handle:=0;
RestoreDC(DC,FSavedDC); RestoreDC(DC,FSavedDC);
FSavedDC:=0; FSavedDC:=0;
FCanvas.Handle:=0;
end; end;
end; end;

13
lcl/dynhasharray.pp
View File

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

20
lcl/graphics.pp
View File

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

12
lcl/grids.pas
View File

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

81
lcl/include/canvas.inc
View File

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

29
lcl/include/font.inc
View File

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -502,7 +502,10 @@ begin
p:= PGtkWidget(Result); p:= PGtkWidget(Result);
if Result = 0 then exit; 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)^.hscrollbar, GTK_CAN_FOCUS);
GTK_WIDGET_UNSET_FLAGS(PGtkScrolledWindow(p)^.vscrollbar, GTK_CAN_FOCUS); GTK_WIDGET_UNSET_FLAGS(PGtkScrolledWindow(p)^.vscrollbar, GTK_CAN_FOCUS);
gtk_scrolled_window_set_policy(PGtkScrolledWindow(p), gtk_scrolled_window_set_policy(PGtkScrolledWindow(p),
@ -663,12 +666,14 @@ class function TGtk2WSCustomEdit.CreateHandle(const AWinControl: TWinControl;
var var
p: PGtkWidget; // ptr to the newly created GtkWidget p: PGtkWidget; // ptr to the newly created GtkWidget
begin begin
p := gtk_entry_new(); p := gtk_entry_new();
gtk_editable_set_editable (PGtkEditable(P), not TCustomEdit(AWinControl).ReadOnly); gtk_editable_set_editable (PGtkEditable(P), not TCustomEdit(AWinControl).ReadOnly);
gtk_widget_show_all(P); gtk_widget_show_all(P);
Result := TLCLIntfHandle(P); Result := TLCLIntfHandle(P);
if result = 0 then exit; {$IFDEF DebugLCLComponents}
gtk2WidgetSet.FinishComponentCreate(AWinControl, P); DebugGtkWidgets.MarkCreated(p,dbgsName(AWinControl));
{$ENDIF}
gtk2WidgetSet.FinishComponentCreate(AWinControl, P);
end; end;
@ -1193,6 +1198,9 @@ begin
ACustomComboBox:=TCustomComboBox(AWinControl); ACustomComboBox:=TCustomComboBox(AWinControl);
Box := gtk_event_box_new; Box := gtk_event_box_new;
{$IFDEF DebugLCLComponents}
DebugGtkWidgets.MarkCreated(Box,dbgsName(AWinControl));
{$ENDIF}
WidgetInfo := CreateWidgetInfo(Box, AWinControl, AParams); 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 // MWE: define (missing) UTF16string similar to UTF8
// strictly spoken, a widestring <> utf16string // strictly spoken, a widestring <> utf16string
// todo: use it in exiting functions // todo: use it in existing functions
type type
UTF16String = type WideString; UTF16String = type WideString;
PUTF16String = ^UTF16String; PUTF16String = ^UTF16String;