paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-06 02:18:03 +02:00
Code Issues Packages Projects Releases Wiki Activity
main
lazarus/lcl/interfaces/gtk/gtkdef.pp
Bad Sector 8f08573815 Fix Gtk 1.2 LCL backend. 
There are still some minor glitches, but the IDE and most examples i
tried seem to work fine.  Some examples didn't work but that seemed to
be mainly a Gtk 1.2 limitation (e.g. no rotating fonts).
2022-02-10 23:54:47 +00:00

830 lines
26 KiB
ObjectPascal
Raw Permalink Blame History

{ $Id$
------------------------------
gtkdef.pp - Type definitions
------------------------------
@created(Wed Jan 24st WET 2001)
@lastmod($Date$)
@author(Marc Weustink <marc@@lazarus.dommelstein.net>)
This unit contains type definitions needed in the GTK <-> LCL interface
*****************************************************************************
This file is part of the Lazarus Component Library (LCL)
See the file COPYING.modifiedLGPL.txt, included in this distribution,
for details about the license.
*****************************************************************************
}
unit GtkDef;
{$mode objfpc}
{$LONGSTRINGS ON}
interface
uses
{$IFDEF gtk2}
glib2, gdk2pixbuf, pango, gdk2, gtk2,
{$ELSE}
glib, gdk, gtk, gdkpixbuf,
{$ENDIF}
Classes, SysUtils, LCLIntf, LCLProc, LCLType, LCLMemManager, DynHashArray,
GraphType, GtkExtra, GtkGlobals;
{$ifdef TraceGdiCalls}
const
MaxTraces = 5;
MaxCallBacks = 11;
type
TCallBacksArray = array[0..MaxCallBacks] of Pointer;
PCallBacksArray = ^TCallBacksArray;
{$endif}
// styles -------------------------------------------------------------------
type
TLazGtkStyle = (
lgsGTK_Default, // without anything
lgsDefault, // with rc file
lgsButton,
lgsLabel,
lgsWindow,
lgsCheckbox,
lgsRadiobutton,
lgsMenu,
lgsMenuBar,
lgsMenuitem,
lgsList,
lgsVerticalScrollbar,
lgsHorizontalScrollbar,
lgsTooltip,
lgsVerticalPaned,
lgsHorizontalPaned,
lgsNotebook,
lgsStatusBar,
lgsHScale,
lgsVScale,
lgsGroupBox,
lgsTreeView, // for gtk2
lgsToolBar, // toolbar
lgsToolButton, // button placed on toolbar
lgsCalendar, // button placed on toolbar
lgsScrolledWindow,
// user defined
lgsUserDefined
);
const
LazGtkStyleNames: array[TLazGtkStyle] of string = (
'gtk_default',
'default',
'button',
'label',
'window',
'checkbox',
'radiobutton',
'menu',
'menubar',
'menuitem',
'list',
'vertical scrollbar',
'horizontal scrollbar',
'tooltip',
'vertical paned',
'horizontal paned',
'statusbar',
'notebook',
'hscale',
'vscale',
'groupbox',
'treeview',
'toolbar',
'toolbutton',
'calendar',
'scrolled window',
''
);
const
// drag target type for on drop files event invoking
FileDragTarget: TGtkTargetEntry = (target: 'text/uri-list'; flags: 0; info: 0;);
type
TGDIType = (gdiBitmap, gdiBrush, gdiFont, gdiPen, gdiRegion, gdiPalette);
TGDIBitmapType = (gbBitmap, gbPixmap, gbPixbuf);
TGtkDeviceContext = class;
{$IFDEF Gtk1}
TGtkIntfFont = PGDKFont;
{$ELSE}
TGtkIntfFont = PPangoLayout;
{$ENDIF}
PGDIRGB = ^TGDIRGB;
TGDIRGB = record
Red,
Green,
Blue: Byte;
end;
TGDIColorFlag = (cfColorAllocated);
TGDIColorFlags = set of TGDIColorFlag;
TGDIColor = record
ColorRef: TColorRef; //Color passed - can be a SYSCOLOR or RGB
ColorFlags: TGDIColorFlags;
Color: TGDKColor; //Actual GDK Color(If any) for use with GC's
Colormap: PGDKColormap; //Colormap GDKColor was allocated with
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; // see ReleaseGDIObject, ReferenceGDIObject
DCCount: integer; // number of DeviceContexts using this GDIObject
Shared: Boolean; // stock or system object which skips DeleteObject calls
Owner: TGtkDeviceContext;
{$ifdef TraceGdiCalls}
StackAddrs: TCallBacksArray;
{$endif}
Next: PGDIObject; // 'Next' is used by the internal mem manager
case GDIType: TGDIType of
gdiBitmap: (
Depth: integer;
SystemVisual : Boolean;
Visual : PGDKVisual;
Colormap : PGDKColormap;
case GDIBitmapType: TGDIBitmapType of
gbBitmap: (GDIBitmapObject: PGdkBitmap); // pixmap with depth 1
gbPixmap: (GDIPixmapObject: record // normal pixmap
Image: PGdkPixmap; // imagedata
Mask: PGdkBitmap; // the mask for images with 1 bit alpha and pixmap not supporting alpha
end);
gbPixbuf: (GDIPixbufObject: PGdkPixbuf);
);
gdiBrush: (
// ToDo: add bitmap mask
IsNullBrush: Boolean;
GDIBrushColor: TGDIColor;
GDIBrushFill: TGdkFill;
GDIBrushPixMap: PGdkPixmap;
);
gdiFont: (
GDIFontObject: TGtkIntfFont;
LogFont: TLogFont;// font info is stored as well, for later query font params
UnTransfFontHeight: Integer;
);
gdiPen: (
IsNullPen : Boolean;//GDK will bomb with a NULL Pen Hatch
IsExtPen: Boolean;
GDIPenColor: TGDIColor;
GDIPenWidth: DWord;
GDIPenStyle: DWord;
GDIPenDashes: Pgint8;
GDIPenDashesCount: DWord;
UnTransfPenWidth: DWord;
);
gdiRegion: (
GDIRegionObject: PGdkRegion;
{ ! Always without the DCOrigin
GDIObjects can exists without DCs and so they are independent
- When the DCOrigin is moved, the region is not moved automatically
- Any clipping operation must be mapped, *before* applying it to the
GDIRegionObject, and *after* reading it
}
);
gdiPalette: (
//Is this the system palette?
SystemPalette : Boolean;
//or, Has it been added to the system palette?
PaletteRealized: Boolean;
//Type of visual expected
VisualType: TGdkVisualType;
//Actual visual created
PaletteVisual: PGDKVisual;
//Colormap for mapping colors
PaletteColormap: PGDKColormap;
//For mapping from Index to RGB
RGBTable: TDynHashArray;
IndexTable: TDynHashArray;
);
end;
TDevContextTextMetric = record
lBearing: LongInt;
rBearing: LongInt;
TextMetric: TTextMetric;
IsDoubleByteChar: boolean;
IsMonoSpace: boolean;
end;
TDeviceContextsFlag = (
dcfPenSelected, // pen changed and needs selecting
dcfPenInvalid, // pen is not a valid GDIObject
dcfTextMetricsValid,
dcfDoubleBuffer // Drawable is a double buffer
);
TDeviceContextsFlags = set of TDeviceContextsFlag;
TDevContextsColorType = (
dccNone,
dccCurrentBackColor,
dccCurrentTextColor,
dccGDIBrushColor,
dccGDIPenColor
);
TDevContextSelectedColorsType = (
dcscCustom,
dcscPen,
dcscBrush,
dcscFont
);
{ TGtkDeviceContext }
TGtkDeviceContextClass = class of TGtkDeviceContext;
TGtkDeviceContext = class
private
FClipRegion: PGdiObject;
FCurrentBitmap: PGdiObject;
FCurrentBrush: PGdiObject;
FCurrentFont: PGdiObject;
FCurrentPalette: PGdiObject;
FCurrentPen: PGdiObject;
FGC: pgdkGC;
FGCValues: TGdkGCValues;
FHasTransf: Boolean; // is any viewport/affine transformation applied?
FDrawable: PGDKDrawable; // either the gdk_window of the owner
// or the gdk_bitmap/pixmap of the selected image
// or the double buffer (OriginalDrawable will hold the original)
FOriginalDrawable: PGDKDrawable; // only set if dcfDoubleBuffer in DCFlags
FWidget: PGtkWidget; // the owner (in case of a windowDC)
FWithChildWindows: boolean;// this DC covers sub gdkwindows
FOrigin: TPoint;
FSpecialOrigin: Boolean;
FFlags: TDeviceContextsFlags;
FSelectedColors: TDevContextSelectedColorsType;
FOwnedGDIObjects: array[TGDIType] of PGdiObject;
// viewport/affine transformations
FMapMode: Integer; // current viewport/window mapping mode
FViewPortExt: TPoint; // current viewport extent
FViewPortOrg: TPoint; // current viewport origin
FWindowExt: TPoint; // current window extent
function GetGDIObjects(ID: TGDIType): PGdiObject;
function GetOffset: TPoint;
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 SetMapMode(AValue: Integer);
procedure SetOwnedGDIObjects(ID: TGDIType; const AValue: PGdiObject);
procedure SetSelectedColors(AValue: TDevContextSelectedColorsType);
function GetGC: pgdkGC;
// winapi
function GetROP2: Integer;
procedure SetROP2(AROP: Integer);
procedure SetViewPortExt(const AValue: TPoint);
procedure SetViewPortOrg(const AValue: TPoint);
procedure SetWindowExt(const AValue: TPoint);
protected
function CreateGC: PGdkGC; virtual;
procedure CreateFont; virtual;
procedure CreateBrush; virtual;
procedure CreatePen; virtual;
procedure CreateBitmap; virtual;
// winapi
function SelectBitmap(AGdiObject: PGdiObject): PGdiObject; virtual;
function SelectPen(AGdiObject: PGdiObject): PGdiObject; virtual;
// viewport/affine transformations
procedure TransfUpdateFont; virtual;
procedure TransfUpdatePen; virtual;
// brushes not transformed!
public
{$ifdef TraceGdiCalls}
StackAddrs: TCallBacksArray;
{$endif}
PenPos: TPoint;
CurrentTextColor: TGDIColor;
CurrentBackColor: TGDIColor;
DCTextMetric: TDevContextTextMetric; // only valid if dcfTextMetricsValid set
PaintRectangle: TRect;// set during paint, BeginPaint/EndPaint
SavedContext: TGtkDeviceContext; // linked list of saved DCs
constructor Create; virtual;
procedure CreateGDIObject(AGDIType: TGDIType);
procedure SelectBrushProps; virtual;
procedure SelectTextProps; virtual;
procedure SelectPenProps; virtual;
procedure SelectRegion;
// device handles
procedure SetWidget(AWidget: PGtkWidget; AWindow: PGdkWindow;
AWithChildWindows: Boolean; ADoubleBuffer: PGdkDrawable = nil);
function HasGC: Boolean;
procedure ResetGCClipping;
procedure Clear;
function GetFont: PGdiObject;
function GetBrush: PGdiObject;
function GetPen: PGdiObject;
function GetBitmap: PGdiObject;
function GetFunction: TGdkFunction; virtual; abstract;
function IsNullBrush: boolean;
function IsNullPen: boolean;
function SelectObject(AGdiObject: PGdiObject): PGdiObject;
procedure SetTextMetricsValid(AValid: Boolean); // temp helper, to allow flag manipulation
// viewport/affine transformations
procedure InvTransfPoint(var X1, Y1: Integer);
function InvTransfPointIndirect(const P: TPoint): TPoint; // point can be const
procedure InvTransfRect(var X1, Y1, X2, Y2: Integer);
function InvTransfRectIndirect(const R: TRect): TRect; // rect can be const
procedure InvTransfExtent(var ExtX, ExtY: Integer);
function InvTransfExtentIndirect(const Extent: TPoint): TPoint; // extent can be const
procedure TransfAngles(var Angle1, Angle2: Integer);
procedure TransfNormalize(var Lower, Higher: Integer);
procedure TransfPoint(var X1, Y1: Integer);
function TransfPointIndirect(const P: TPoint): TPoint; // point can be const
procedure TransfRect(var X1, Y1, X2, Y2: Integer);
function TransfRectIndirect(const R: TRect): TRect; // rect can be const
procedure TransfExtent(var ExtX, ExtY: Integer);
function TransfExtentIndirect(const Extent: TPoint): TPoint; // extent can be const
// help functions
function CopyDataFrom(ASource: TGtkDeviceContext; AClearSource, AMoveGDIOwnerShip, ARestore: Boolean): Boolean;
function FillRect(ARect: TRect; ABrush: HBrush; SkipRop: Boolean): Boolean;
// origins
property Origin: TPoint read FOrigin write FOrigin;
property Offset: TPoint read GetOffset;
// drawing settings
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 GCValues: TGdkGCValues read FGCValues;
property GDIObjects[ID: TGDIType]: PGdiObject read GetGDIObjects write SetGDIObjects;
// viewport/window and affine transformations
property HasTransf: Boolean read FHasTransf;
property MapMode: Integer read FMapMode write SetMapMode;
property ViewPortExt: TPoint read FViewPortExt write SetViewPortExt;
property ViewPortOrg: TPoint read FViewPortOrg write SetViewPortOrg;
property WindowExt: TPoint read FWindowExt write SetWindowExt;
// control
property SelectedColors: TDevContextSelectedColorsType read FSelectedColors write SetSelectedColors;
property Flags: TDeviceContextsFlags read FFlags write FFlags;
property OwnedGDIObjects[ID: TGDIType]: PGdiObject read GetOwnedGDIObjects write SetOwnedGDIObjects;
property Drawable: PGDKDrawable read FDrawable;
property Widget: PGtkWidget read FWidget; // the owner
property GC: pgdkGC read GetGC write FGC;
property WithChildWindows: Boolean read FWithChildWindows;
// winapi
property ROP2: Integer read GetRop2 write SetRop2;
end;
// memory system for TDeviceContext(s) ---------------------------------------------
{ TDeviceContextMemManager }
TDeviceContextMemManager = class(TLCLMemManager)
private
FDeviceContextClass: TGtkDeviceContextClass;
protected
procedure FreeFirstItem; override;
public
constructor Create(AClass: TGtkDeviceContextClass);
procedure DisposeDeviceContext(ADeviceContext: TGtkDeviceContext);
function NewDeviceContext: TGtkDeviceContext;
end;
TWidgetInfoFlag = (
wwiNotOnParentsClientArea,
wwiValidQueuedEvent, // Mark this widgetinfo as valid queued proc
// see gtkwsmenus.pp: gtkWSPopupMenuDeactivate
wwiDeactivating, // during gtk deactivate
wwiActivating, // during gtk activate
wwiNoEraseBkgnd, // erase background is disabled for widget
wwiInvalidEvent // special mark for widgetinfo
// see gtkchanged_editbox and
// gtkchanged_editbox_backspace in gtkcallback.inc
);
TWidgetInfoFlags = set of TWidgetInfoFlag;
tGtkStateEnumRange = 0..31;
tGtkStateEnum = set of tGtkStateEnumRange;
// Info needed by the API of a HWND (=Widget)
PWidgetInfo = ^TWidgetInfo;
TWidgetInfo = record
LCLObject: TObject; // the object which created this widget
ClientWidget: PGTKWidget; // the widget which contains the childwidgets
// used to be "fixed" or "core-child"
CoreWidget: PGTKWidget; // the widget which implements the main functionality
// For a TListBox the GTKList is the CoreWidget
// and the scrollbox around it is the handle
// So in most cases handle = CoreWidget
UpdateRect: TRect; // used by LM_Paint, beginpaint etc
WndProc: Integer; // window data
Style: Integer;
ExStyle: Integer;
EventMask: TGdkEventMask;
DoubleBuffer: PGdkPixmap;
ControlCursor: HCursor; // current widget cursor
DefaultCursor: HCursor; // default widget cursor
Flags: TWidgetInfoFlags;
ChangeLock: Integer; // lock events
PaintDepth: integer; // increased/decreased by Begin/EndPaint
DataOwner: Boolean; // Set if the UserData should be freed when the info is freed
UserData: Pointer;
FormBorderStyle: Integer; // used only by forms
{$IFDEF GTK2}
FormWindowState: TGdkEventWindowState; // used only by forms to stop infinite loops eg. issue #16505
{$ENDIF}
end;
//TODO: remove
PWinWidgetInfo = ^TWidgetInfo;
TWinWidgetInfo = TWidgetInfo;
//--
const
GdkTrue = {$IFDEF Gtk2}true{$ELSE}1{$ENDIF};
GdkFalse = {$IFDEF Gtk2}false{$ELSE}0{$ENDIF};
GTK_STYLE_BASE = 20;// see GTK_STATE_NORMAL..GTK_STATE_INSENSITIVE,
GTK_STYLE_TEXT = 21;// see tGtkStateEnum, and see TGtkWidgetSet.SetWidgetColor
type
TGdkPixBufBuffer = {$IFDEF Gtk2}Pguchar{$ELSE}PChar{$ENDIF};
{$IFDEF GTK2}
const
GDK_VOIDSYMBOL = $FFFFFF;
{$ENDIF}
// MWE: All the IFDEFs for GTK2 annoyed me so I defined all (most) constants here
{$IFNDEF GTK2}
{$I gtkkeysyms.inc}
{$ENDIF}
// MWE:
// Additional GDK_KEY_xxx definitions, not defined in GDK. Since GDK (on Linux)
// simply passes the X vvalue I definde those extra here as GDKX_KEY_xxx
// I don't know what the values are in win32 so I assume the same
// Original source: /usr/X11R6/include/X11/XF86keysym.h
// Keys found on some "Internet" keyboards.
const
GDKX_KEY_Standby = $1008FF10;
GDKX_KEY_AudioLowerVolume = $1008FF11;
GDKX_KEY_AudioMute = $1008FF12;
GDKX_KEY_AudioRaiseVolume = $1008FF13;
GDKX_KEY_AudioPlay = $1008FF14;
GDKX_KEY_AudioStop = $1008FF15;
GDKX_KEY_AudioPrev = $1008FF16;
GDKX_KEY_AudioNext = $1008FF17;
GDKX_KEY_HomePage = $1008FF18;
GDKX_KEY_Mail = $1008FF19;
GDKX_KEY_Start = $1008FF1A;
GDKX_KEY_Search = $1008FF1B;
GDKX_KEY_AudioRecord = $1008FF1C;
// These are sometimes found on PDA's (e.g. Palm, PocketPC or elsewhere)
GDKX_KEY_Calculator = $1008FF1D;
GDKX_KEY_Memo = $1008FF1E;
GDKX_KEY_ToDoList = $1008FF1F;
GDKX_KEY_Calendar = $1008FF20;
GDKX_KEY_PowerDown = $1008FF21;
GDKX_KEY_ContrastAdjust = $1008FF22;
GDKX_KEY_RockerUp = $1008FF23;
GDKX_KEY_RockerDown = $1008FF24;
GDKX_KEY_RockerEnter = $1008FF25;
// Some more "Internet" keyboard symbols
GDKX_KEY_Back = $1008FF26;
GDKX_KEY_Forward = $1008FF27;
GDKX_KEY_Stop = $1008FF28;
GDKX_KEY_Refresh = $1008FF29;
GDKX_KEY_PowerOff = $1008FF2A;
GDKX_KEY_WakeUp = $1008FF2B;
GDKX_KEY_Eject = $1008FF2C;
GDKX_KEY_ScreenSaver = $1008FF2D;
GDKX_KEY_WWW = $1008FF2E;
GDKX_KEY_Sleep = $1008FF2F;
GDKX_KEY_Favorites = $1008FF30;
GDKX_KEY_AudioPause = $1008FF31;
GDKX_KEY_AudioMedia = $1008FF32;
GDKX_KEY_MyComputer = $1008FF33;
GDKX_KEY_VendorHome = $1008FF34;
GDKX_KEY_LightBulb = $1008FF35;
GDKX_KEY_Shop = $1008FF36;
GDKX_KEY_History = $1008FF37;
GDKX_KEY_OpenURL = $1008FF38;
GDKX_KEY_AddFavorite = $1008FF39;
GDKX_KEY_HotLinks = $1008FF3A;
GDKX_KEY_BrightnessAdjust = $1008FF3B;
GDKX_KEY_Finance = $1008FF3C;
GDKX_KEY_Community = $1008FF3D;
GDKX_KEY_Launch0 = $1008FF40;
GDKX_KEY_Launch1 = $1008FF41;
GDKX_KEY_Launch2 = $1008FF42;
GDKX_KEY_Launch3 = $1008FF43;
GDKX_KEY_Launch4 = $1008FF44;
GDKX_KEY_Launch5 = $1008FF45;
GDKX_KEY_Launch6 = $1008FF46;
GDKX_KEY_Launch7 = $1008FF47;
GDKX_KEY_Launch8 = $1008FF48;
GDKX_KEY_Launch9 = $1008FF49;
GDKX_KEY_LaunchA = $1008FF4A;
GDKX_KEY_LaunchB = $1008FF4B;
GDKX_KEY_LaunchC = $1008FF4C;
GDKX_KEY_LaunchD = $1008FF4D;
GDKX_KEY_LaunchE = $1008FF4E;
GDKX_KEY_LaunchF = $1008FF4F;
function InternalNewPGDIObject: PGDIObject;
procedure InternalDisposePGDIObject(GDIObject: PGdiObject);
type
TReferenceGDIObject = procedure(GDIObject: PGdiObject) of object;
TReleaseGDIObject = function(GDIObject: PGdiObject): boolean of object;
var
ReleaseGDIObject: TReleaseGDIObject; // see TGtkWidgetSet.ReleaseGDIObject
ReferenceGDIObject: TReferenceGDIObject; // see TGtkWidgetSet.ReferenceGDIObject
{$IFDEF DebugLCLComponents}
var
DebugGtkWidgets: TDebugLCLItems = nil;
DebugGdiObjects: TDebugLCLItems = nil;
DebugDeviceContexts: TDebugLCLItems = nil;
{$ENDIF}
procedure GtkDefDone;
function dbgs(g: TGDIType): string; overload;
function dbgs(const r: TGDKRectangle): string; overload;
function dbgs(r: PGDKRectangle): string; overload;
implementation
uses
// until all code is transfered to objects, these circles are needed;
gtkint, gtkproc, GtkFontCache, GTKWinApiWindow, LazUtilities;
{$IFOpt R+}{$Define RangeChecksOn}{$Endif}
{$i gtkdevicecontext.inc}
// memory system for PGDIObject(s) ---------------------------------------------
type
TGDIObjectMemManager = class(TLCLMemManager)
protected
procedure FreeFirstItem; override;
public
procedure DisposeGDIObjectMem(AGDIObject: PGDIObject);
function NewGDIObjectMem: PGDIObject;
end;
const
GDIObjectMemManager: TGDIObjectMemManager = nil;
function InternalNewPGDIObject: PGDIObject;
begin
if GDIObjectMemManager=nil then begin
GDIObjectMemManager:=TGDIObjectMemManager.Create;
GDIObjectMemManager.MinimumFreeCount:=1000;
end;
Result:=GDIObjectMemManager.NewGDIObjectMem;
{$IFDEF DebugLCLComponents}
DebugGdiObjects.MarkCreated(Result,'NewPGDIObject');
{$ENDIF}
end;
procedure InternalDisposePGDIObject(GDIObject: PGdiObject);
begin
{$IFDEF DebugLCLComponents}
DebugGdiObjects.MarkDestroyed(GDIObject);
{$ENDIF}
GDIObjectMemManager.DisposeGDIObjectMem(GDIObject);
end;
{ TGDIObjectMemManager }
procedure TGDIObjectMemManager.FreeFirstItem;
var AGDIObject: PGDIObject;
begin
AGDIObject:=PGDIObject(FFirstFree);
PGDIObject(FFirstFree):=AGDIObject^.Next;
Dispose(AGDIObject);
//DebugLn('TGDIObjectMemManager.DisposeGDIObject A FFreedCount=',FFreedCount);
{$R-}
inc(FFreedCount);
{$IfDef RangeChecksOn}{$R+}{$Endif}
end;
procedure TGDIObjectMemManager.DisposeGDIObjectMem(AGDIObject: PGDIObject);
begin
//DebugLn('TGDIObjectMemManager.DisposeGDIObjectMem ',DbgS(AGDIObject));
if AGDIObject^.RefCount<>0 then
RaiseGDBException('');
if (FFreeCount<FMinFree) or (FFreeCount<((FCount shr 3)*FMaxFreeRatio)) then
begin
// add AGDIObject to Free list
AGDIObject^.Next:=PGDIObject(FFirstFree);
PGDIObject(FFirstFree):=AGDIObject;
inc(FFreeCount);
end else begin
// free list full -> free the ANode
Dispose(AGDIObject);
//DebugLn('TGDIObjectMemManager.DisposeGDIObjectMem B FFreedCount=',FFreedCount);
{$R-}
inc(FFreedCount);
{$IfDef RangeChecksOn}{$R+}{$Endif}
end;
dec(FCount);
end;
function TGDIObjectMemManager.NewGDIObjectMem: PGDIObject;
begin
if FFirstFree<>nil then begin
// take from free list
Result:=PGDIObject(FFirstFree);
PGDIObject(FFirstFree):=Result^.Next;
dec(FFreeCount);
end else begin
// free list empty -> create new node
New(Result);
// DebugLn('TGDIObjectMemManager.NewGDIObjectMem FAllocatedCount=',FAllocatedCount);
{$R-}
inc(FAllocatedCount);
{$IfDef RangeChecksOn}{$R+}{$Endif}
end;
FillChar(Result^, SizeOf(TGDIObject), 0);
inc(FCount);
//DebugLn('TGDIObjectMemManager.NewGDIObjectMem ',DbgS(Result));
end;
{ TDeviceContextMemManager }
procedure TDeviceContextMemManager.FreeFirstItem;
var ADeviceContext: TGtkDeviceContext;
begin
ADeviceContext:=TGtkDeviceContext(FFirstFree);
TGtkDeviceContext(FFirstFree):=ADeviceContext.SavedContext;
//DebugLn('TDeviceContextMemManager.FreeFirstItem FFreedCount=',FFreedCount);
ADeviceContext.Free;
{$R-}
inc(FFreedCount);
{$IfDef RangeChecksOn}{$R+}{$Endif}
end;
constructor TDeviceContextMemManager.Create(AClass: TGtkDeviceContextClass);
begin
inherited Create;
FDeviceContextClass := AClass;
end;
procedure TDeviceContextMemManager.DisposeDeviceContext(
ADeviceContext: TGtkDeviceContext);
begin
if (FFreeCount<FMinFree) or (FFreeCount<((FCount shr 3)*FMaxFreeRatio))
then begin
// add ADeviceContext to Free list
ADeviceContext.SavedContext:=TGtkDeviceContext(FFirstFree);
TGtkDeviceContext(FFirstFree):=ADeviceContext;
inc(FFreeCount);
end
else begin
// free list full -> free the ANode
//DebugLn('TDeviceContextMemManager.DisposeDeviceContext FFreedCount=',FFreedCount);
ADeviceContext.Free;
{$R-}
inc(FFreedCount);
{$IfDef RangeChecksOn}{$R+}{$Endif}
end;
dec(FCount);
end;
function TDeviceContextMemManager.NewDeviceContext: TGtkDeviceContext;
begin
if FFirstFree <> nil
then begin
// take from free list
Result := TGtkDeviceContext(FFirstFree);
TGtkDeviceContext(FFirstFree) := Result.SavedContext;
Dec(FFreeCount);
Result.Clear;
end
else begin
// free list empty -> create new node
Result := FDeviceContextClass.Create;
//DebugLn('TDeviceContextMemManager.NewDeviceContext FAllocatedCount=',FAllocatedCount);
{$R-}
inc(FAllocatedCount);
{$IfDef RangeChecksOn}{$R+}{$Endif}
end;
Inc(FCount);
end;
//------------------------------------------------------------------------------
procedure GtkDefInit;
begin
{$IFDEF DebugLCLComponents}
DebugGtkWidgets:=TDebugLCLItems.Create;
DebugGdiObjects:=TDebugLCLItems.Create;
DebugDeviceContexts:=TDebugLCLItems.Create;
{$ENDIF}
end;
procedure GtkDefDone;
begin
GDIObjectMemManager.Free;
GDIObjectMemManager:=nil;
{$IFDEF DebugLCLComponents}
FreeAndNil(DebugGtkWidgets);
FreeAndNil(DebugGdiObjects);
FreeAndNil(DebugDeviceContexts);
{$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;
function dbgs(const r: TGDKRectangle): string;
begin
Result:=dbgs(Bounds(r.x,r.y,r.width,r.height));
end;
function dbgs(r: PGDKRectangle): string;
begin
if r=nil then
Result:='nil'
else
Result:=dbgs(r^);
end;
initialization
GtkDefInit;
finalization
end.
Reference in New Issue View Git Blame Copy Permalink