1{ $Id$
2                         -------------------------------
3                         gtk2def.pp  -  Type definitions
4                         -------------------------------
5
6 @created(Tue Nov 20st WET 2007)
7 @lastmod($Date$)
8 @author(Marc Weustink <marc@@dommelstein.net>)
9
10 This unit contains type definitions needed in the GTK2 <-> LCL interface
11
12 *****************************************************************************
13  This file is part of the Lazarus Component Library (LCL)
14
15  See the file COPYING.modifiedLGPL.txt, included in this distribution,
16  for details about the license.
17 *****************************************************************************
18}
19
20
21unit Gtk2Def;
22
23{$mode objfpc} {$H+}
24
25interface
26
27uses
28  // RTL
29  Classes, SysUtils, glib2, gdk2pixbuf, pango, gdk2, gtk2,
30  // LazUtils
31  GraphType, DynHashArray, LazLoggerBase, LazTracer, LazUtilities,
32  // LCL
33  Gtk2Extra, Gtk2Globals,
34  LCLIntf, LCLType, LCLMemManager, Graphics {for TColor};
35
36{$ifdef TraceGdiCalls}
37const
38  MaxTraces    = 5;
39  MaxCallBacks = 11;
40type
41  TCallBacksArray = array[0..MaxCallBacks] of Pointer;
42  PCallBacksArray = ^TCallBacksArray;
43{$endif}
44
45// styles -------------------------------------------------------------------
46type
47  TLazGtkStyle = (
48    lgsGTK_Default, // without anything
49    lgsDefault,     // with rc file
50    lgsButton,
51    lgsLabel,
52    lgsWindow,
53    lgsCheckbox,
54    lgsRadiobutton,
55    lgsMenu,
56    lgsMenuBar,
57    lgsMenuitem,
58    lgsList,
59    lgsVerticalScrollbar,
60    lgsHorizontalScrollbar,
61    lgsTooltip,
62    lgsVerticalPaned,
63    lgsHorizontalPaned,
64    lgsNotebook,
65    lgsStatusBar,
66    lgsHScale,
67    lgsVScale,
68    lgsGroupBox,
69    lgsTreeView,      // for gtk2
70    lgsToolBar,       // toolbar
71    lgsToolButton,    // button placed on toolbar
72    lgsCalendar,      // button placed on toolbar
73    lgsScrolledWindow,
74    lgsComboBox,
75    // user defined
76    lgsUserDefined
77    );
78
79const
80  LazGtkStyleNames: array[TLazGtkStyle] of string = (
81    'gtk_default',
82    'default',
83    'button',
84    'label',
85    'window',
86    'checkbox',
87    'radiobutton',
88    'menu',
89    'menubar',
90    'menuitem',
91    'list',
92    'vertical scrollbar',
93    'horizontal scrollbar',
94    'tooltip',
95    'vertical paned',
96    'horizontal paned',
97    'notebook',
98    'statusbar',
99    'hscale',
100    'vscale',
101    'groupbox',
102    'treeview',
103    'toolbar',
104    'toolbutton',
105    'calendar',
106    'scrolled window',
107    'combobox',
108    ''
109    );
110
111
112const
113  // drag target type for on drop files event invoking
114  FileDragTarget: TGtkTargetEntry = (target: 'text/uri-list'; flags: 0; info: 0;);
115
116type
117  TGDIType = (gdiBitmap, gdiBrush, gdiFont, gdiPen, gdiRegion, gdiPalette);
118  TGDIBitmapType = (gbBitmap, gbPixmap, gbPixbuf);
119
120  TGtkDeviceContext = class;
121
122  TGtkIntfFont = PPangoLayout;
123
124  PGDIRGB = ^TGDIRGB;
125  TGDIRGB = record
126    Red,
127    Green,
128    Blue: Byte;
129  end;
130
131  TGDIColorFlag = (cfColorAllocated);
132  TGDIColorFlags = set of TGDIColorFlag;
133
134  TGDIColor = record
135    ColorRef: TColorRef;    //Color passed - can be a SYSCOLOR or RGB
136    ColorFlags: TGDIColorFlags;
137    Color: TGDKColor;       //Actual GDK Color(If any) for use with GC's
138    Colormap: PGDKColormap; //Colormap GDKColor was allocated with
139  end;
140  PGDIColor = ^TGDIColor;
141
142  { Create a GDIObject with NewGDIObject. Then RefCount is 1.
143    Free a GDIObject with DeleteObject. This will decrease the RefCount
144    and when 0 calls DisposeGDIObject. }
145  PGDIObject = ^TGDIObject;
146  TGDIObject = record
147    RefCount: integer; // see ReleaseGDIObject, ReferenceGDIObject
148    DCCount: integer; // number of DeviceContexts using this GDIObject
149    Shared: Boolean; // stock or system object which skips DeleteObject calls
150    Owner: TGtkDeviceContext;
151    {$ifdef TraceGdiCalls}
152    StackAddrs: TCallBacksArray;
153    {$endif}
154    Next: PGDIObject; // 'Next' is used by the internal mem manager
155    case GDIType: TGDIType of
156      gdiBitmap: (
157        Depth: integer;
158        SystemVisual : Boolean;
159        Visual : PGDKVisual;
160        Colormap : PGDKColormap;
161        case GDIBitmapType: TGDIBitmapType of
162          gbBitmap: (GDIBitmapObject: PGdkBitmap); // pixmap with depth 1
163          gbPixmap: (GDIPixmapObject: record // normal pixmap
164                      Image: PGdkPixmap;     // imagedata
165                      Mask: PGdkBitmap;      // the mask for images with 1 bit alpha and pixmap not supporting alpha
166                    end);
167          gbPixbuf: (GDIPixbufObject: PGdkPixbuf);
168      );
169      gdiBrush: (
170        // ToDo: add bitmap mask
171        IsNullBrush: Boolean;
172        GDIBrushColor: TGDIColor;
173        GDIBrushFill: TGdkFill;
174        GDIBrushPixMap: PGdkPixmap;
175      );
176      gdiFont: (
177        GDIFontObject: TGtkIntfFont;
178        LogFont: TLogFont;// font info is stored as well, for later query font params
179        UnTransfFontHeight: Integer;
180      );
181      gdiPen: (
182        IsNullPen : Boolean;//GDK will bomb with a NULL Pen Hatch
183        IsExtPen: Boolean;
184        GDIPenColor: TGDIColor;
185        GDIPenWidth: DWord;
186        GDIPenStyle: DWord;
187        GDIPenDashes: Pgint8;
188        GDIPenDashesCount: DWord;
189        UnTransfPenWidth: DWord;
190      );
191      gdiRegion: (
192        GDIRegionObject: PGdkRegion;
193          { ! Always without the DCOrigin
194            GDIObjects can exists without DCs and so they are independent
195
196            - When the DCOrigin is moved, the region is not moved automatically
197            - Any clipping operation must be mapped, *before* applying it to the
198              GDIRegionObject, and *after* reading it
199          }
200      );
201      gdiPalette: (
202        //Is this the system palette?
203        SystemPalette : Boolean;
204
205        //or, Has it been added to the system palette?
206        PaletteRealized: Boolean;
207
208        //Type of visual expected
209        VisualType: TGdkVisualType;
210
211        //Actual visual created
212        PaletteVisual: PGDKVisual;
213
214        //Colormap for mapping colors
215        PaletteColormap: PGDKColormap;
216
217        //For mapping from Index to RGB
218        RGBTable: TDynHashArray;
219        IndexTable: TDynHashArray;
220      );
221  end;
222
223  TDevContextTextMetric = record
224    lBearing: LongInt;
225    rBearing: LongInt;
226    TextMetric: TTextMetric;
227    IsDoubleByteChar: boolean;
228    IsMonoSpace: boolean;
229  end;
230
231  TDeviceContextsFlag = (
232    dcfPenSelected, // pen changed and needs selecting
233    dcfPenInvalid,  // pen is not a valid GDIObject
234    dcfTextMetricsValid,
235    dcfDoubleBuffer  // Drawable is a double buffer
236    );
237  TDeviceContextsFlags = set of TDeviceContextsFlag;
238
239  TDevContextsColorType = (
240    dccNone,
241    dccCurrentBackColor,
242    dccCurrentTextColor,
243    dccGDIBrushColor,
244    dccGDIPenColor
245    );
246
247  TDevContextSelectedColorsType = (
248    dcscCustom,
249    dcscPen,
250    dcscBrush,
251    dcscFont
252    );
253
254
255  { TGtkDeviceContext }
256
257
258  TGtkDeviceContextClass = class of TGtkDeviceContext;
259  TGtkDeviceContext = class
260  private
261    FClipRegion: PGdiObject;
262    FCurrentBitmap: PGdiObject;
263    FCurrentBrush: PGdiObject;
264    FCurrentFont: PGdiObject;
265    FCurrentPalette: PGdiObject;
266    FCurrentPen: PGdiObject;
267    FGC: pgdkGC;
268    FGCValues: TGdkGCValues;
269
270    FHasTransf: Boolean; // is any viewport/affine transformation applied?
271
272    FDrawable: PGDKDrawable; // either the gdk_window of the owner
273                             // or the gdk_bitmap/pixmap of the selected image
274                             // or the double buffer (OriginalDrawable will hold the original)
275
276    FPixbuf: PGdkPixbuf;     // pixbuf reference for when the drawable comes from a pixbuf
277
278    FOriginalDrawable: PGDKDrawable; // only set if dcfDoubleBuffer in DCFlags
279
280    FWidget: PGtkWidget;     // the owner (in case of a windowDC)
281
282    FWithChildWindows: boolean;// this DC covers sub gdkwindows
283
284    FFlags: TDeviceContextsFlags;
285    FSelectedColors: TDevContextSelectedColorsType;
286
287    FOwnedGDIObjects: array[TGDIType] of PGdiObject;
288
289    // viewport/affine transformations
290    FMapMode: Integer; // current viewport/window mapping mode
291    FViewPortExt: TPoint; // current viewport extent
292    FViewPortOrg: TPoint; // current viewport origin
293    FWindowExt: TPoint; // current window extent
294    FWindowOrg: TPoint; // current window origin
295
296    function GetClipRectangle: TGdkRectangle;
297    function GetGDIObjects(ID: TGDIType): PGdiObject;
298    function GetOffset: TPoint;
299    function GetOwnedGDIObjects(ID: TGDIType): PGdiObject;
300    procedure SetClipRegion(const AValue: PGdiObject);
301    procedure SetCurrentBitmap(const AValue: PGdiObject);
302    procedure SetCurrentBrush(const AValue: PGdiObject);
303    procedure SetCurrentFont(const AValue: PGdiObject);
304    procedure SetCurrentPalette(const AValue: PGdiObject);
305    procedure SetCurrentPen(const AValue: PGdiObject);
306    procedure ChangeGDIObject(var GDIObject: PGdiObject;
307                              const NewValue: PGdiObject);
308    procedure SetGDIObjects(ID: TGDIType; const AValue: PGdiObject);
309    procedure SetMapMode(AValue: Integer);
310    procedure SetOwnedGDIObjects(ID: TGDIType; const AValue: PGdiObject);
311    procedure SetSelectedColors(AValue: TDevContextSelectedColorsType);
312
313    function GetGC: pgdkGC;
314
315    // winapi
316    function  GetROP2: Integer;
317    procedure SetROP2(AROP: Integer);
318    procedure SetViewPortExt(const AValue: TPoint);
319    procedure SetViewPortOrg(const AValue: TPoint);
320    procedure SetWindowExt(const AValue: TPoint);
321    procedure SetWindowOrg(AValue: TPoint);
322  protected
323    function CreateGC: PGdkGC; virtual;
324
325    procedure CreateFont; virtual;
326    procedure CreateBrush; virtual;
327    procedure CreatePen; virtual;
328    procedure CreateBitmap; virtual;
329
330    // winapi
331    function SelectBitmap(AGdiObject: PGdiObject): PGdiObject; virtual;
332    function SelectPen(AGdiObject: PGdiObject): PGdiObject; virtual;
333
334    // viewport/affine transformations
335    procedure TransfUpdateFont; virtual;
336    procedure TransfUpdatePen; virtual;
337    // brushes not transformed!
338  public
339    {$ifdef TraceGdiCalls}
340    StackAddrs: TCallBacksArray;
341    {$endif}
342    PenPos: TPoint;
343    BkMode: Integer;
344    CurrentTextColor: TGDIColor;
345    CurrentBackColor: TGDIColor;
346    DCTextMetric: TDevContextTextMetric; // only valid if dcfTextMetricsValid set
347    PaintRectangle: TRect;// set during paint, BeginPaint/EndPaint
348    SavedContext: TGtkDeviceContext; // linked list of saved DCs
349    Antialiasing: Boolean;
350
351    constructor Create; virtual;
352    destructor Destroy; override;
353    procedure CreateGDIObject(AGDIType: TGDIType);
354    procedure SelectBrushProps; virtual;
355    procedure SelectTextProps; virtual;
356    procedure SelectPenProps; virtual;
357    procedure SelectRegion;
358    // device handles
359    procedure SetWidget(AWidget: PGtkWidget; AWindow: PGdkWindow;
360                        AWithChildWindows: Boolean; ADoubleBuffer: PGdkDrawable = nil);
361    function HasGC: Boolean;
362    procedure ResetGCClipping;
363    procedure Clear;
364    function GetFont: PGdiObject;
365    function GetBrush: PGdiObject;
366    function GetPen: PGdiObject;
367    function GetBitmap: PGdiObject;
368    function GetFunction: TGdkFunction;
369    function IsNullBrush: boolean;
370    function IsNullPen: boolean;
371    function SelectObject(AGdiObject: PGdiObject): PGdiObject;
372    procedure SetTextMetricsValid(AValid: Boolean); // temp helper, to allow flag manipulation
373    procedure RemovePixbuf; // called to remove the stored pixbuf (because, f.e., the pixmap was modified)
374
375    // viewport/affine transformations
376    procedure InvTransfPoint(var X1, Y1: Integer);
377    function InvTransfPointIndirect(const P: TPoint): TPoint; // point can be const
378    procedure InvTransfRect(var X1, Y1, X2, Y2: Integer);
379    function InvTransfRectIndirect(const R: TRect): TRect; // rect can be const
380    procedure InvTransfExtent(var ExtX, ExtY: Integer);
381    function InvTransfExtentIndirect(const Extent: TPoint): TPoint; // extent can be const
382    procedure TransfAngles(var Angle1, Angle2: Integer);
383    procedure TransfNormalize(var Lower, Higher: Integer);
384    procedure TransfPoint(var X1, Y1: Integer);
385    function TransfPointIndirect(const P: TPoint): TPoint; // point can be const
386    procedure TransfRect(var X1, Y1, X2, Y2: Integer);
387    function TransfRectIndirect(const R: TRect): TRect; // rect can be const
388    procedure TransfExtent(var ExtX, ExtY: Integer);
389    function TransfExtentIndirect(const Extent: TPoint): TPoint; // extent can be const
390
391    // help functions
392    function CopyDataFrom(ASource: TGtkDeviceContext; AClearSource, AMoveGDIOwnerShip, ARestore: Boolean): Boolean;
393    function FillRect(ARect: TRect; ABrush: HBrush; SkipRop: Boolean): Boolean;
394    procedure DrawTextWithColors(AText: PChar; ALength: LongInt; X, Y: Integer; FGColor, BGColor: PGdkColor);
395
396    // device origin
397    property Offset: TPoint read GetOffset;
398    // drawing settings
399    property CurrentBitmap: PGdiObject read FCurrentBitmap write SetCurrentBitmap;
400    property CurrentFont: PGdiObject read FCurrentFont write SetCurrentFont;
401    property CurrentPen: PGdiObject read FCurrentPen write SetCurrentPen;
402    property CurrentBrush: PGdiObject read FCurrentBrush write SetCurrentBrush;
403    property CurrentPalette: PGdiObject read FCurrentPalette write SetCurrentPalette;
404    property ClipRect: TGdkRectangle read GetClipRectangle;
405    property ClipRegion: PGdiObject read FClipRegion write SetClipRegion;
406    property GCValues: TGdkGCValues read FGCValues;
407    property GDIObjects[ID: TGDIType]: PGdiObject read GetGDIObjects write SetGDIObjects;
408    // viewport/window and affine transformations
409    property HasTransf: Boolean read FHasTransf;
410    property MapMode: Integer read FMapMode write SetMapMode;
411    property ViewPortExt: TPoint read FViewPortExt write SetViewPortExt;
412    property ViewPortOrg: TPoint read FViewPortOrg write SetViewPortOrg;
413    property WindowExt: TPoint read FWindowExt write SetWindowExt;
414    property WindowOrg: TPoint read FWindowOrg write SetWindowOrg;
415    // control
416    property SelectedColors: TDevContextSelectedColorsType read FSelectedColors write SetSelectedColors;
417    property Flags: TDeviceContextsFlags read FFlags write FFlags;
418    property OwnedGDIObjects[ID: TGDIType]: PGdiObject read GetOwnedGDIObjects write SetOwnedGDIObjects;
419    property Drawable: PGDKDrawable read FDrawable;
420    property Pixbuf: PGdkPixbuf read FPixbuf;
421    property Widget: PGtkWidget read FWidget; // the owner
422    property GC: pgdkGC read GetGC write FGC;
423    property WithChildWindows: Boolean read FWithChildWindows;
424    // winapi
425    property ROP2: Integer read GetRop2 write SetRop2;
426  end;
427
428  // memory system for TDeviceContext(s) ---------------------------------------------
429
430  { TDeviceContextMemManager }
431
432  TDeviceContextMemManager = class(TLCLMemManager)
433  private
434    FDeviceContextClass: TGtkDeviceContextClass;
435  protected
436    procedure FreeFirstItem; override;
437  public
438    constructor Create(AClass: TGtkDeviceContextClass);
439    procedure DisposeDeviceContext(ADeviceContext: TGtkDeviceContext);
440    function NewDeviceContext: TGtkDeviceContext;
441  end;
442
443
444  TWidgetInfoFlag = (
445    wwiNotOnParentsClientArea,
446    wwiValidQueuedEvent,              // Mark this widgetinfo as valid queued proc
447                                      // see gtk2wsmenus.pp: gtkWSPopupMenuDeactivate
448    wwiDeactivating,                  // during gtk deactivate
449    wwiActivating,                    // during gtk activate
450    wwiNoEraseBkgnd,                  // erase background is disabled for widget
451    wwiInvalidEvent,                  // special mark for widgetinfo
452                                      // see gtkchanged_editbox and
453                                      // gtkchanged_editbox_backspace in gtkcallback.inc
454    wwiTabWidgetFocusCheck            // TabWidget have nasty behaviour when clicked
455                                      // by mouse: switches focus here and there, so
456                                      // focused control triggers OnExit and it looks
457                                      // like it triggered OnEnter.issue #20493
458    );
459  TWidgetInfoFlags = set of TWidgetInfoFlag;
460  tGtkStateEnumRange = 0..31;
461  tGtkStateEnum = set of tGtkStateEnumRange;
462
463  // Info needed by the API of a HWND (=Widget)
464  PWidgetInfo = ^TWidgetInfo;
465  TWidgetInfo = record
466    LCLObject: TObject;               // the object which created this widget
467    ClientWidget: PGTKWidget;         // the widget which contains the childwidgets
468                                      // used to be "fixed" or "core-child"
469    CoreWidget: PGTKWidget;           // the widget which implements the main functionality
470                                      // For a TListBox the GTKList is the CoreWidget
471                                      // and the scrollbox around it is the handle
472                                      // So in most cases handle = CoreWidget
473    UpdateRect: TRect;                // used by LM_Paint, beginpaint etc
474    WndProc: Integer;                 // window data
475    Style: Integer;
476    ExStyle: Integer;
477    EventMask: TGdkEventMask;
478    DoubleBuffer: PGdkPixmap;
479    CursorPos: integer;
480    SelLength: integer;
481    ControlCursor: HCursor;           // current widget cursor
482    Flags: TWidgetInfoFlags;
483    ChangeLock: Integer;              // lock events
484    PaintDepth: integer;              // increased/decreased by Begin/EndPaint
485    DataOwner: Boolean;               // Set if the UserData should be freed when the info is freed
486    UserData: Pointer;
487    FormBorderStyle: Integer;         // used only by forms
488    FormWindowState: TGdkEventWindowState; // used only by forms to stop infinite loops eg. issue #16505
489    FirstPaint: boolean; // for accurate frame - forms only
490  end;
491
492  //TODO: remove
493  PWinWidgetInfo = ^TWidgetInfo;
494  TWinWidgetInfo = TWidgetInfo;
495  //--
496
497
498const
499  GdkTrue = true;
500  GdkFalse = false;
501
502
503  GTK_STYLE_BASE = 20;// see GTK_STATE_NORMAL..GTK_STATE_INSENSITIVE,
504  GTK_STYLE_TEXT = 21;// see tGtkStateEnum, and see TGtkWidgetSet.SetWidgetColor
505
506
507type
508  TGdkPixBufBuffer = Pguchar;
509
510
511const
512  GDK_VOIDSYMBOL = $FFFFFF;
513
514  GDK_KEY_ISO_Level5_Shift = $FE11;
515  GDK_KEY_ISO_Level5_Latch = $FE12;
516  GDK_KEY_ISO_Level5_Lock = $FE13;
517
518// MWE:
519// Additional GDK_KEY_xxx definitions, not defined in GDK. Since GDK (on Linux)
520// simply passes the X vvalue I definde those extra here as GDKX_KEY_xxx
521// I don't know what the values are in win32 so I assume the same
522// Original source: /usr/X11R6/include/X11/XF86keysym.h
523
524// Keys found on some "Internet" keyboards.
525const
526  GDKX_KEY_Standby          = $1008FF10;
527  GDKX_KEY_AudioLowerVolume = $1008FF11;
528  GDKX_KEY_AudioMute        = $1008FF12;
529  GDKX_KEY_AudioRaiseVolume = $1008FF13;
530  GDKX_KEY_AudioPlay        = $1008FF14;
531  GDKX_KEY_AudioStop        = $1008FF15;
532  GDKX_KEY_AudioPrev        = $1008FF16;
533  GDKX_KEY_AudioNext        = $1008FF17;
534  GDKX_KEY_HomePage         = $1008FF18;
535  GDKX_KEY_Mail             = $1008FF19;
536  GDKX_KEY_Start            = $1008FF1A;
537  GDKX_KEY_Search           = $1008FF1B;
538  GDKX_KEY_AudioRecord      = $1008FF1C;
539
540// These are sometimes found on PDA's (e.g. Palm, PocketPC or elsewhere)
541  GDKX_KEY_Calculator       = $1008FF1D;
542  GDKX_KEY_Memo             = $1008FF1E;
543  GDKX_KEY_ToDoList         = $1008FF1F;
544  GDKX_KEY_Calendar         = $1008FF20;
545  GDKX_KEY_PowerDown        = $1008FF21;
546  GDKX_KEY_ContrastAdjust   = $1008FF22;
547  GDKX_KEY_RockerUp         = $1008FF23;
548  GDKX_KEY_RockerDown       = $1008FF24;
549  GDKX_KEY_RockerEnter      = $1008FF25;
550
551// Some more "Internet" keyboard symbols
552  GDKX_KEY_Back             = $1008FF26;
553  GDKX_KEY_Forward          = $1008FF27;
554  GDKX_KEY_Stop             = $1008FF28;
555  GDKX_KEY_Refresh          = $1008FF29;
556  GDKX_KEY_PowerOff         = $1008FF2A;
557  GDKX_KEY_WakeUp           = $1008FF2B;
558  GDKX_KEY_Eject            = $1008FF2C;
559  GDKX_KEY_ScreenSaver      = $1008FF2D;
560  GDKX_KEY_WWW              = $1008FF2E;
561  GDKX_KEY_Sleep            = $1008FF2F;
562  GDKX_KEY_Favorites        = $1008FF30;
563  GDKX_KEY_AudioPause       = $1008FF31;
564  GDKX_KEY_AudioMedia       = $1008FF32;
565  GDKX_KEY_MyComputer       = $1008FF33;
566  GDKX_KEY_VendorHome       = $1008FF34;
567  GDKX_KEY_LightBulb        = $1008FF35;
568  GDKX_KEY_Shop             = $1008FF36;
569  GDKX_KEY_History          = $1008FF37;
570  GDKX_KEY_OpenURL          = $1008FF38;
571  GDKX_KEY_AddFavorite      = $1008FF39;
572  GDKX_KEY_HotLinks         = $1008FF3A;
573  GDKX_KEY_BrightnessAdjust = $1008FF3B;
574  GDKX_KEY_Finance          = $1008FF3C;
575  GDKX_KEY_Community        = $1008FF3D;
576
577  GDKX_KEY_Launch0          = $1008FF40;
578  GDKX_KEY_Launch1          = $1008FF41;
579  GDKX_KEY_Launch2          = $1008FF42;
580  GDKX_KEY_Launch3          = $1008FF43;
581  GDKX_KEY_Launch4          = $1008FF44;
582  GDKX_KEY_Launch5          = $1008FF45;
583  GDKX_KEY_Launch6          = $1008FF46;
584  GDKX_KEY_Launch7          = $1008FF47;
585  GDKX_KEY_Launch8          = $1008FF48;
586  GDKX_KEY_Launch9          = $1008FF49;
587  GDKX_KEY_LaunchA          = $1008FF4A;
588  GDKX_KEY_LaunchB          = $1008FF4B;
589  GDKX_KEY_LaunchC          = $1008FF4C;
590  GDKX_KEY_LaunchD          = $1008FF4D;
591  GDKX_KEY_LaunchE          = $1008FF4E;
592  GDKX_KEY_LaunchF          = $1008FF4F;
593
594
595function InternalNewPGDIObject: PGDIObject;
596procedure InternalDisposePGDIObject(GDIObject: PGdiObject);
597type
598  TReferenceGDIObject = procedure(GDIObject: PGdiObject) of object;
599  TReleaseGDIObject = function(GDIObject: PGdiObject): boolean of object;
600var
601  ReleaseGDIObject: TReleaseGDIObject; // see TGtkWidgetSet.ReleaseGDIObject
602  ReferenceGDIObject: TReferenceGDIObject; // see TGtkWidgetSet.ReferenceGDIObject
603
604{$IFDEF DebugLCLComponents}
605var
606  DebugGtkWidgets: TDebugLCLItems = nil;
607  DebugGdiObjects: TDebugLCLItems = nil;
608  DebugDeviceContexts: TDebugLCLItems = nil;
609{$ENDIF}
610
611procedure GtkDefDone;
612
613function dbgs(g: TGDIType): string; overload;
614function dbgs(const r: TGDKRectangle): string; overload;
615function dbgs(r: PGDKRectangle): string; overload;
616
617procedure SetLayoutText(ALayout: PPangoLayout; AText: PChar; ALength: PtrInt);
618
619implementation
620
621uses
622  // until all code is transfered to objects, these circles are needed;
623  Gtk2Int, Gtk2Proc, Gtk2FontCache, Gtk2WinApiWindow;
624
625{$IFOpt R+}{$Define RangeChecksOn}{$Endif}
626
627// memory system for PGDIObject(s) ---------------------------------------------
628type
629  TGDIObjectMemManager = class(TLCLMemManager)
630  protected
631    procedure FreeFirstItem; override;
632  public
633    procedure DisposeGDIObjectMem(AGDIObject: PGDIObject);
634    function NewGDIObjectMem: PGDIObject;
635  end;
636
637const
638  GDIObjectMemManager: TGDIObjectMemManager = nil;
639
640function InternalNewPGDIObject: PGDIObject;
641begin
642  if GDIObjectMemManager=nil then begin
643    GDIObjectMemManager:=TGDIObjectMemManager.Create;
644    GDIObjectMemManager.MinimumFreeCount:=1000;
645  end;
646  Result:=GDIObjectMemManager.NewGDIObjectMem;
647  {$IFDEF DebugLCLComponents}
648  DebugGdiObjects.MarkCreated(Result,'NewPGDIObject');
649  {$ENDIF}
650end;
651
652procedure InternalDisposePGDIObject(GDIObject: PGdiObject);
653begin
654  {$IFDEF DebugLCLComponents}
655  DebugGdiObjects.MarkDestroyed(GDIObject);
656  {$ENDIF}
657  GDIObjectMemManager.DisposeGDIObjectMem(GDIObject);
658end;
659
660{ TGDIObjectMemManager }
661
662procedure TGDIObjectMemManager.FreeFirstItem;
663var AGDIObject: PGDIObject;
664begin
665  AGDIObject:=PGDIObject(FFirstFree);
666  PGDIObject(FFirstFree):=AGDIObject^.Next;
667  Dispose(AGDIObject);
668  //DebugLn('TGDIObjectMemManager.DisposeGDIObject A FFreedCount=',FFreedCount);
669  {$R-}
670  inc(FFreedCount);
671  {$IfDef RangeChecksOn}{$R+}{$Endif}
672end;
673
674procedure TGDIObjectMemManager.DisposeGDIObjectMem(AGDIObject: PGDIObject);
675begin
676  //DebugLn('TGDIObjectMemManager.DisposeGDIObjectMem ',DbgS(AGDIObject));
677  if AGDIObject^.RefCount<>0 then
678    RaiseGDBException('');
679  if (FFreeCount<FMinFree) or (FFreeCount<((FCount shr 3)*FMaxFreeRatio)) then
680  begin
681    // add AGDIObject to Free list
682    AGDIObject^.Next:=PGDIObject(FFirstFree);
683    PGDIObject(FFirstFree):=AGDIObject;
684    inc(FFreeCount);
685  end else begin
686    // free list full -> free the ANode
687    Dispose(AGDIObject);
688    //DebugLn('TGDIObjectMemManager.DisposeGDIObjectMem B FFreedCount=',FFreedCount);
689    {$R-}
690    inc(FFreedCount);
691    {$IfDef RangeChecksOn}{$R+}{$Endif}
692  end;
693  dec(FCount);
694end;
695
696function TGDIObjectMemManager.NewGDIObjectMem: PGDIObject;
697begin
698  if FFirstFree<>nil then begin
699    // take from free list
700    Result:=PGDIObject(FFirstFree);
701    PGDIObject(FFirstFree):=Result^.Next;
702    dec(FFreeCount);
703  end else begin
704    // free list empty -> create new node
705    New(Result);
706    // DebugLn('TGDIObjectMemManager.NewGDIObjectMem FAllocatedCount=',FAllocatedCount);
707    {$R-}
708    inc(FAllocatedCount);
709    {$IfDef RangeChecksOn}{$R+}{$Endif}
710  end;
711  FillChar(Result^, SizeOf(TGDIObject), 0);
712  inc(FCount);
713  //DebugLn('TGDIObjectMemManager.NewGDIObjectMem ',DbgS(Result));
714end;
715
716
717
718{ TDeviceContextMemManager }
719
720procedure TDeviceContextMemManager.FreeFirstItem;
721var ADeviceContext: TGtkDeviceContext;
722begin
723  ADeviceContext:=TGtkDeviceContext(FFirstFree);
724  TGtkDeviceContext(FFirstFree):=ADeviceContext.SavedContext;
725  //DebugLn('TDeviceContextMemManager.FreeFirstItem FFreedCount=',FFreedCount);
726  ADeviceContext.Free;
727  {$R-}
728  inc(FFreedCount);
729  {$IfDef RangeChecksOn}{$R+}{$Endif}
730end;
731
732constructor TDeviceContextMemManager.Create(AClass: TGtkDeviceContextClass);
733begin
734  inherited Create;
735  FDeviceContextClass := AClass;
736end;
737
738procedure TDeviceContextMemManager.DisposeDeviceContext(
739  ADeviceContext: TGtkDeviceContext);
740begin
741  if (FFreeCount<FMinFree) or (FFreeCount<((FCount shr 3)*FMaxFreeRatio))
742  then begin
743    // add ADeviceContext to Free list
744    ADeviceContext.SavedContext:=TGtkDeviceContext(FFirstFree);
745    TGtkDeviceContext(FFirstFree):=ADeviceContext;
746    inc(FFreeCount);
747  end
748  else begin
749    // free list full -> free the ANode
750    //DebugLn('TDeviceContextMemManager.DisposeDeviceContext FFreedCount=',FFreedCount);
751    ADeviceContext.Free;
752    {$R-}
753    inc(FFreedCount);
754    {$IfDef RangeChecksOn}{$R+}{$Endif}
755  end;
756  dec(FCount);
757end;
758
759function TDeviceContextMemManager.NewDeviceContext: TGtkDeviceContext;
760begin
761  if FFirstFree <> nil
762  then begin
763    // take from free list
764    Result := TGtkDeviceContext(FFirstFree);
765    TGtkDeviceContext(FFirstFree) := Result.SavedContext;
766    Dec(FFreeCount);
767    Result.Clear;
768  end
769  else begin
770    // free list empty -> create new node
771    Result := FDeviceContextClass.Create;
772    //DebugLn('TDeviceContextMemManager.NewDeviceContext FAllocatedCount=',FAllocatedCount);
773    {$R-}
774    inc(FAllocatedCount);
775    {$IfDef RangeChecksOn}{$R+}{$Endif}
776  end;
777  Inc(FCount);
778end;
779
780
781//------------------------------------------------------------------------------
782
783procedure GtkDefInit;
784begin
785  {$IFDEF DebugLCLComponents}
786  DebugGtkWidgets:=TDebugLCLItems.Create('GtkDefInit.DebugGtkWidgets');
787  DebugGdiObjects:=TDebugLCLItems.Create('GtkDefInit.DebugGdiObjects');
788  DebugDeviceContexts:=TDebugLCLItems.Create('GtkDefInit.DebugDeviceContexts');
789  {$ENDIF}
790end;
791
792procedure GtkDefDone;
793begin
794  GDIObjectMemManager.Free;
795  GDIObjectMemManager:=nil;
796  {$IFDEF DebugLCLComponents}
797  FreeAndNil(DebugGtkWidgets);
798  FreeAndNil(DebugGdiObjects);
799  FreeAndNil(DebugDeviceContexts);
800  {$ENDIF}
801end;
802
803function dbgs(g: TGDIType): string;
804begin
805  case g of
806  gdiBitmap: Result:='gdiBitmap';
807  gdiBrush: Result:='gdiBrush';
808  gdiFont: Result:='gdiFont';
809  gdiPen: Result:='gdiPen';
810  gdiRegion: Result:='gdiRegion';
811  gdiPalette: Result:='gdiPalette';
812  else Result:='<?? unknown gdi type '+dbgs(ord(g))+'>';
813  end;
814end;
815
816function dbgs(const r: TGDKRectangle): string;
817begin
818  Result:=dbgs(Bounds(r.x,r.y,r.width,r.height));
819end;
820
821function dbgs(r: PGDKRectangle): string;
822begin
823  if r=nil then
824    Result:='nil'
825  else
826    Result:=dbgs(r^);
827end;
828
829{$i gtk2devicecontext.inc}
830
831initialization
832  GtkDefInit;
833
834
835end.
836