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