1{%MainUnit gtk2int.pas} 2 3{****************************************************************************** 4 All GTK Winapi implementations. 5 Initial Revision : Sat Nov 13 12:53:53 1999 6 7 8 !! Keep alphabetical !! 9 10 Support routines go to gtk2proc.pp 11 12 ****************************************************************************** 13 Implementation 14 ****************************************************************************** 15 16 ***************************************************************************** 17 This file is part of the Lazarus Component Library (LCL) 18 19 See the file COPYING.modifiedLGPL.txt, included in this distribution, 20 for details about the license. 21 ***************************************************************************** 22} 23{$IFOPT C-} 24// Uncomment for local trace 25// {$C+} 26// {$DEFINE ASSERT_IS_ON} 27{$EndIf} 28 29{off $define VerboseScrollWindowEx} 30 31 32//##apiwiz##sps## // Do not remove 33 34{------------------------------------------------------------------------------ 35 Method: Arc 36 Params: left, top, right, bottom, angle1, angle2 37 Returns: Nothing 38 39 Use Arc to draw an elliptically curved line with the current Pen. 40 The angles angle1 and angle2 are 1/16th of a degree. For example, a full 41 circle equals 5760 (16*360). Positive values of Angle and AngleLength mean 42 counter-clockwise while negative values mean clockwise direction. 43 Zero degrees is at the 3'o clock position. 44 Angle1 is the starting angle. Angle2 is relative to Angle1 (added). 45 Example: 46 Angle1 = 10*16, Angle2 = 30*16 will draw an arc from 10 to 40 degree. 47 48 ------------------------------------------------------------------------------} 49function TGtk2WidgetSet.Arc(DC: HDC; Left, top, right, bottom, angle1, 50 angle2: Integer): Boolean; 51var 52 DevCtx: TGtkDeviceContext absolute DC; 53 DCOrigin: TPoint; 54 Angle: Integer; 55begin 56 Result := IsValidDC(DC); 57 if not Result then Exit; 58 59 // Draw outline 60 DevCtx.SelectPenProps; 61 62 if not (dcfPenSelected in DevCtx.Flags) 63 then begin 64 Result := False; 65 Exit; 66 end; 67 if DevCtx.IsNullPen then Exit; 68 69 if DevCtx.HasTransf then 70 begin 71 DevCtx.TransfRect(Left, Top, Right, Bottom); 72 DevCtx.TransfNormalize(Left, Right); 73 DevCtx.TransfNormalize(Top, Bottom); 74 // we must convert angles too because of possible negative axis orientations 75 Angle := Angle1 + Angle2; 76 DevCtx.TransfAngles(Angle1, Angle); 77 Angle2 := Angle - Angle1; 78 end; 79 80 DCOrigin := DevCtx.Offset; 81 inc(Left, DCOrigin.X); 82 inc(Top, DCOrigin.Y); 83 inc(Right, DCOrigin.X); 84 inc(Bottom, DCOrigin.Y); 85 86 {$IFDEF DebugGDKTraps}BeginGDKErrorTrap;{$ENDIF} 87 DevCtx.RemovePixbuf; 88 gdk_draw_arc(DevCtx.Drawable, DevCtx.GC, 0, left, top, right - left, bottom - top, 89 Angle1*4, Angle2*4); 90 {$IFDEF DebugGDKTraps}EndGDKErrorTrap;{$ENDIF} 91end; 92 93 {------------------------------------------------------------------------------ 94 Method: AngleChord 95 Params: DC, x1, y1, x2, y2, angle1, angle2 96 Returns: Nothing 97 98 Use AngleChord to draw a filled Chord-shape on the canvas. The angles angle1 99 and angle2 are 1/16th of a degree. For example, a full circle equals 5760 100 16*360). Positive values of Angle and AngleLength mean counter-clockwise while 101 negative values mean clockwise direction. Zero degrees is at the 3'o clock 102 position. 103 104------------------------------------------------------------------------------} 105function TGtk2WidgetSet.AngleChord(DC: HDC; 106 x1, y1, x2, y2, angle1, angle2: Integer): Boolean; 107begin 108 Result := inherited AngleChord(DC, x1, y1, x2, y2, angle1, angle2); 109end; 110 111{------------------------------------------------------------------------------ 112 Function: BeginPaint 113 Params: 114 Returns: 115 116 ------------------------------------------------------------------------------} 117function TGtk2WidgetSet.BeginPaint(Handle: hWnd; var PS : TPaintStruct) : hdc; 118var 119 Widget: PGtkWidget; 120 Info: PWidgetInfo; 121 DC: TGtkDeviceContext; 122 paintrect : TGDKRectangle; 123 Control: TWinControl; 124 125begin 126 Widget:={%H-}PGtkWidget(Handle); 127 Info:=GetWidgetInfo(Widget); 128 if Info<>nil then 129 Inc(Info^.PaintDepth); 130 PS.hDC:=GetDC(Handle); 131 DC:=TGtkDeviceContext(PS.hDC); 132 DC.PaintRectangle:=PS.rcPaint; 133 134 Result := PS.hDC; 135 136 if Handle <> 0 137 then Control := TWinControl(GetLCLObject({%H-}Pointer(Handle))) 138 else Control := nil; 139 140 if (Control <> nil) 141 and TWSWinControlClass(Control.WidgetSetClass).GetDoubleBuffered(Control) 142 and not GTK_WIDGET_DOUBLE_BUFFERED({%H-}PGTKWidget(Handle)) 143 then begin 144 //DebugLn(['TGtk2WidgetSet.BeginPaint ',DbgSName(Control)]); 145 paintrect.x := PS.rcPaint.Left; 146 paintrect.y := PS.rcPaint.Top; 147 paintrect.width := PS.rcPaint.Right- PS.rcPaint.Left; 148 paintrect.height := PS.rcPaint.Bottom - PS.rcPaint.Top; 149 if (paintrect.width <= 0) or (paintrect.height <=0) 150 then begin 151 paintrect.x := 0; 152 paintrect.y := 0; 153 gdk_drawable_get_size(TGtkDeviceContext(Result).Drawable, 154 @paintrect.width, @paintrect.height); 155 end; 156 gdk_window_freeze_updates(TGtkDeviceContext(Result).Drawable); 157 gdk_window_begin_paint_rect (TGtkDeviceContext(Result).Drawable, @paintrect); 158 end; 159 160end; 161 162{------------------------------------------------------------------------------ 163 Function: BitBlt 164 Params: DestDC: The destination devicecontext 165 X, Y: The left/top corner of the destination rectangle 166 Width, Height: The size of the destination rectangle 167 SrcDC: The source devicecontext 168 XSrc, YSrc: The left/top corner of the source rectangle 169 Rop: The raster operation to be performed 170 Returns: True if succesful 171 172 The BitBlt function copies a bitmap from a source context into a destination 173 context using the specified raster operation. 174 ------------------------------------------------------------------------------} 175function TGtk2WidgetSet.BitBlt(DestDC: HDC; X, Y, Width, Height: Integer; 176 SrcDC: HDC; XSrc, YSrc: Integer; Rop: DWORD): Boolean; 177begin 178 Result := StretchBlt(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc, Width, 179 Height, ROP); 180end; 181 182{------------------------------------------------------------------------------ 183 Function: CallNextHookEx 184 Params: none 185 Returns: Nothing 186 187 188 ------------------------------------------------------------------------------} 189function TGtk2WidgetSet.CallNextHookEx(hHk: HHOOK; ncode: Integer; 190 wParam: WParam; lParam: LParam): Integer; 191begin 192 Result := 0; 193 // TODO: TGtk2WidgetSet.CallNextHookEx: Does anything need to be done here? 194end; 195 196{------------------------------------------------------------------------------ 197 Function: CallWindowProc 198 Params: lpPrevWndFunc: 199 Handle: 200 Msg: 201 wParam: 202 lParam: 203 Returns: 204 205 ------------------------------------------------------------------------------} 206function TGtk2WidgetSet.CallWindowProc(lpPrevWndFunc: TFarProc; Handle: HWND; 207 Msg: UINT; wParam: WParam; lParam: lParam): Integer; 208var 209 Proc : TWndMethod; 210 Mess : TLMessage; 211 P : Pointer; 212begin 213 Result := -1; 214 if Handle = 0 then Exit; 215 P := g_object_get_data({%H-}PGObject(Handle),'WNDPROC'); 216 if P <> nil then 217 Proc := TWndMethod(P^) 218 else 219 Exit; 220 Mess.msg := msg; 221 Mess.LParam := LParam; 222 Mess.WParam := WParam; 223 Proc(Mess); 224 Result := Mess.Result; 225end; 226 227{------------------------------------------------------------------------------ 228 Function: ClientToScreen 229 Params: Handle : HWND; var P : TPoint 230 Returns: true on success 231 232 Converts the client-area coordinates of P to screen coordinates. 233 ------------------------------------------------------------------------------} 234function TGtk2WidgetSet.ClientToScreen(Handle : HWND; var P : TPoint) : Boolean; 235var 236 Position: TPoint; 237Begin 238 if Handle = 0 239 then begin 240 Position.X := 0; 241 Position.Y := 0; 242 end 243 else begin 244 Position:=GetWidgetClientOrigin({%H-}PGtkWidget(Handle)); 245 end; 246 247 Inc(P.X, Position.X); 248 Inc(P.Y, Position.Y); 249 250 //DebugLn(Format('Trace: [GTKObject.ClientToScreen] Handle: 0x%x --> (%d, %d)', [Integer(Handle), P.X, P.y])); 251 Result := True; 252end; 253 254{------------------------------------------------------------------------------ 255 Function: ClipboardFormatToMimeType 256 Params: FormatID - a registered format identifier (0 is invalid) 257 Returns: the corresponding mime type as string 258 ------------------------------------------------------------------------------} 259function TGtk2WidgetSet.ClipboardFormatToMimeType( 260 FormatID: TClipboardFormat): string; 261var p: PChar; 262begin 263 if FormatID<>0 then begin 264 p:=gdk_atom_name(FormatID); 265 Result:=StrPas(p); 266 g_free(p); 267 end else 268 Result:=''; 269end; 270 271{------------------------------------------------------------------------------ 272 Function: ClipboardGetData 273 Params: ClipboardType 274 FormatID - a registered format identifier (0 is invalid) 275 Stream - If format is available, it will be appended to this stream 276 Returns: true on success 277 ------------------------------------------------------------------------------} 278function TGtk2WidgetSet.ClipboardGetData(ClipboardType: TClipboardType; 279 FormatID: TClipboardFormat; Stream: TStream): boolean; 280var 281 FormatAtom: TGdkAtom; 282 SupportedCnt, i: integer; 283 SupportedFormats: PGdkAtom; 284 SelData: TGtkSelectionData; 285 CompoundTextList: PPGChar; 286 CompoundTextCount: integer; 287 288 function IsFormatSupported(CurFormat: TGdkAtom): boolean; 289 var 290 i: integer; 291 AllID: TGdkAtom; 292 begin 293 //DebugLn('IsFormatSupported CurFormat=',dbgs(CurFormat),' SupportedCnt=',dbgs(SupportedCnt)); 294 if CurFormat=0 then begin 295 Result:=false; 296 exit; 297 end; 298 if SupportedCnt<0 then begin 299 Result:=false; 300 AllID:=gdk_atom_intern('TARGETS',GdkFalse); 301 SelData:=RequestSelectionData(ClipboardWidget,ClipboardType,AllID); 302 {$IFDEF DEBUG_CLIPBOARD} 303 DebugLn('IsFormatSupported A ',Dbgs(SelData.Selection), 304 ' ',HexStr(Cardinal(ClipboardTypeAtoms[ClipboardType]),8), 305 ' SelData.Target='+dbgs(SelData.Target),' AllID='+dbgs(AllID), 306 ' SelData.TheType='+dbgs(SelData._type)+' ATOM='+dbgs(gdk_atom_intern('ATOM',GdkTrue))+' Name="'+GdkAtomToStr(SelData._type)+'"', 307 ' SelData.Length='+dbgs(SelData.Length), 308 ' SelData.Format='+dbgs(SelData.Format) 309 ); 310 {$ENDIF} 311 if (SelData.Selection<>ClipboardTypeAtoms[ClipboardType]) 312 or (SelData.Target<>AllID) 313 or (SelData._Type<>gdk_atom_intern('ATOM',GdkFalse)) 314 or ((SelData.Format shr 3)<=0) then begin 315 SupportedCnt:=0; 316 exit; 317 end; 318 SupportedCnt:=SelData.Length div (SelData.Format shr 3); 319 SupportedFormats:=PGdkAtom(SelData.Data); 320 //DebugLn('IsFormatSupported SupportedCnt=',dbgs(SupportedCnt)); 321 322 {$IFDEF DEBUG_CLIPBOARD} 323 i:=SupportedCnt-1; 324 while (i>=0) do begin 325 debugln(' ',dbgs(i),' "',GdkAtomToStr(SupportedFormats[i]),'"'); 326 dec(i); 327 end; 328 {$ENDIF} 329 end; 330 i:=SupportedCnt-1; 331 while (i>=0) and (SupportedFormats[i]<>CurFormat) do dec(i); 332 Result:=(i>=0); 333 end; 334 335 procedure CheckAtomFormat(const atom_name: Pgchar; only_if_exists:gboolean); 336 var 337 FormatTry: TGdkAtom; 338 begin 339 if FormatAtom<>0 then exit; 340 FormatTry:=gdk_atom_intern(atom_name,only_if_exists); 341 if IsFormatSupported(FormatTry) then 342 FormatAtom:=FormatTry; 343 end; 344 345begin 346 {$IfDef DEBUG_CLIPBOARD} 347 DebugLn('[TGtk2WidgetSet.ClipboardGetData] A ClipboardWidget=',Dbgs(ClipboardWidget),' FormatID=',ClipboardFormatToMimeType(FormatID),' Now=',dbgs(Now)); 348 {$EndIf} 349 Result:=false; 350 if (FormatID=0) or (Stream=nil) then exit; 351 if not (ClipboardType in [ctPrimarySelection,ctSecondarySelection,ctClipboard]) 352 then exit; 353 // request the data from the selection owner 354 SupportedCnt:=-1; 355 SupportedFormats:=nil; 356 FillChar(SelData,SizeOf(TGtkSelectionData),0); 357 try 358 359 FormatAtom:=FormatID; 360 if (FormatAtom=gdk_atom_intern('text/plain',GdkTrue)) then begin 361 // text/plain is supported in various formats in gtk 362 FormatAtom:=0; 363 // check for UTF8 text format 'UTF8_STRING' 364 CheckAtomFormat('UTF8_STRING',GdkFalse); 365 // The COMPOUND_TEXT format can be converted and is therefore 366 // used as default for 'text/plain' 367 if (SupportedCnt=0) then 368 FormatAtom:=gdk_atom_intern('COMPOUND_TEXT',GdkFalse) 369 else begin 370 CheckAtomFormat('COMPOUND_TEXT',GdkFalse); 371 // then check for simple text format 'text/plain' 372 CheckAtomFormat('text/plain',GdkFalse); 373 // then check for simple text format STRING 374 CheckAtomFormat('STRING',GdkFalse); 375 // check for some other formats that can be interpreted as text 376 CheckAtomFormat('FILE_NAME',GdkTrue); 377 CheckAtomFormat('HOST_NAME',GdkTrue); 378 CheckAtomFormat('USER',GdkTrue); 379 // the TEXT format is not reliable, but it should be supported 380 CheckAtomFormat('TEXT',GdkFalse); 381 end; 382 end; 383 384 {$IfDef DEBUG_CLIPBOARD} 385 DebugLn('[TGtk2WidgetSet.ClipboardGetData] B Format=',ClipboardFormatToMimeType(FormatAtom),' FormatAtom=',dbgs(FormatAtom),' Now=',dbgs(Now)); 386 {$EndIf} 387 if FormatAtom=0 then exit; 388 389 // request data from owner 390 SelData:=RequestSelectionData(ClipboardWidget,ClipboardType,FormatAtom); 391 {$IfDef DEBUG_CLIPBOARD} 392 DebugLn('[TGtk2WidgetSet.ClipboardGetData] C Length=',dbgs(SelData.Length),' Now=',dbgs(Now),' ', 393 ' SelData.Selection=',dbgs(SelData.Selection),' SelData.Length=',dbgs(SelData.Length)); 394 {$EndIf} 395 if (SelData.Selection<>ClipboardTypeAtoms[ClipboardType]) 396 or (SelData.Target<>FormatAtom) then begin 397 {$IfDef DEBUG_CLIPBOARD} 398 DebugLn('[TGtk2WidgetSet.ClipboardGetData] REQUESTED FORMAT NOT SUPPORTED Length=',dbgs(SelData.Length)); 399 {$ENDIF} 400 exit; 401 end; 402 403 // write data to stream 404 if (SelData.Data<>nil) and (SelData.Length>0) then begin 405 if (FormatID=gdk_atom_intern('text/plain',GdkTrue)) then begin 406 // the lcl expects the return format as simple text 407 // transform if necessary 408 if FormatAtom=gdk_atom_intern('COMPOUND_TEXT',GdkTrue) then begin 409 CompoundTextList:=nil; 410 CompoundTextCount:=gdk_text_property_to_text_list(SelData._Type, 411 SelData.Format,SelData.Data,SelData.Length,CompoundTextList); 412 try 413 {$IfDef DEBUG_CLIPBOARD} 414 DebugLn('[TGtk2WidgetSet.ClipboardGetData] D CompoundTextCount=',dbgs(CompoundTextCount),' Now=',dbgs(Now)); 415 {$EndIf} 416 for i:=0 to CompoundTextCount-1 do 417 if (CompoundTextList[i]<>nil) then 418 Stream.Write(CompoundTextList[i]^,StrLen(CompoundTextList[i])); 419 finally 420 gdk_free_text_list(CompoundTextList); 421 end; 422 end else 423 Stream.Write(SelData.Data^,SelData.Length); 424 end else begin 425 Stream.Write(SelData.Data^,SelData.Length); 426 end; 427 end; 428 429 {$IfDef DEBUG_CLIPBOARD} 430 DebugLn('[TGtk2WidgetSet.ClipboardGetData] END ',' Now=',dbgs(Now)); 431 {$EndIf} 432 Result:=true; 433 finally 434 if SupportedFormats<>nil then 435 FreeMem(SupportedFormats); 436 if (SelData.Data<>nil) and (PGdkAtom(SelData.Data)<>SupportedFormats) then 437 FreeMem(SelData.Data); 438 end; 439end; 440 441{------------------------------------------------------------------------------ 442 Function: ClipboardGetFormats 443 Params: ClipboardType 444 Returns: true on success 445 Count contains the number of supported formats 446 List is an array of TClipboardType 447 448 ! List will be created. You must free it yourself with FreeMem(List) ! 449 ------------------------------------------------------------------------------} 450function TGtk2WidgetSet.ClipboardGetFormats(ClipboardType: TClipboardType; 451 var Count: integer; var List: PClipboardFormat): boolean; 452var 453 AllID: TGdkAtom; 454 FormatAtoms: PGdkAtom; 455 Cnt, i: integer; 456 AddTextPlain: boolean; 457 SelData: TGtkSelectionData; 458 459 function IsFormatSupported(CurFormat: TGdkAtom): boolean; 460 var a: integer; 461 begin 462 if CurFormat<>0 then begin 463 for a:=0 to Cnt-1 do begin 464 {$IfDef DEBUG_CLIPBOARD} 465 DebugLn(' IsFormatSupported ',dbgs(CurFormat),' ',dbgs(FormatAtoms[a])); 466 {$EndIf} 467 if FormatAtoms[a]=CurFormat then begin 468 Result:=true; 469 exit; 470 end; 471 end; 472 end; 473 Result:=false; 474 end; 475 476 function IsFormatSupported(Formats: TGtkClipboardFormats): boolean; 477 var Format: TGtkClipboardFormat; 478 begin 479 for Format:=Low(TGtkClipboardFormat) to High(TGtkClipboardFormat) do 480 if (Format in Formats) 481 and (IsFormatSupported( 482 gdk_atom_intern(PGChar(GtkClipboardFormatName[Format]),GdkTrue))) 483 then begin 484 Result:=true; 485 exit; 486 end; 487 Result:=false; 488 end; 489 490 491begin 492 {$IfDef DEBUG_CLIPBOARD} 493 DebugLn('[TGtk2WidgetSet.ClipboardGetFormats] A ClipboardWidget=',Dbgs(ClipboardWidget),' Now=',dbgs(Now)); 494 {$EndIf} 495 Result:=false; 496 Count:=0; 497 List:=nil; 498 if not (ClipboardType in [ctPrimarySelection,ctSecondarySelection,ctClipboard]) 499 then exit; 500 // request the list of supported formats from the selection owner 501 AllID:=gdk_atom_intern('TARGETS',GdkFalse); 502 503 SelData:=RequestSelectionData(ClipboardWidget,ClipboardType,AllID); 504 505 try 506 {$IfDef DEBUG_CLIPBOARD} 507 DebugLn('[TGtk2WidgetSet.ClipboardGetFormats] Checking TARGETS answer ', 508 ' selection: '+dbgs(SelData.Selection)+'='+dbgs(ClipboardTypeAtoms[ClipboardType])+ 509 ' "'+GdkAtomToStr(SelData.Selection)+'"', 510 ' target: '+dbgs(SelData.Target),'=',dbgs(AllID), 511 ' "'+GdkAtomToStr(SelData.Target),'"', 512 ' theType: '+dbgs(SelData._type)+'='+dbgs(gdk_atom_intern('ATOM',GdkFalse))+ 513 ' "'+GdkAtomToStr(SelData._type)+'"', 514 ' Length='+dbgs(SelData.Length), 515 ' Format='+dbgs(SelData.Format), 516 ' Data='+Dbgs(SelData.Data), 517 ' Now='+dbgs(Now) 518 ); 519 {$EndIf} 520 if (SelData.Selection<>ClipboardTypeAtoms[ClipboardType]) 521 or (SelData.Target<>AllID) 522 or (SelData.Format<=0) 523 or ((SelData._Type<>gdk_atom_intern('ATOM',GdkFalse)) 524 and (SelData._Type<>AllID)) 525 then 526 exit; 527 Cnt:=SelData.Length div (SelData.Format shr 3); 528 if (SelData.Data<>nil) and (Cnt>0) then begin 529 Count:=Cnt; 530 FormatAtoms:=PGdkAtom(SelData.Data); 531 // add transformable lcl formats 532 // for example: the lcl expects text as 'text/plain', but gtk applications 533 // also know 'TEXT' and 'STRING'. These formats can automagically 534 // transformed into the lcl format, so the lcl format is also supported 535 // and will be added to the list 536 537 AddTextPlain:=false; 538 if (not IsFormatSupported(gdk_atom_intern('text/plain',GdkTrue))) 539 and (IsFormatSupported([gfCOMPOUND_TEXT,gfTEXT,gfSTRING,gfFILE_NAME, 540 gfHOST_NAME,gfUSER])) 541 then begin 542 AddTextPlain:=true; 543 inc(Count); 544 end; 545 546 // copy normal supported formats 547 GetMem(List,SizeOf(TClipboardFormat)*Count); 548 i:=0; 549 while (i<Cnt) do begin 550 {$IfDef DEBUG_CLIPBOARD} 551 DebugLn('[TGtk2WidgetSet.ClipboardGetFormats] Supported formats: ', 552 dbgs(i)+'/'+dbgs(Cnt),': ',dbgs(FormatAtoms[i])); 553 DebugLn(' MimeType="',ClipboardFormatToMimeType(FormatAtoms[i]),'"'); 554 {$EndIf} 555 List[i]:=FormatAtoms[i]; 556 inc(i); 557 end; 558 559 // add all lcl formats that the gtk-interface can transform from the 560 // supported formats 561 if AddTextPlain then begin 562 List[i]:=gdk_atom_intern('text/plain',GdkFalse); 563 inc(i); 564 end; 565 end; 566 finally 567 if SelData.Data<>nil then FreeMem(SelData.Data); 568 end; 569 Result:=true; 570end; 571 572{------------------------------------------------------------------------------ 573 Function: ClipboardGetOwnerShip 574 Params: ClipboardType 575 OnRequestProc - TClipboardRequestEvent is defined in LCLIntf.pp 576 If OnRequestProc is nil the onwership will end. 577 FormatCount - number of formats 578 Formats - array of TClipboardFormat. The supported formats the owner 579 provides. 580 581 Returns: true on success 582 583 Sets the supported formats and requests ownership for the clipboard. 584 Each time the clipboard is read the OnRequestProc will be executed. 585 If someone else requests the ownership, the OnRequestProc will be executed 586 with the invalid FormatID 0 to notify the old owner of the lost of ownership. 587 ------------------------------------------------------------------------------} 588function TGtk2WidgetSet.ClipboardGetOwnerShip(ClipboardType: TClipboardType; 589 OnRequestProc: TClipboardRequestEvent; FormatCount: integer; 590 Formats: PClipboardFormat): boolean; 591var TargetEntries: PGtkTargetEntry; 592 593 function IsFormatSupported(FormatID: TGdkAtom): boolean; 594 var i: integer; 595 begin 596 if FormatID=0 then begin 597 Result:=false; 598 exit; 599 end; 600 i:=FormatCount-1; 601 while (i>=0) and (Formats[i]<>FormatID) do dec(i); 602 Result:=(i>=0); 603 end; 604 605 procedure AddTargetEntry(var Index: integer; const FormatName: string); 606 begin 607 {$IfDef DEBUG_CLIPBOARD} 608 DebugLn(' AddTargetEntry ',FormatName); 609 {$EndIf} 610 TargetEntries[Index].Target := StrAlloc(Length(FormatName) + 1); 611 StrPCopy(TargetEntries[Index].Target, FormatName); 612 TargetEntries[Index].flags:=0; 613 TargetEntries[Index].Info:=Index; 614 inc(Index); 615 end; 616 617{function TGtk2WidgetSet.ClipboardGetOwnerShip(ClipboardType: TClipboardType; 618 OnRequestProc: TClipboardRequestEvent; FormatCount: integer; 619 Formats: PClipboardFormat): boolean;} 620var 621 TargetEntriesSize, i: integer; 622 gtkFormat: TGtkClipboardFormat; 623 ExpFormatCnt: integer; 624 OldClipboardWidget: PGtkWidget; 625begin 626 if ClipboardType in [ctPrimarySelection, ctSecondarySelection, ctClipboard] then 627 begin 628 {$IfDef DEBUG_CLIPBOARD} 629 DebugLn('[TGtk2WidgetSet.ClipboardGetOwnerShip] A'); 630 {$EndIf} 631 ClipboardHandler[ClipboardType]:=nil; 632 Result:=false; 633 if (ClipboardWidget=nil) or (FormatCount=0) or (Formats=nil) then 634 begin 635 // end ownership 636 if (ClipBoardWidget <> nil) 637 and (GetControlWindow(ClipboardWidget)<>nil) 638 and (gdk_selection_owner_get(ClipboardTypeAtoms[ClipboardType]) = 639 GetControlWindow(ClipboardWidget)) 640 then begin 641 gtk_selection_owner_set(nil,ClipboardTypeAtoms[ClipboardType],0); 642 end; 643 Result:=true; 644 exit; 645 end; 646 647 // registering targets 648 FreeClipboardTargetEntries(ClipboardType); 649 650 // the gtk-interface adds automatically some gtk formats unknown to the lcl 651 ExpFormatCnt:=FormatCount; 652 for gtkFormat:=Low(TGtkClipboardFormat) to High(TGtkClipboardFormat) do 653 ClipboardExtraGtkFormats[ClipboardType][gtkFormat]:=false; 654 {$IfDef DEBUG_CLIPBOARD} 655 DebugLn('[TGtk2WidgetSet.ClipboardGetOwnerShip] B'); 656 {$EndIf} 657 if IsFormatSupported(gdk_atom_intern('text/plain',GdkTrue)) then 658 begin 659 // lcl provides 'text/plain' and the gtk-interface will automatically 660 // provide some more text formats 661 ClipboardExtraGtkFormats[ClipboardType][gfUTF8_STRING]:=not IsFormatSupported( 662 gdk_atom_intern(PGChar(GtkClipboardFormatName[gfUTF8_STRING]),GdkFalse)); 663 ClipboardExtraGtkFormats[ClipboardType][gfCOMPOUND_TEXT]:= 664 not IsFormatSupported( 665 gdk_atom_intern(PGChar(GtkClipboardFormatName[gfCOMPOUND_TEXT]),GdkFalse)); 666 ClipboardExtraGtkFormats[ClipboardType][gfSTRING]:=not IsFormatSupported( 667 gdk_atom_intern(PGChar(GtkClipboardFormatName[gfSTRING]),GdkFalse)); 668 ClipboardExtraGtkFormats[ClipboardType][gfTEXT]:=not IsFormatSupported( 669 gdk_atom_intern(PGChar(GtkClipboardFormatName[gfTEXT]),GdkFalse)); 670 end; 671 672 for gtkFormat:=Low(TGtkClipboardFormat) to High(TGtkClipboardFormat) do 673 if ClipboardExtraGtkFormats[ClipboardType][gtkFormat] then 674 inc(ExpFormatCnt); 675 676 // build TargetEntries 677 TargetEntriesSize:=SizeOf(TGtkTargetEntry) * ExpFormatCnt; 678 GetMem(TargetEntries,TargetEntriesSize); 679 FillChar(TargetEntries^,TargetEntriesSize,0); 680 i:=0; 681 while i<FormatCount do 682 AddTargetEntry(i,ClipboardFormatToMimeType(Formats[i])); 683 for gtkFormat:=Low(TGtkClipboardFormat) to High(TGtkClipboardFormat) do 684 if ClipboardExtraGtkFormats[ClipboardType][gtkFormat] then 685 AddTargetEntry(i,GtkClipboardFormatName[gtkFormat]); 686 687 // set the supported formats 688 ClipboardTargetEntries[ClipboardType]:=TargetEntries; 689 ClipboardTargetEntryCnt[ClipboardType]:=ExpFormatCnt; 690 691 // reset the clipboard widget (this will set the new target list) 692 OldClipboardWidget:=ClipboardWidget; 693 SetClipboardWidget(nil); 694 SetClipboardWidget(OldClipboardWidget); 695 696 // taking the ownership 697 {$IfDef DEBUG_CLIPBOARD} 698 DebugLn('[TGtk2WidgetSet.ClipboardGetOwnerShip] C'); 699 {$EndIf} 700 if gtk_selection_owner_set(ClipboardWidget, 701 ClipboardTypeAtoms[ClipboardType],0)=GdkFalse 702 then begin 703 {$IfDef DEBUG_CLIPBOARD} 704 DebugLn('[TGtk2WidgetSet.ClipboardGetOwnerShip] D FAILED'); 705 {$EndIf} 706 exit; 707 end; 708 709 {$IfDef DEBUG_CLIPBOARD} 710 DebugLn('[TGtk2WidgetSet.ClipboardGetOwnerShip] YEAH, got it!'); 711 {$EndIf} 712 ClipboardHandler[ClipboardType]:=OnRequestProc; 713 714 Result:=true; 715 end else 716 { the gtk does not support this kind of clipboard, so the application can 717 have the ownership at any time. The TClipboard in clipbrd.pp has an 718 internal cache system, so that an application can use all types of 719 clipboards even if the underlying platform does not support it. 720 Of course this will only be a local clipboard, invisible to other 721 applications. } 722 Result:=true; 723end; 724 725function TGtk2WidgetSet.ClipboardFormatNeedsNullByte( 726 const AFormat: TPredefinedClipboardFormat): Boolean; 727begin 728 Result := False; 729end; 730 731{------------------------------------------------------------------------------ 732 Function: ClipboardRegisterFormat 733 Params: AMimeType 734 Returns: the registered Format identifier (TClipboardFormat) 735 ------------------------------------------------------------------------------} 736function TGtk2WidgetSet.ClipboardRegisterFormat(const AMimeType: string 737 ): TClipboardFormat; 738var AtomName: PChar; 739begin 740 if Assigned(Application) then begin 741 AtomName:=PChar(AMimeType); 742 Result:=gdk_atom_intern(AtomName,GdkFalse); 743 end else 744 RaiseGDBException( 745 'ERROR: TGtk2WidgetSet.ClipboardRegisterFormat gdk not initialized'); 746end; 747 748 749{------------------------------------------------------------------------------ 750 Function: CreateBitmap 751 Params: none 752 Returns: Nothing 753 754 755 ------------------------------------------------------------------------------} 756function TGtk2WidgetSet.CreateBitmap(Width, Height: Integer; Planes, BitCount: Longint; BitmapBits: Pointer): HBITMAP; 757 758 759const 760 MIN_LOADER_HEADER_SIZE = 128; 761 762type 763 // the loader internally used starts decoding the header after 128 bytes. 764 // by adding dummy bytes and adjusting the data offset, we make sure that we 765 // we write atleast 128 bytes 766 767 TBitmapHeader = packed record 768 FileHeader: tagBitmapFileHeader; 769 InfoHeader: tagBitmapInfoHeader; 770 Dummy: array[1..MIN_LOADER_HEADER_SIZE] of Byte; 771 end; 772 773var 774 GdiObject: PGdiObject; 775 776 procedure FillBitmapInfo(out Header: TBitmapHeader); 777 begin 778 FillChar(Header{%H-}, SizeOf(Header), 0); 779 780 Header.InfoHeader.biSize := SizeOf(Header.InfoHeader); 781 Header.InfoHeader.biWidth := Width; 782 Header.InfoHeader.biHeight := Height; 783 Header.InfoHeader.biPlanes := Planes; 784 Header.InfoHeader.biBitCount := Bitcount; 785 Header.InfoHeader.biCompression := BI_RGB; 786 Header.InfoHeader.biSizeImage := (((BitCount * Width + 31) shr 5) shl 2) * Height; 787 Header.InfoHeader.biXPelsPerMeter := GetDeviceCaps(0, LOGPIXELSX); 788 Header.InfoHeader.biYPelsPerMeter := GetDeviceCaps(0, LOGPIXELSY); 789 790 Header.FileHeader.bfType := LeToN($4D42); 791 Header.FileHeader.bfSize := MIN_LOADER_HEADER_SIZE + Header.InfoHeader.biSizeImage; 792 Header.FileHeader.bfOffBits := MIN_LOADER_HEADER_SIZE; 793 end; 794 795 procedure LoadDataByPixbufLoader; 796 const 797 ALIGNDATA: Word = 0; 798 var 799 Header: TBitmapHeader; 800 Loader: PGdkPixbufLoader; 801 Src: PGDKPixbuf; 802 res: Boolean; 803 LineSize, Count: Integer; 804 BitsPtr: PByte; 805 begin 806 Loader := gdk_pixbuf_loader_new; 807 if Loader = nil then Exit; 808 809 810 FillBitmapInfo(Header); 811 Src := nil; 812 try 813 if not gdk_pixbuf_loader_write(Loader, TGdkPixBufBuffer(@Header), MIN_LOADER_HEADER_SIZE,nil) 814 then begin 815 DebugLn('WARNING: [TGtk2WidgetSet.CreateBitmap] Error loading Bitmap Header!'); 816 Exit; 817 end; 818 819 LineSize := (((BitCount * Width + 15) shr 4) shl 1); 820 if (LineSize and 2) <> 0 821 then begin 822 // bitmapdata needs to be DWord aligned, while CreateBitmap is Word aligned 823 // so "feed" the loader line by line :( 824 Count := Height; 825 res := True; 826 BitsPtr := BitmapBits; 827 while res and (Count > 0) do 828 begin 829 res := gdk_pixbuf_loader_write(Loader, TGdkPixBufBuffer(BitsPtr), LineSize,nil) 830 and gdk_pixbuf_loader_write(Loader, TGdkPixBufBuffer(@ALIGNDATA), 2,nil); 831 Inc(BitsPtr, LineSize); 832 Dec(Count); 833 end; 834 end 835 else begin 836 // data is DWord aligned :) 837 res := gdk_pixbuf_loader_write(Loader, TGdkPixBufBuffer(BitmapBits), Header.InfoHeader.biSizeImage,nil); 838 end; 839 840 if not res 841 then begin 842 DebugLn('WARNING: [TGtk2WidgetSet.CreateBitmap] Error loading Image!'); 843 Exit; 844 end; 845 846 Src := gdk_pixbuf_loader_get_pixbuf(loader); 847 if Src = nil 848 then begin 849 DebugLn('WARNING: [TGtk2WidgetSet.CreateBitmap] Error loading Pixbuf!'); 850 Exit; 851 end; 852 853 finally 854 gdk_pixbuf_loader_close(Loader,nil); 855 end; 856 857 if GdiObject^.GDIPixmapObject.Image<>nil then 858 begin 859 gdk_pixmap_unref(GdiObject^.GDIPixmapObject.Image); 860 GdiObject^.GDIPixmapObject.Image:=nil; 861 end; 862 if GdiObject^.GDIPixmapObject.Mask<>nil then 863 begin 864 gdk_bitmap_unref(GdiObject^.GDIPixmapObject.Mask); 865 GdiObject^.GDIPixmapObject.Mask:=nil; 866 end; 867 gdk_pixbuf_render_pixmap_and_mask(Src, 868 GdiObject^.GDIPixmapObject.Image, GdiObject^.GDIPixmapObject.Mask, $80); 869 gdk_pixbuf_unref(Src); 870 871 GdiObject^.Depth := gdk_drawable_get_depth(GdiObject^.GDIPixmapObject.Image); 872 if GdiObject^.Depth = 1 873 then begin 874 if GdiObject^.GDIPixmapObject.Mask <> nil 875 then gdk_pixmap_unref(GdiObject^.GDIPixmapObject.Mask); 876 GdiObject^.GDIPixmapObject.Mask := nil; 877 GdiObject^.GDIBitmapType := gbBitmap; 878 end 879 else begin 880 GdiObject^.GDIBitmapType := gbPixmap; 881 end; 882 883 884 GdiObject^.Visual := gdk_window_get_visual(GDIObject^.GDIPixmapObject.Image); 885 if GdiObject^.Visual = nil 886 then GdiObject^.Visual := gdk_visual_get_best_with_depth(GdiObject^.Depth) 887 else gdk_visual_ref(GdiObject^.Visual); 888 889 GdiObject^.Colormap := gdk_colormap_new(GdiObject^.Visual, GdkTrue); 890 end; 891 892 procedure LoadBitmapData; 893 var 894 LineSize, n: Integer; 895 BitsPtr: Pointer; 896 Src, Dst: PByte; 897 begin 898 LineSize := (Width + 7) shr 3; 899 if (LineSize and 1) <> 0 900 then begin 901 // the gdk_bitmap_create_from_data expects data byte aligned while 902 // Createbitmap is word aligned. adjust data 903 BitsPtr := GetMem(LineSize * Height); 904 Dst := BitsPtr; 905 Src := BitmapBits; 906 for n := 1 to height do 907 begin 908 Move(Src^, Dst^, LineSize); 909 Inc(Src, LineSize + 1); 910 Inc(Dst, LineSize); 911 end; 912 end 913 else begin 914 BitsPtr := BitmapBits; 915 end; 916 917 GdiObject^.GDIBitmapType := gbBitmap; 918 GdiObject^.GDIBitmapObject := gdk_bitmap_create_from_data(nil, BitsPtr, Width, Height); 919 GdiObject^.Visual := nil; // bitmaps don't have a visual 920 GdiObject^.SystemVisual := False; 921 922 if BitsPtr <> BitmapBits 923 then FreeMem(BitsPtr); 924 end; 925 926begin 927 //DebugLn(Format('Trace:> [TGtk2WidgetSet.CreateBitmap] Width: %d, Height: %d, Planes: %d, BitCount: %d, BitmapBits: 0x%x', [Width, Height, Planes, BitCount, PtrUInt(BitmapBits)])); 928 929 if (BitCount < 1) or (Bitcount > 32) 930 then begin 931 Result := 0; 932 DebugLn(Format('ERROR: [TGtk2WidgetSet.CreateBitmap] Illegal depth %d', [BitCount])); 933 Exit; 934 end; 935 936 GdiObject := NewGDIObject(gdiBitmap); 937 938 if BitmapBits = nil 939 then begin 940 if BitCount = 1 941 then begin 942 GdiObject^.GDIBitmapType := gbBitmap; 943 GdiObject^.GDIBitmapObject := gdk_pixmap_new(nil, Width, Height, 1); 944 GdiObject^.Visual := nil; // bitmaps don't have a visual 945 end 946 else begin 947 GdiObject^.GDIBitmapType := gbPixmap; 948 GdiObject^.GDIPixmapObject.Image := gdk_pixmap_new(nil, Width, Height, BitCount); 949 GdiObject^.Visual := gdk_window_get_visual(GdiObject^.GDIPixmapObject.Image); 950 gdk_visual_ref(GdiObject^.Visual); 951 end; 952 GdiObject^.SystemVisual := False; 953 end 954 else begin 955 if BitCount = 1 956 then begin 957 LoadBitmapData; 958 end 959 else begin 960 // Load the data by faking it as a windows bitmap stream (this handles all conversion) 961 // Problem with his method is that it doesn't result in the bitmap requested. 962 // it is always a device compatible bitmap 963 // maybe we should add a gdPixBuf type the the GDIObject for formats not compatible 964 // with a native pixmap format 965 LoadDataByPixbufLoader; 966 end; 967 end; 968 969 Result := HBITMAP({%H-}PtrUInt(GdiObject)); 970 971 //DebugLn(Format('Trace:< [TGtk2WidgetSet.CreateBitmap] --> 0x%x', [Integer(Result)])); 972end; 973 974 975{------------------------------------------------------------------------------ 976 Function: CreateBrushIndirect 977 Params: none 978 Returns: Nothing 979 980 981 ------------------------------------------------------------------------------} 982function TGtk2WidgetSet.CreateBrushIndirect(const LogBrush: TLogBrush): HBRUSH; 983const 984 HATCH_BDIAGONAL : array[0..7] of Byte = ($80, $40, $20, $10, $08, $04, $02, $01); 985 HATCH_CROSS : array[0..7] of Byte = ($08, $08, $08, $FF, $08, $08, $08, $08); 986 HATCH_DIAGCROSS : array[0..7] of Byte = ($81, $42, $24, $18, $18, $24, $42, $81); 987 HATCH_FDIAGONAL : array[0..7] of Byte = ($01, $02, $04, $08, $10, $20, $40, $80); 988 HATCH_HORIZONTAL: array[0..7] of Byte = ($00, $00, $00, $FF, $00, $00, $00, $00); 989 HATCH_VERTICAL : array[0..7] of Byte = ($08, $08, $08, $08, $08, $08, $08, $08); 990var 991 GObject: PGdiObject; 992 TmpMask: PGdkBitmap; 993begin 994 //DebugLn(Format('Trace:> [TGtk2WidgetSet.CreateBrushIndirect] Style: %d, Color: %8x', [LogBrush.lbStyle, LogBrush.lbColor])); 995 996 {$IFDEF DebugGDKTraps} 997 BeginGDKErrorTrap; 998 {$ENDIF} 999 1000 GObject := NewGDIObject(gdiBrush); 1001 try 1002 {$IFDEF DebugGDIBrush} 1003 DebugLn('[TGtk2WidgetSet.CreateBrushIndirect] ',DbgS(GObject)); 1004 {$ENDIF} 1005 GObject^.IsNullBrush := False; 1006 with LogBrush do 1007 begin 1008 case lbStyle of 1009 BS_NULL {BS_HOLLOW}: // Same as BS_HOLLOW. 1010 GObject^.IsNullBrush := True; 1011 BS_SOLID: // Solid brush. 1012 GObject^.GDIBrushFill := GDK_SOLID; 1013 BS_HATCHED: // Hatched brush. 1014 begin 1015 GObject^.GDIBrushFill := GDK_STIPPLED; 1016 case lbHatch of 1017 HS_BDIAGONAL: 1018 GObject^.GDIBrushPixmap := gdk_bitmap_create_from_data( 1019 nil, pgchar(@HATCH_BDIAGONAL[0]), 8, 8); 1020 HS_CROSS: 1021 GObject^.GDIBrushPixmap := gdk_bitmap_create_from_data( 1022 nil, pgchar(@HATCH_CROSS[0]), 8, 8); 1023 HS_DIAGCROSS: 1024 GObject^.GDIBrushPixmap := gdk_bitmap_create_from_data( 1025 nil, pgchar(@HATCH_DIAGCROSS[0]), 8, 8); 1026 HS_FDIAGONAL: 1027 GObject^.GDIBrushPixmap := gdk_bitmap_create_from_data( 1028 nil, pgchar(@HATCH_FDIAGONAL[0]), 8, 8); 1029 HS_HORIZONTAL: 1030 GObject^.GDIBrushPixmap := gdk_bitmap_create_from_data( 1031 nil, pgchar(@HATCH_HORIZONTAL[0]), 8, 8); 1032 HS_VERTICAL: 1033 GObject^.GDIBrushPixmap := gdk_bitmap_create_from_data( 1034 nil, pgchar(@HATCH_VERTICAL[0]), 8, 8); 1035 else 1036 GObject^.GDIBrushFill := GDK_SOLID; 1037 end; 1038 end; 1039 1040 BS_DIBPATTERN, // A pattern brush defined by a device-independent 1041 // bitmap (DIB) specification. If lbStyle is BS_DIBPATTERN, the 1042 // lbHatch member contains a handle to a packed DIB.Windows 95: 1043 // Creating brushes from bitmaps or DIBs larger than 8x8 pixels 1044 // is not supported. If a larger bitmap is given, only a portion 1045 // of the bitmap is used. 1046 BS_DIBPATTERN8X8, // Same as BS_DIBPATTERN. 1047 BS_DIBPATTERNPT, // A pattern brush defined by a device-independent 1048 // bitmap (DIB) specification. If lbStyle is BS_DIBPATTERNPT, the 1049 // lbHatch member contains a pointer to a packed DIB. 1050 BS_PATTERN, // Pattern brush defined by a memory bitmap. 1051 BS_PATTERN8X8: // Same as BS_PATTERN. 1052 begin 1053 GObject^.GDIBrushPixmap := nil; 1054 if IsValidGDIObject(lbHatch) and ({%H-}PGdiObject(lbHatch)^.GDIType = gdiBitmap) then 1055 begin 1056 case {%H-}PGdiObject(lbHatch)^.GDIBitmapType of 1057 gbBitmap: 1058 begin 1059 GObject^.GDIBrushPixmap := {%H-}PGdiObject(lbHatch)^.GDIBitmapObject; 1060 GObject^.GDIBrushFill := GDK_STIPPLED; 1061 end; 1062 gbPixmap: 1063 begin 1064 GObject^.GDIBrushPixmap := {%H-}PGdiObject(lbHatch)^.GDIPixmapObject.Image; 1065 GObject^.GDIBrushFill := GDK_TILED; 1066 end; 1067 gbPixbuf: 1068 begin 1069 GObject^.GDIBrushPixmap := nil; 1070 TmpMask := nil; 1071 gdk_pixbuf_render_pixmap_and_mask({%H-}PGdiObject(lbHatch)^.GDIPixbufObject, 1072 GObject^.GDIBrushPixmap, TmpMask, $80); 1073 gdk_pixmap_unref(TmpMask); 1074 end; 1075 else 1076 begin 1077 DebugLn('TGtk2WidgetSet.CreateBrushIndirect: Unsupported GDIBitmapType') 1078 end; 1079 end 1080 end 1081 else 1082 RaiseGDBException('unsupported bitmap'); 1083 if GObject^.GDIBrushPixmap <> nil then 1084 gdk_pixmap_ref(GObject^.GDIBrushPixmap); 1085 end; 1086 else 1087 RaiseGDBException(Format('unsupported Style %d',[lbStyle])); 1088 end; 1089 1090 {$IFDEF DebugGDKTraps} 1091 EndGDKErrorTrap; 1092 {$ENDIF} 1093 1094 if not GObject^.IsNullBrush then 1095 SetGDIColorRef(GObject^.GDIBrushColor, lbColor); 1096 end; 1097 Result := HBRUSH({%H-}PtrUInt(GObject)); 1098 except 1099 Result:=0; 1100 DisposeGDIObject(GObject); 1101 DebugLn('TGtk2WidgetSet.CreateBrushIndirect failed'); 1102 end; 1103 //DebugLn(Format('Trace:< [TGtk2WidgetSet.CreateBrushIndirect] Got --> %x', [Result])); 1104end; 1105 1106{------------------------------------------------------------------------------ 1107 Function: CreateCaret 1108 Params: none 1109 Returns: Nothing 1110 1111 1112 ------------------------------------------------------------------------------} 1113function TGtk2WidgetSet.CreateCaret(Handle: HWND; Bitmap: hBitmap; width, 1114 Height: Integer): Boolean; 1115var 1116 GTKObject: PGTKObject; 1117 BMP: PGDKPixmap; 1118begin 1119 //DebugLn('Trace:TODO: [TGtk2WidgetSet.CreateCaret] Finish'); 1120 1121 GTKObject := {%H-}PGTKObject(Handle); 1122 Result := GTKObject <> nil; 1123 1124 if Result then begin 1125 if gtk_type_is_a(g_object_type(GTKObject), GTKAPIWidget_GetType) 1126 then begin 1127 if IsValidGDIObjectType(Bitmap, gdiBitmap) then 1128 BMP := {%H-}PGdiObject(Bitmap)^.GDIBitmapObject 1129 else 1130 BMP := nil; 1131 GTKAPIWidget_CreateCaret(PGTKAPIWidget(GTKObject), Width, Height, BMP); 1132 end 1133// else if // TODO: other widgettypes 1134 else begin 1135 Result := False; 1136 end; 1137 end; 1138end; 1139 1140{------------------------------------------------------------------------------ 1141 Function: CreateCompatibleBitmap 1142 Params: DC: 1143 Width: 1144 Height: 1145 Returns: 1146 1147 Creates a bitmap compatible with the specified device context. 1148 ------------------------------------------------------------------------------} 1149function TGtk2WidgetSet.CreateCompatibleBitmap(DC: HDC; Width, Height: Integer): HBITMAP; 1150var 1151 DevCtx: TGtkDeviceContext absolute DC; 1152 1153 GDIObject: PGdiObject; 1154 Depth : Longint; 1155 Drawable, DefDrawable: PGDkDrawable; 1156begin 1157 //DebugLn(Format('Trace:> [TGtk2WidgetSet.CreateCompatibleBitmap] DC: 0x%x, W: %d, H: %d', [DC, Width, Height])); 1158 1159 if IsValidDC(DC) and (DevCtx.Drawable <> nil) 1160 then begin 1161 DefDrawable := DevCtx.Drawable; 1162 Depth := gdk_drawable_get_depth(DevCtx.Drawable); 1163 end 1164 else begin 1165 DefDrawable := nil; 1166 Depth := gdk_visual_get_system^.Depth; 1167 end; 1168 1169 1170 if (Depth < 1) or (Depth > 32) 1171 then begin 1172 Result := 0; 1173 DebugLn(Format('ERROR: [TGtk2WidgetSet.CreateCompatibleBitmap] Illegal depth %d', [Depth])); 1174 Exit; 1175 end; 1176 1177 GdiObject := NewGDIObject(gdiBitmap); 1178 1179 Drawable := gdk_pixmap_new(DefDrawable, Width, Height, Depth); 1180 GdiObject^.Visual := gdk_window_get_visual(Drawable); 1181 if Depth = 1 1182 then begin 1183 GdiObject^.GDIBitmapType := gbBitmap; 1184 GdiObject^.GDIBitmapObject := Drawable; 1185 end 1186 else begin 1187 GdiObject^.GDIBitmapType := gbPixmap; 1188 GdiObject^.GDIPixmapObject.Image := Drawable; 1189 end; 1190 1191 if GdiObject^.Visual = nil 1192 then begin 1193 GdiObject^.Visual := gdk_visual_get_best_with_depth(Depth); 1194 if GdiObject^.Visual = nil 1195 then GdiObject^.Visual := gdk_visual_get_system; 1196 GdiObject^.SystemVisual := True; 1197 end 1198 else begin 1199 gdk_visual_ref(GdiObject^.Visual); 1200 GdiObject^.SystemVisual := False; 1201 end; 1202 1203 GdiObject^.Colormap := gdk_colormap_new(GdiObject^.Visual, GdkTrue); 1204 1205 Result := HBITMAP({%H-}PtrUInt(GdiObject)); 1206 1207 //DebugLn(Format('Trace:< [TGtk2WidgetSet.CreateCompatibleBitmap] DC: 0x%x --> 0x%x', [DC, Result])); 1208end; 1209 1210{------------------------------------------------------------------------------ 1211 Function: CreateCompatibleDC 1212 Params: none 1213 Returns: Nothing 1214 ------------------------------------------------------------------------------} 1215function TGtk2WidgetSet.CreateCompatibleDC(DC: HDC): HDC; 1216var 1217 pNewDC: TGtkDeviceContext; 1218begin 1219 Result := 0; 1220 pNewDC := NewDC; 1221 1222 // ToDo: TGtk2WidgetSet.CreateCompatibleDC: when is a DC compatible? 1223 1224 // do not copy 1225 // In a compatible DC you have to select a bitmap into it 1226(* 1227 if IsValidDC(DC) then 1228 with TGtkDeviceContext(DC)^ do 1229 begin 1230 pNewDC^.hWnd := hWnd; 1231 pNewDC^.Drawable := Drawable; 1232 pNewDC^.GC := gdk_gc_new(Drawable); 1233 end 1234 else begin 1235 // We can't do anything yet 1236 // Wait till a bitmap get selected 1237 end; 1238*) 1239 with pNewDC do 1240 begin 1241 gdk_color_black(gdk_colormap_get_system, @CurrentTextColor.Color); 1242 BuildColorRefFromGDKColor(CurrentTextColor); 1243 gdk_color_white(gdk_colormap_get_system, @CurrentBackColor.Color); 1244 BuildColorRefFromGDKColor(CurrentBackColor); 1245 end; 1246 Result := HDC(pNewDC); 1247 1248 //DebugLn(Format('trace: [TGtk2WidgetSet.CreateCompatibleDC] DC: 0x%x --> 0x%x', [Integer(DC), Integer(Result)])); 1249end; 1250 1251function TGtk2WidgetSet.DestroyCursor(Handle: HCURSOR): Boolean; 1252begin 1253 Result := Handle <> 0; 1254 if Result then 1255 gdk_cursor_destroy({%H-}PGdkCursor(Handle)); 1256end; 1257 1258function TGtk2WidgetSet.DestroyIcon(Handle: HICON): Boolean; 1259begin 1260 Result := (Handle <> 0) and 1261 ( 1262 GDK_IS_PIXBUF({%H-}Pointer(Handle)) or 1263 // todo: replace with GDK_IS_CURSOR when fpc will have it 1264 G_TYPE_CHECK_INSTANCE_TYPE({%H-}Pointer(Handle),GDK_TYPE_CURSOR) 1265 ); 1266 if Result then 1267 if GDK_IS_PIXBUF({%H-}Pointer(Handle)) then 1268 gdk_pixbuf_unref({%H-}PGdkPixbuf(Handle)) 1269 else 1270 gdk_cursor_unref({%H-}PGdkCursor(Handle)); 1271end; 1272 1273function TGtk2WidgetSet.DPtoLP(DC: HDC; var Points; Count: Integer): BOOL; 1274var 1275 DevCtx: TGtkDeviceContext absolute DC; 1276 P: PPoint; 1277begin 1278 Result := False; 1279 1280 if not IsValidDC(DC) then Exit(False); 1281 1282 if not DevCtx.HasTransf then Exit(True); 1283 1284 P := @Points; 1285 while Count > 0 do 1286 begin 1287 Dec(Count); 1288 DevCtx.InvTransfPoint(P^.X, P^.Y); 1289 Inc(P); 1290 end; 1291 1292 Result := True; 1293end; 1294 1295{ 1296 Gtk2 has no function to build an elliptical region so we approximate it to a 1297 polygon. Our Ellipse is axis-aligned, so it's parametrization is: 1298 1299 X(t) = Xc + a * cos(t) 1300 Y(t) = Yc + b * sin(t) 1301 1302 (Xc,Yc) is the center of the ellipse 1303} 1304function TGtk2WidgetSet.CreateEllipticRgn(X1, Y1, X2, Y2: Integer): HRGN; 1305var 1306 points: array of TGdkPoint; 1307 n_points: Integer; 1308 i, Xc, Yc, a, b: Integer; 1309 t: Double; 1310 GObject: PGdiObject; 1311 RegionObj: PGdkRegion; 1312begin 1313 a := (X2 - X1) div 2; 1314 b := (Y2 - Y1) div 2; 1315 Xc := X1 + a; 1316 Yc := Y1 + b; 1317 1318 // Choose a large enough amount of points 1319 n_points := Max(X2-X1,Y2-Y1) * 4; 1320 SetLength(points{%H-}, n_points); 1321 // And fill them iterating through the ellipse 1322 for i := 0 to n_points - 1 do 1323 begin 1324 t := (i / n_points) * 2 * Pi; 1325 points[i].X := Round(Xc + a * cos(t)); 1326 points[i].Y := Round(Yc + b * sin(t)); 1327 end; 1328 1329 GObject := NewGDIObject(gdiRegion); 1330 RegionObj := gdk2.gdk_region_polygon(@points[0], n_points, GDK_WINDING_RULE); 1331 GObject^.GDIRegionObject := RegionObj; 1332 1333 Result := HRGN({%H-}PtrUInt(GObject)); 1334 1335 // Free the allocated array 1336 SetLength(points, 0); 1337 //DebugLn('TGtk2WidgetSet.CreateRectRgn A ',GDKRegionAsString(RegionObj)); 1338end; 1339 1340{------------------------------------------------------------------------------ 1341 Function: CreateFontIndirect 1342 Params: const LogFont: TLogFont 1343 Returns: HFONT 1344 1345 Creates a font GDIObject. 1346 ------------------------------------------------------------------------------} 1347function TGtk2WidgetSet.CreateFontIndirect(const LogFont: TLogFont): HFONT; 1348begin 1349 Result := CreateFontIndirectEx(LogFont,''); 1350end; 1351 1352{------------------------------------------------------------------------------ 1353 Function: CreateFontIndirectEx 1354 Params: const LogFont: TLogFont; const LongFontName: string 1355 Returns: HFONT 1356 1357 Creates a font GDIObject. 1358 ------------------------------------------------------------------------------} 1359function TGtk2WidgetSet.CreateFontIndirectEx(const LogFont: TLogFont; 1360 const LongFontName: string): HFONT; 1361{off $DEFINE VerboseFonts} 1362var 1363 GdiObject: PGdiObject; 1364 FullString, aFamily, aStyle, ALongFontName: String; 1365 aSize: Integer; 1366 aSizeInPixels: Boolean; 1367 PangoDesc: PPangoFontDescription; 1368 CachedFont: TGtkFontCacheDescriptor; 1369 AttrList: PPangoAttrList; 1370 AttrListTemporary: Boolean; 1371 Attr: PPangoAttribute; 1372 CurFont: PPangoLayout; 1373 TmpStr: PChar; 1374begin 1375 {$IFDEF VerboseFonts} 1376 DebugLn('TGtk2WidgetSet.CreateFontIndirectEx A Name=',LogFont.lfFaceName,' Height=',dbgs(LogFont.lfHeight),' LongName=',LongFontName); 1377 {$ENDIF} 1378 Result := 0; 1379 PangoDesc := nil; 1380 GdiObject := nil; 1381 if LongFontName = '' then 1382 ALongFontName := LogFont.lfFaceName 1383 else 1384 ALongFontName := LongFontName; 1385 try 1386 // first search in cache 1387 CachedFont:=FontCache.FindGTkFontDesc(LogFont, ALongFontName); 1388 if CachedFont<>nil then begin 1389 CachedFont.Item.IncreaseRefCount; 1390 GdiObject := NewGdiObject(gdiFont); 1391 GdiObject^.UntransfFontHeight := 0; 1392 GdiObject^.GDIFontObject := TGtkFontCacheItem(CachedFont.Item).GtkFont; 1393 {$IFDEF VerboseFonts} 1394 WriteLn('Was already in cache'); 1395 {$ENDIF} 1396 exit; 1397 end; 1398 1399 with LogFont do 1400 begin 1401 if lfFaceName[0] = #0 1402 then begin 1403 //DebugLn('ERROR: [Tgt2kObject.CreateFontIndirectEx] No fontname'); 1404 Exit; 1405 end; 1406 1407 // if we have really default font 1408 if (lfHeight = 0) and 1409 (lfWeight = FW_NORMAL) and 1410 (lfItalic = 0) and 1411 (lfUnderline = 0) and 1412 (lfStrikeOut = 0) and 1413 (lfOrientation = 0) and 1414 IsFontNameDefault(lfFacename) then 1415 begin 1416 // use default font 1417 {$IFDEF VerboseFonts} 1418 DebugLn(['TGtk2WidgetSet.CreateFontIndirectEx Creating default font']); 1419 {$ENDIF} 1420 GdiObject := CreateDefaultFont; 1421 exit; 1422 end; 1423 1424 FontNameToPangoFontDescStr(ALongFontname, aFamily, aStyle, aSize, aSizeInPixels); 1425 1426 // if font specified size, prefer this instead of 'possibly' inaccurate 1427 // lfHeight note that lfHeight may actually have a most accurate value 1428 // but there is no way to know this at this point. 1429 1430 // setting the size, this could be done in two ways 1431 // method 1: fontdesc using fontname like "helvetica 12" 1432 // method 2: fontdesc using fontname like "helvetica" and later modify size 1433 1434 // to obtain consistent font sizes method 2 should be used 1435 // for method 1 converting lfheight to fontsize can lead to rounding errors 1436 // for example, font size=12, lfheight=-12 (75dpi), at 75 dpi aSize=11 1437 // so we would get a font "helvetica 11" instead of "helvetica 12" 1438 // size information, and later modify font size 1439 1440 // using method 2 1441 1442 if IsFontNameDefault(aFamily) then 1443 begin 1444 CurFont := GetDefaultGtkFont(False); 1445 if PANGO_IS_LAYOUT(CurFont) then 1446 begin 1447 PangoDesc := pango_layout_get_font_description(CurFont); 1448 if PangoDesc = nil then 1449 PangoDesc := pango_context_get_font_description(pango_layout_get_context(CurFont)); 1450 aFamily := StrPas(pango_font_description_get_family(PangoDesc)); 1451 if (aSize = 0) and (lfHeight = 0) then 1452 begin 1453 aSize := pango_font_description_get_size(PangoDesc); 1454 if not pango_font_description_get_size_is_absolute(PangoDesc) then 1455 aSize := aSize div PANGO_SCALE; 1456 end; 1457 end; 1458 end; 1459 1460 if (aSize = 0) and (lfHeight = 0) then 1461 FullString := '10' // use some default: TODO: find out the default size of the widget 1462 else 1463 if aSize > 0 then 1464 begin 1465 FullString := IntToStr(aSize); 1466 if aSizeInPixels then 1467 FullString := FullString + 'px'; 1468 end 1469 else 1470 FullString := ''; 1471 1472 if Pos(',', AFamily) > 0 then 1473 FullString := AFamily + ' ' + aStyle + ' ' + FullString 1474 else 1475 FullString := AFamily + ', ' + aStyle + ' ' + FullString; 1476 PangoDesc := pango_font_description_from_string(PChar(FullString)); 1477 1478 if (pango_font_description_get_weight(PangoDesc) = PANGO_WEIGHT_NORMAL) 1479 and (lfWeight <> FW_DONTCARE) then 1480 pango_font_description_set_weight(PangoDesc, lfWeight); 1481 1482 if (pango_font_description_get_style (PangoDesc) = PANGO_STYLE_NORMAL) 1483 and (lfItalic <> 0) then 1484 pango_font_description_set_style(PangoDesc, PANGO_STYLE_ITALIC); 1485 TmpStr := pango_font_description_to_string(PangoDesc); 1486 aStyle := TmpStr; 1487 g_free(TmpStr); 1488 if (aSize=0) and (lfHeight<>0) then 1489 begin 1490 // a size is not specified, try to calculate one based on lfHeight 1491 // and use this value not in the font name but set this value appart 1492 // NOTE: in gtk2.8 is possible to use pango_font_description_set_absolute_size 1493 // which would be great with the given lfheight value, but older gtk2 version 1494 // doesn't have this function 1495 if lfHeight < 0 then 1496 aSize := -lfHeight * PANGO_SCALE 1497 else 1498 aSize := lfHeight * PANGO_SCALE; 1499 pango_font_description_set_absolute_size(PangoDesc, aSize); 1500 end; 1501 1502 // create font 1503 // TODO: use context widget (CreateFontIndirectEx needs a parameter for this: Context: HWnd) 1504 GdiObject := NewGdiObject(gdiFont); 1505 GdiObject^.UntransfFontHeight := 0; 1506 GdiObject^.GDIFontObject:=gtk_widget_create_pango_layout( 1507 GetStyleWidget(lgsdefault), nil); 1508 CurFont:=GdiObject^.GDIFontObject; 1509 1510 pango_layout_set_font_description(CurFont,PangoDesc); 1511 1512 if (LogFont.lfUnderline<>0) or (LogFont.lfStrikeOut<>0) then 1513 begin 1514 AttrListTemporary := false; 1515 AttrList := pango_layout_get_attributes(CurFont); 1516 if (AttrList = nil) then 1517 begin 1518 AttrList := pango_attr_list_new(); 1519 AttrListTemporary := True; 1520 end; 1521 1522 if LogFont.lfUnderline<>0 then 1523 begin 1524 Attr := pango_attr_underline_new(PANGO_UNDERLINE_SINGLE); 1525 pango_attr_list_change(AttrList, Attr); 1526 end; 1527 1528 if LogFont.lfStrikeOut<>0 then 1529 begin 1530 Attr := pango_attr_strikethrough_new(True); 1531 pango_attr_list_change(AttrList, Attr); 1532 end; 1533 1534 pango_layout_set_attributes(CurFont, AttrList); 1535 1536 if AttrListTemporary then 1537 pango_attr_list_unref(AttrList); 1538 end; 1539 1540 pango_layout_set_single_paragraph_mode(CurFont, True); 1541 pango_layout_set_width(CurFont, -1); 1542 pango_layout_set_alignment(CurFont, PANGO_ALIGN_LEFT); 1543 1544 if (lfEscapement <> 0) then 1545 begin 1546 // the rotation is done via the pango matrix of the context 1547 // it must be set by the device context 1548 end; 1549 end; 1550 finally 1551 if (CachedFont = nil) and (GdiObject<>nil) and (GdiObject^.GDIFontObject <> nil) then 1552 begin 1553 // add to cache 1554 CachedFont := FontCache.Add(GdiObject^.GDIFontObject, LogFont, ALongFontName); 1555 //decrement refcount for GdiObject^.GDIFontObject so that object gets 1556 //released when removing from FontCache. 1557 g_object_unref(GdiObject^.GDIFontObject); 1558 if CachedFont <> nil then 1559 begin 1560 CachedFont.PangoFontDescription := PangoDesc; 1561 PangoDesc := nil; 1562 end; 1563 end; 1564 {$IFDEF VerboseFonts} 1565 if (GdiObject<>nil) and (GdiObject^.GDIFontObject <> nil) then begin 1566 DebugLn(['TGtk2WidgetSet.CreateFontIndirectEx New pangolayout=',dbgs(GdiObject^.GDIFontObject),' Cached=',FontCache.FindGTKFont(GdiObject^.GDIFontObject)<>nil]); 1567 end; 1568 {$ENDIF} 1569 // clean up helper objects 1570 if PangoDesc<>nil then 1571 pango_font_description_free(PangoDesc); 1572 1573 if (GdiObject<>nil) then begin 1574 if (GdiObject^.GDIFontObject = nil) then begin 1575 DebugLn(['TGtk2WidgetSet.CreateFontIndirectEx Unable to create font A']); 1576 DisposeGDIObject(GdiObject); 1577 Result := 0; 1578 end else begin 1579 // return the new font 1580 GdiObject^.LogFont:=LogFont; 1581 Result := HFONT({%H-}PtrUInt(GdiObject)); 1582 end; 1583 end else begin 1584 {$IFDEF VerboseFonts} 1585 DebugLn(['TGtk2WidgetSet.CreateFontIndirectEx Unable to create font B']); 1586 {$ENDIF} 1587 end; 1588 {$IFDEF VerboseFonts} 1589 DebugLn(['TGtk2WidgetSet.CreateFontIndirectEx END Result=',dbgs(Pointer(PtrInt(Result)))]); 1590 {$ENDIF} 1591 end; 1592end; 1593 1594function TGtk2WidgetSet.CreateIconIndirect(IconInfo: PIconInfo): HICON; 1595var 1596 bitmap: PGdkBitmap; 1597 pixmap: PGdkPixmap; 1598 pixbuf: PGdkPixbuf; 1599 Width, Height: integer; 1600 MaxWidth, MaxHeight: guint; 1601begin 1602 Result := 0; 1603 if not IsValidGDIObject(IconInfo^.hbmColor) then Exit; 1604 1605 if {%H-}PGDIObject(IconInfo^.hbmColor)^.GDIBitmapType = gbPixbuf then 1606 begin 1607 pixbuf := gdk_pixbuf_copy({%H-}PGDIObject(IconInfo^.hbmColor)^.GDIPixbufObject); 1608 end 1609 else 1610 begin 1611 pixmap := {%H-}PGDIObject(IconInfo^.hbmColor)^.GDIPixmapObject.Image; 1612 //DbgDumpPixmap(pixmap, ''); 1613 1614 gdk_drawable_get_size(pixmap, @Width, @Height); 1615 1616 if not IconInfo^.fIcon then 1617 begin 1618 gdk_display_get_maximal_cursor_size(gdk_display_get_default, 1619 @MaxWidth, @MaxHeight); 1620 1621 if (Width > integer(MaxWidth)) 1622 or (Height > integer(MaxHeight)) then Exit; 1623 end; 1624 1625 bitmap := CreateGdkMaskBitmap(IconInfo^.hbmColor, IconInfo^.hbmMask); 1626 pixbuf := CreatePixbufFromImageAndMask(pixmap, 0, 0, Width, Height, nil, bitmap); 1627 if bitmap <> nil then 1628 gdk_bitmap_unref(bitmap); 1629 end; 1630 1631 if IconInfo^.fIcon then 1632 begin 1633 Result := HICON({%H-}PtrUInt(pixbuf)); 1634 end 1635 else 1636 begin 1637 // create cursor from pixbuf 1638 Result := HCURSOR({%H-}PtrUInt(gdk_cursor_new_from_pixbuf(gdk_display_get_default, 1639 pixbuf, IconInfo^.xHotSpot, IconInfo^.yHotSpot))); 1640 if pixbuf <> nil then 1641 gdk_pixbuf_unref(pixbuf); 1642 end; 1643end; 1644 1645{------------------------------------------------------------------------------ 1646 Function: CreatePalette 1647 Params: LogPalette 1648 Returns: a handle to the Palette created 1649 1650 1651 ------------------------------------------------------------------------------} 1652function TGtk2WidgetSet.CreatePalette(const LogPalette: TLogPalette): HPALETTE; 1653var 1654 GObject: PGdiObject; 1655begin 1656 //DebugLn('trace:[TGtk2WidgetSet.CreatePalette]'); 1657 1658 GObject := NewGDIObject(gdiPalette); 1659 GObject^.SystemPalette := False; 1660 GObject^.PaletteRealized := False; 1661 GObject^.VisualType := GDK_VISUAL_PSEUDO_COLOR; 1662 GObject^.PaletteVisual := nil; 1663 1664 {$IFDEF DebugGDKTraps} 1665 BeginGDKErrorTrap; 1666 {$ENDIF} 1667 1668 GObject^.PaletteVisual := gdk_visual_get_best_with_type(GObject^.VisualType); 1669 if GObject^.PaletteVisual = nil 1670 then begin 1671 GObject^.PaletteVisual := GDK_Visual_Get_System; 1672 GDK_Visual_Ref(GObject^.PaletteVisual); 1673 end; 1674 GObject^.PaletteColormap := GDK_Colormap_new(GObject^.PaletteVisual, GdkTrue); 1675 1676 {$IFDEF DebugGDKTraps} 1677 EndGDKErrorTrap; 1678 {$ENDIF} 1679 1680 GObject^.RGBTable := TDynHashArray.Create(-1); 1681 GObject^.RGBTable.OnGetKeyForHashItem:=@GetRGBAsKey; 1682 GObject^.IndexTable := TDynHashArray.Create(-1); 1683 GObject^.IndexTable.OnGetKeyForHashItem:=@GetIndexAsKey; 1684 InitializePalette(GObject, LogPalette.palPalEntry, LogPalette.palNumEntries); 1685 1686 Result := HPALETTE({%H-}PtrUInt(GObject)); 1687end; 1688 1689{------------------------------------------------------------------------------ 1690 Function: CreatePenIndirect 1691 Params: none 1692 Returns: Nothing 1693 1694 1695 ------------------------------------------------------------------------------} 1696function TGtk2WidgetSet.CreatePenIndirect(const LogPen: TLogPen): HPEN; 1697var 1698 GObject: PGdiObject; 1699begin 1700 //DebugLn('trace:[TGtk2WidgetSet.CreatePenIndirect]'); 1701//write('CreatePenIndirect->'); 1702 GObject := NewGDIObject(gdiPen); 1703 GObject^.UnTransfPenWidth := 0; 1704 GObject^.GDIPenDashes := nil; 1705 1706 GObject^.IsExtPen := False; 1707 with LogPen do 1708 begin 1709 GObject^.GDIPenStyle := lopnStyle; 1710 GObject^.GDIPenWidth := lopnWidth.X; 1711 SetGDIColorRef(GObject^.GDIPenColor,lopnColor); 1712 end; 1713 1714 Result := HPEN({%H-}PtrUInt(GObject)); 1715end; 1716 1717{------------------------------------------------------------------------------ 1718 Method: CreatePolygonRgn 1719 Params: Points, NumPts, FillMode 1720 Returns: the handle to the region 1721 1722 Creates a Polygon, a closed many-sided shaped region. The Points parameter is 1723 an array of points that give the vertices of the polygon. FillMode=Winding 1724 determines what points are going to be included in the region. When Winding 1725 is True, points are selected by using the Winding fill algorithm. When Winding 1726 is False, points are selected by using using the even-odd (alternative) fill 1727 algorithm. NumPts indicates the number of points to use. 1728 The first point is always connected to the last point. 1729 ------------------------------------------------------------------------------} 1730function TGtk2WidgetSet.CreatePolygonRgn(Points: PPoint; NumPts: Integer; 1731 FillMode: integer): HRGN; 1732var 1733 i: integer; 1734 PointArray: PGDKPoint; 1735 GObject: PGdiObject; 1736 fr : TGDKFillRule; 1737begin 1738 Result := 0; 1739 if NumPts<=1 then exit; // gdk_region_polygon will crash on a polygon with 1 point 1740 GObject := NewGDIObject(gdiRegion); 1741 1742 GetMem(PointArray,SizeOf(TGdkPoint)*NumPts); 1743 for i:=0 to NumPts-1 do begin 1744 PointArray[i].x:=Points[i].x; 1745 PointArray[i].y:=Points[i].y; 1746 end; 1747 1748 If FillMode=Winding then 1749 fr := GDK_WINDING_RULE 1750 else 1751 fr := GDK_EVEN_ODD_RULE; 1752 1753 GObject^.GDIRegionObject := gdk_region_polygon(PointArray, NumPts, fr); 1754 1755 FreeMem(PointArray); 1756 1757 Result := HRGN({%H-}PtrUInt(GObject)); 1758end; 1759 1760{------------------------------------------------------------------------------ 1761 Function: CreateRectRgn 1762 Params: none 1763 Returns: Nothing 1764 ------------------------------------------------------------------------------} 1765function TGtk2WidgetSet.CreateRectRgn(X1,Y1,X2,Y2 : Integer): HRGN; 1766var 1767 R: TGDKRectangle; 1768 RRGN: PGDKRegion; 1769 GObject: PGdiObject; 1770 RegionObj: PGdkRegion; 1771begin 1772 GObject := NewGDIObject(gdiRegion); 1773 if X1<=X2 then begin 1774 R.X := gint16(X1); 1775 R.Width := X2 - X1; 1776 end else begin 1777 R.X := gint16(X2); 1778 R.Width := X1 - X2; 1779 end; 1780 if Y1<=Y2 then begin 1781 R.Y := gint16(Y1); 1782 R.Height := Y2 - Y1; 1783 end else begin 1784 R.Y := gint16(Y2); 1785 R.Height := Y1 - Y1; 1786 end; 1787 1788 RRGN := gdk_region_new; 1789 RegionObj:=PGdkRegion(gdk_region_union_with_rect(RRGN,@R)); 1790 GObject^.GDIRegionObject := RegionObj; 1791 gdk_region_destroy(RRGN); 1792 1793 Result := HRGN({%H-}PtrUInt(GObject)); 1794 //DebugLn('TGtk2WidgetSet.CreateRectRgn A ',GDKRegionAsString(RegionObj)); 1795end; 1796 1797{------------------------------------------------------------------------------ 1798 Function: CombineRgn 1799 Params: Dest, Src1, Src2, fnCombineMode 1800 Returns: longint 1801 1802 Combine the 2 Source Regions into the Destination Region using the specified 1803 Combine Mode. The Destination must already be initialized. The Return value 1804 is the Destination's Region type, or ERROR. 1805 1806 The Combine Mode can be one of the following: 1807 RGN_AND : Gets a region of all points which are in both source regions 1808 1809 RGN_COPY : Gets an exact copy of the first source region 1810 1811 RGN_DIFF : Gets a region of all points which are in the first source 1812 region but not in the second.(Source1 - Source2) 1813 1814 RGN_OR : Gets a region of all points which are in either the first 1815 source region or in the second.(Source1 + Source2) 1816 1817 RGN_XOR : Gets all points which are in either the first Source Region 1818 or in the second, but not in both. 1819 1820 The result can be one of the following constants 1821 Error 1822 NullRegion 1823 SimpleRegion 1824 ComplexRegion 1825 ------------------------------------------------------------------------------} 1826function TGtk2WidgetSet.CombineRgn(Dest, Src1, Src2: HRGN; 1827 fnCombineMode: Longint): Longint; 1828var 1829 Continue: Boolean; 1830 D, S1, S2: PGDKRegion; 1831 DObj, S1Obj, S2Obj: PGDIObject; 1832begin 1833 Result := SIMPLEREGION; 1834 DObj := {%H-}PGdiObject(Dest); 1835 S1Obj := {%H-}PGdiObject(Src1); 1836 S2Obj := {%H-}PGdiObject(Src2); 1837 Continue := IsValidGDIObject(Dest) and IsValidGDIObject(Src1) 1838 and IsValidGDIObject(Src2); 1839 if not Continue then begin 1840 DebugLn('WARNING: [TGtk2WidgetSet.CombineRgn] Invalid HRGN'); 1841 exit(Error); 1842 end; 1843 if DObj^.RefCount>1 then 1844 begin 1845 DebugLn('WARNING: [TGtk2WidgetSet.CombineRgn] Invalid Dest'); 1846 exit(RegionType(DObj^.GDIRegionObject)); 1847 end; 1848 1849 S1 := S1Obj^.GDIRegionObject; 1850 S2 := S2Obj^.GDIRegionObject; 1851 //DebugLn('TGtk2WidgetSet.CombineRgn A fnCombineMode=',Dbgs(fnCombineMode)); 1852 case fnCombineMode of 1853 RGN_AND : 1854 D := PGDKRegion(gdk_region_intersect(S1, S2)); 1855 RGN_COPY : 1856 D := gdk_region_copy(S1); 1857 RGN_DIFF : 1858 D := PGDKRegion(gdk_region_subtract(S1, S2)); 1859 RGN_OR : 1860 D := PGDKRegion(gdk_region_union(S1, S2)); 1861 RGN_XOR : 1862 D := PGDKRegion(gdk_region_xor(S1, S2)); 1863 else begin 1864 Result:= ERROR; 1865 D := nil; 1866 end; 1867 end; 1868 if Assigned(DObj^.GDIRegionObject) then 1869 gdk_region_destroy(DObj^.GDIRegionObject); 1870 DObj^.GDIRegionObject := D; 1871 Result := RegionType(D); 1872 //DebugLn('TGtk2WidgetSet.CombineRgn B Mode=',dbgs(fnCombineMode), 1873 // ' S1=',GDKRegionAsString(S1),' S2=',GDKRegionAsString(S2),' D=',GDKRegionAsString(D),''); 1874end; 1875 1876{------------------------------------------------------------------------------ 1877 Function: DeleteDC 1878 Params: none 1879 Returns: Nothing 1880 ------------------------------------------------------------------------------} 1881function TGtk2WidgetSet.DeleteDC(hDC: HDC): Boolean; 1882begin 1883 // TODO: 1884 // for now it's just the same, however CreateDC/FreeDC 1885 // and GetDC/ReleaseDC are couples 1886 // we should use gdk_new_gc for create and gtk_new_gc for Get 1887 Result:= (ReleaseDC(0, hDC) = 1); 1888end; 1889 1890{------------------------------------------------------------------------------ 1891 Function: DeleteObject 1892 Params: none 1893 Returns: Nothing 1894 1895 DeleteObject is allowed while the object is still selected. The msdn docs 1896 are misleading. Marc tested with resource profiler under win XP. 1897 ------------------------------------------------------------------------------} 1898function TGtk2WidgetSet.DeleteObject(GDIObject: HGDIOBJ): Boolean; 1899 1900 procedure RaiseInvalidGDIObject; 1901 begin 1902 {$ifdef TraceGdiCalls} 1903 DebugLn(); 1904 DebugLn('TGtk2WidgetSet.DeleteObject: TraceCall for invalid object: '); 1905 DumpBackTrace(PgdiObject(GdiObject)^.StackAddrs); 1906 DebugLn(); 1907 DebugLn('Exception will follow:'); 1908 DebugLn(); 1909 {$endif} 1910 RaiseGDBException('TGtk2WidgetSet.DeleteObject invalid GdiObject='+dbgs(GdiObject)); 1911 end; 1912 1913var 1914 GDIObjectExists: boolean; 1915begin 1916 if GDIObject = 0 then 1917 begin 1918 Result := True; 1919 Exit; 1920 end; 1921 {$IFDEF DebugLCLComponents} 1922 if DebugGdiObjects.IsDestroyed(Pointer(GDIObject)) then 1923 begin 1924 DebugLn(['TGtk2WidgetSet.DeleteObject object already deleted ',GDIObject]); 1925 debugln(DebugGdiObjects.GetInfo(PGdiObject(GDIObject),true)); 1926 Halt; 1927 end; 1928 {$ENDIF} 1929 1930 // Find out if we want to release internal GDI object 1931 GDIObjectExists := FGDIObjects.Contains({%H-}PGdiObject(GDIObject)); 1932 Result := GDIObjectExists; 1933 if not GDIObjectExists then 1934 begin 1935 RaiseInvalidGDIObject; 1936 end; 1937 1938 Result := ReleaseGDIObject({%H-}PGdiObject(GDIObject)); 1939end; 1940 1941function TGtk2WidgetSet.DestroyCaret(Handle: HWND): Boolean; 1942var 1943 GTKObject: PGTKObject; 1944begin 1945 GTKObject := {%H-}PGTKObject(Handle); 1946 Result := true; 1947 1948 if GTKObject<>nil then begin 1949 if gtk_type_is_a(g_object_type(GTKObject), GTKAPIWidget_GetType) 1950 then begin 1951 GTKAPIWidget_DestroyCaret(PGTKAPIWidget(GTKObject)); 1952 end 1953// else if // TODO: other widgettypes 1954 else begin 1955 Result := False; 1956 end; 1957 end; 1958end; 1959 1960function TGtk2WidgetSet.DrawFrameControl(DC: HDC; const Rect : TRect; 1961 uType, uState : Cardinal) : Boolean; 1962{const 1963 ADJUST_FLAG: array[Boolean] of Integer = (0, BF_ADJUST); 1964 PUSH_EDGE_FLAG: array[Boolean] of Integer = (EDGE_RAISED, EDGE_SUNKEN); 1965 PUSH_EDGE_FLAG2: array[Boolean] of Integer = (0, BF_FLAT);} 1966var 1967 DevCtx: TGtkDeviceContext absolute DC; 1968 Widget: PGtkWidget; 1969 R: TRect; 1970 ClipArea: TGdkRectangle; 1971 1972 procedure DrawButtonPush; 1973 var 1974 State: TGtkStateType; 1975 Shadow: TGtkShadowType; 1976 aStyle : PGTKStyle; 1977 aDC: TGtkDeviceContext; 1978 DCOrigin: TPoint; 1979 begin 1980 //if Widget<>nil then begin 1981 1982 // use the gtk paint functions to draw a widget style dependent button 1983 1984 //writeln('DrawButtonPush ', 1985 // ' DFCS_BUTTONPUSH=',uState and DFCS_BUTTONPUSH, 1986 // ' DFCS_PUSHED=',uState and DFCS_PUSHED, 1987 // ' DFCS_INACTIVE=',uState and DFCS_INACTIVE, 1988 // ' DFCS_FLAT=',uState and DFCS_FLAT, 1989 // ''); 1990 // set State (the interior filling style) 1991 if (DFCS_PUSHED and uState)<>0 then 1992 State := GTK_STATE_ACTIVE //button pressed(GTK ignores disabled) 1993 else if (DFCS_INACTIVE and uState)<>0 then 1994 State := GTK_STATE_INSENSITIVE //button disabled 1995 else if (DFCS_HOT and uState)<>0 then 1996 State := GTK_STATE_PRELIGHT // button enabled, special (e.g. mouse over) 1997 else 1998 State := GTK_STATE_NORMAL; // button enabled, normal 1999 2000 // set Shadow (the border style) 2001 if (DFCS_PUSHED and uState)<>0 then begin 2002 // button down 2003 Shadow:=GTK_SHADOW_IN; 2004 end else begin 2005 if (((DFCS_FLAT+DFCS_CHECKED) and uState)=DFCS_FLAT) then begin 2006 // button up, flat, no special 2007 Shadow:=GTK_SHADOW_ETCHED_OUT; 2008 //Shadow:=GTK_SHADOW_NONE; 2009 end else begin 2010 // button up 2011 Shadow:=GTK_SHADOW_OUT; 2012 end; 2013 end; 2014 2015 aDC:=TGtkDeviceContext(DC); 2016 DCOrigin:= aDC.Offset; 2017 2018 If Widget <> nil then 2019 aStyle := gtk_widget_get_style(Widget) 2020 else 2021 aStyle := GetStyle(lgsButton); 2022 if aStyle = nil then 2023 aStyle := GetStyle(lgsGTK_Default); 2024 2025 // MG: You can't assign a style to any window. Why it is needed anyway? 2026 //aStyle := gtk_style_attach(gtk_style_ref(aStyle),aDC.Drawable); 2027 2028 if aStyle<>nil then 2029 begin 2030 aDC.RemovePixbuf; 2031 if (Shadow=GTK_SHADOW_NONE) then 2032 gtk_paint_flat_box(aStyle,aDC.Drawable, 2033 State, 2034 Shadow, 2035 @ClipArea, 2036 GetStyleWidget(lgsButton), 2037 'button', 2038 R.Left+DCOrigin.X,R.Top+DCOrigin.Y, 2039 R.Right-R.Left,R.Bottom-R.Top) 2040 else 2041 gtk_paint_box(aStyle,aDC.Drawable, 2042 State, 2043 Shadow, 2044 @ClipArea, 2045 GetStyleWidget(lgsButton), 2046 'button', 2047 R.Left+DCOrigin.X,R.Top+DCOrigin.Y, 2048 R.Right-R.Left,R.Bottom-R.Top); 2049 end; 2050 Result := True; 2051 end; 2052 2053 procedure DrawCheckOrRadioButton(IsRadioButton: Boolean); 2054 const 2055 LazGtkStyleMap: array[Boolean] of TLazGtkStyle = (lgsCheckbox, lgsRadiobutton); 2056 var 2057 State: TGtkStateType; 2058 Shadow: TGtkShadowType; 2059 aDC: TGtkDeviceContext; 2060 DCOrigin: TPoint; 2061 Style : PGTKStyle; 2062 Widget : PGTKWidget; 2063 begin 2064 // use the gtk paint functions to draw a widget style dependent check/radio button 2065 if (DFCS_BUTTON3STATE and uState)<>0 then 2066 Shadow := GTK_SHADOW_ETCHED_IN //3state style 2067 else if (DFCS_CHECKED and uState)<>0 then 2068 Shadow := GTK_SHADOW_IN //checked style 2069 else 2070 Shadow := GTK_SHADOW_OUT; //unchecked style 2071 2072 if (DFCS_PUSHED and uState)<>0 then 2073 State := GTK_STATE_ACTIVE //button pressed(GTK ignores disabled) 2074 else if (DFCS_INACTIVE and uState)<>0 then 2075 State := GTK_STATE_INSENSITIVE //button disabled 2076 else if (DFCS_HOT and uState)<>0 then 2077 State := GTK_STATE_PRELIGHT // button enabled, special (e.g. mouse over) 2078 else 2079 State := GTK_STATE_NORMAL; // button enabled, normal 2080 2081 aDC:=TGtkDeviceContext(DC); 2082 DCOrigin := aDC.Offset; 2083 2084 Style := GetStyle(LazGtkStyleMap[IsRadioButton]); 2085 2086 if Style = nil then 2087 begin 2088 Style := GetStyle(lgsGTK_Default); 2089 if Style <> nil then 2090 Style := gtk_style_attach(gtk_style_ref(Style),aDC.Drawable); 2091 end; 2092 2093 Widget := GetStyleWidget(LazGtkStyleMap[IsRadioButton]); 2094 2095 if Widget = nil then 2096 Widget := GetStyleWidget(lgsDefault); 2097 if Widget <> nil then 2098 Widget^.Window := aDC.Drawable; 2099 Result := Style <> nil; 2100 if Result then 2101 begin 2102 aDC.RemovePixbuf; 2103 if IsRadioButton then 2104 gtk_paint_option(Style,aDC.Drawable, State, 2105 Shadow, @ClipArea, Widget, 'radiobutton', 2106 R.Left+DCOrigin.X,R.Top+DCOrigin.Y, 2107 R.Right-R.Left, R.Bottom-R.Top) 2108 else 2109 gtk_paint_check(Style,aDC.Drawable, State, 2110 Shadow, @ClipArea, Widget, 'checkbutton', 2111 R.Left+DCOrigin.X,R.Top+DCOrigin.Y, 2112 R.Right-R.Left, R.Bottom-R.Top); 2113 end; 2114 end; 2115 2116var 2117 ClientWidget: PGtkWidget; 2118begin 2119 Result := False; 2120 if IsValidDC(DC) then 2121 begin 2122 if DevCtx.HasTransf then 2123 begin 2124 R := DevCtx.TransfRectIndirect(Rect); 2125 DevCtx.TransfNormalize(R.Left, R.Right); 2126 DevCtx.TransfNormalize(R.Top, R.Bottom); 2127 end else 2128 R := Rect; 2129 2130 Widget:=TGtkDeviceContext(DC).Widget; 2131 //It's possible to draw in a DC without a widget, e.g., a Bitmap 2132 if Widget <> nil then 2133 begin 2134 ClientWidget:=GetFixedWidget(Widget); 2135 if ClientWidget<>nil then 2136 Widget:=ClientWidget; 2137 end; 2138 end else 2139 Widget:=nil; 2140 2141 ClipArea := DevCtx.ClipRect; 2142 case uType of 2143 DFC_CAPTION: 2144 begin //all draw CAPTION commands here 2145 end; 2146 DFC_MENU: 2147 begin 2148 2149 end; 2150 DFC_SCROLL: 2151 begin 2152 end; 2153 DFC_BUTTON: 2154 begin 2155 //DebugLn(Format('Trace: [TGtk2WidgetSet.DrawFrameControl] DFC_BUTTON --> draw rect = %d,%d,%d,%d',[R.Left,R.Top,R.Right,R.Bottom])); 2156 //figure out the style first 2157 if (uState and $1F) in [DFCS_BUTTONCHECK, DFCS_BUTTON3STATE] then 2158 begin 2159 //DebugLn('Trace:State ButtonCheck'); 2160 DrawCheckOrRadioButton(False); 2161 end 2162 else if (DFCS_BUTTONRADIO and uState) <> 0 then 2163 begin 2164 //DebugLn('Trace:State ButtonRadio'); 2165 DrawCheckOrRadioButton(True); 2166 end 2167 else if (DFCS_BUTTONPUSH and uState) <> 0 then 2168 begin 2169 //DebugLn('Trace:State ButtonPush'); 2170 DrawButtonPush; 2171 end 2172 else if (DFCS_BUTTONRADIOIMAGE and uState) <> 0 then 2173 begin 2174 //DebugLn('Trace:State ButtonRadioImage'); 2175 end 2176 else if (DFCS_BUTTONRADIOMASK and uState) <> 0 then 2177 begin 2178 //DebugLn('Trace:State ButtonRadioMask'); 2179 end 2180 else 2181 DebugLn(Format('ERROR: [TGtk2WidgetSet.DrawFrameControl] Unknown State 0x%x', [uState])); 2182 end; 2183 else 2184 DebugLn(Format('ERROR: [TGtk2WidgetSet.DrawFrameControl] Unknown type %d', [uType])); 2185 end; 2186end; 2187 2188function TGtk2WidgetSet.DrawFocusRect(DC: HDC; const Rect: TRect): boolean; 2189var 2190 DevCtx: TGtkDeviceContext absolute DC; 2191 Origin: TPoint; 2192 2193 procedure DrawPixel(X1,Y1: Integer); 2194 begin 2195 inc(X1,Origin.X); 2196 inc(Y1,Origin.Y); 2197 TGtkDeviceContext(DC).RemovePixbuf; 2198 gdk_draw_point(TGtkDeviceContext(DC).Drawable, TGtkDeviceContext(DC).GC, X1, Y1); 2199 end; 2200 2201 procedure DrawVertLine(X1,Y1,Y2: integer); 2202 begin 2203 if Y2<Y1 then 2204 while Y2<Y1 do begin 2205 DrawPixel(X1, Y1); 2206 dec(Y1, 2); 2207 end 2208 else 2209 while Y1<Y2 do begin 2210 DrawPixel(X1, Y1); 2211 inc(Y1, 2); 2212 end; 2213 end; 2214 2215 procedure DrawHorzLine(X1,Y1,X2: integer); 2216 begin 2217 if X2<X1 then 2218 while X2<X1 do begin 2219 DrawPixel(X1, Y1); 2220 dec(X1, 2); 2221 end 2222 else 2223 while X1<X2 do begin 2224 DrawPixel(X1, Y1); 2225 inc(X1, 2); 2226 end; 2227 end; 2228 2229var 2230 OldROP: Integer; 2231 APen, TempPen: HPEN; 2232 LogPen : TLogPen; 2233 R: TRect; 2234begin 2235 Result := False; 2236 if IsValidDC(DC) then 2237 begin 2238 with LogPen do 2239 begin 2240 lopnStyle := PS_DOT; 2241 lopnWidth.X := 2; 2242 lopnColor := clWhite; 2243 end; 2244 if DevCtx.HasTransf then 2245 R := DevCtx.TransfRectIndirect(Rect) 2246 else 2247 R := Rect; 2248 2249 APen := CreatePenIndirect(LogPen); 2250 TempPen := SelectObject(DC, APen); 2251 OldRop := SetROP2(DC, R2_XORPEN); 2252 2253 Origin := DevCtx.Offset; 2254 try 2255 DrawHorzLine(R.Left, R.Top, R.Right-1); 2256 DrawVertLine(R.Right-1, R.Top, R.Bottom-1); 2257 DrawHorzLine(R.Right-1, R.Bottom-1, R.Left); 2258 DrawVertLine(R.Left, R.Bottom-1, R.Top); 2259 2260 Result := True; 2261 finally 2262 SelectObject(DC, TempPen); 2263 DeleteObject(APen); 2264 SetROP2(DC, OldROP); 2265 end; 2266 end; 2267end; 2268 2269{------------------------------------------------------------------------------ 2270 Function: DrawEdge 2271 Params: DC: HDC; var Rect: TRect; edge: Cardinal; grfFlags: Cardinal 2272 Returns: Boolean 2273 2274 Draws one or more edges of a rectangle. The rectangle is the area 2275 Left to Right-1 and Top to Bottom-1. 2276 ------------------------------------------------------------------------------} 2277function TGtk2WidgetSet.DrawEdge(DC: HDC; var ARect: TRect; Edge: Cardinal; 2278 grfFlags: Cardinal): Boolean; 2279 2280 procedure DrawEdges(var R: TRect; GC: pgdkGC; Drawable:PGdkDrawable; 2281 const TopLeftColor, BottomRightColor: TGDKColor); 2282 begin 2283 gdk_gc_set_foreground(GC, @TopLeftColor); 2284 if (grfFlags and BF_TOP) = BF_TOP then begin 2285 gdk_draw_line(Drawable, GC, R.Left, R.Top, R.Right, R.Top); 2286 inc(R.Top); 2287 end; 2288 if (grfFlags and BF_LEFT) = BF_LEFT then begin 2289 gdk_draw_line(Drawable, GC, R.Left, R.Top, R.Left, R.Bottom); 2290 inc(R.Left); 2291 end; 2292 2293 gdk_gc_set_foreground(GC, @BottomRightColor); 2294 if (grfFlags and BF_BOTTOM) = BF_BOTTOM then begin 2295 gdk_draw_line(Drawable, GC, R.Left, R.Bottom-1, R.Right, R.Bottom-1); 2296 dec(R.Bottom); 2297 end; 2298 if (grfFlags and BF_RIGHT) = BF_RIGHT then begin 2299 gdk_draw_line(Drawable, GC, R.Right-1, R.Top, R.Right-1, R.Bottom); 2300 dec(R.Right); 2301 end; 2302 end; 2303 2304var 2305 InnerTL, OuterTL, 2306 InnerBR, OuterBR, MiddleColor: TGDKColor; 2307 BInner, BOuter: Boolean; 2308 R: TRect; 2309 DCOrigin: TPoint; 2310begin 2311 //DebugLn('TGtk2WidgetSet.DrawEdge Edge=',DbgS(Edge),8),' grfFlags=',DbgS(Cardinal(grfFlags)); 2312 Result := IsValidDC(DC); 2313 if Result then 2314 with TGtkDeviceContext(DC) do 2315 begin 2316 R := ARect; 2317 2318 LPtoDP(DC, R, 2); 2319 2320 DCOrigin := Offset; 2321 OffsetRect(R, DCOrigin.X, DCOrigin.Y); 2322 2323 // try to use the gdk functions, so that the current theme is used 2324 BInner := False; 2325 BOuter := False; 2326 2327 // TODO: change this to real colors 2328 if (edge and BDR_RAISEDINNER) = BDR_RAISEDINNER 2329 then begin 2330 InnerTL := AllocGDKColor(GetSysColor(COLOR_BTNHIGHLIGHT)); 2331 InnerBR := AllocGDKColor(GetSysColor(COLOR_BTNSHADOW)); 2332 BInner := True; 2333 end; 2334 if (edge and BDR_SUNKENINNER) = BDR_SUNKENINNER 2335 then begin 2336 InnerTL := AllocGDKColor(GetSysColor(COLOR_BTNSHADOW)); 2337 InnerBR := AllocGDKColor(GetSysColor(COLOR_BTNHIGHLIGHT)); 2338 BInner := True; 2339 end; 2340 if (edge and BDR_RAISEDOUTER) = BDR_RAISEDOUTER 2341 then begin 2342 OuterTL := AllocGDKColor(GetSysColor(COLOR_BTNHIGHLIGHT)); 2343 OuterBR := AllocGDKColor(GetSysColor(COLOR_BTNSHADOW)); 2344 BOuter := True; 2345 end; 2346 if (edge and BDR_SUNKENOUTER) = BDR_SUNKENOUTER 2347 then begin 2348 OuterTL := AllocGDKColor(GetSysColor(COLOR_BTNSHADOW)); 2349 OuterBR := AllocGDKColor(GetSysColor(COLOR_BTNHIGHLIGHT)); 2350 BOuter := True; 2351 end; 2352 2353 gdk_gc_set_fill(GC, GDK_SOLID); 2354 SelectedColors := dcscCustom; 2355 2356 // Draw outer rect 2357 if BOuter then 2358 begin 2359 RemovePixbuf; 2360 DrawEdges(R, GC,Drawable,OuterTL,OuterBR); 2361 end; 2362 2363 // Draw inner rect 2364 if BInner then 2365 begin 2366 RemovePixbuf; 2367 DrawEdges(R,GC,Drawable,InnerTL,InnerBR); 2368 end; 2369 2370 // gdk_colormap_free_colors(gdk_colormap_get_system, @OuterTL, 1); 2371 // gdk_colormap_free_colors(gdk_colormap_get_system, @OuterBR, 1); 2372 // gdk_colormap_free_colors(gdk_colormap_get_system, @InnerTL, 1); 2373 // gdk_colormap_free_colors(gdk_colormap_get_system, @InnerBR, 1); 2374 2375 //Draw interiour 2376 if ((grfFlags and BF_MIDDLE) = BF_MIDDLE) then 2377 begin 2378 RemovePixbuf; 2379 MiddleColor := AllocGDKColor(GetSysColor(COLOR_BTNFACE)); 2380 gdk_gc_set_foreground(GC, @MiddleColor); 2381 gdk_draw_rectangle(Drawable, GC, 1, R.Left, R.Top, 2382 R.Right - R.Left, R.Bottom - R.Top); 2383 end; 2384 2385 // adjust rect if needed 2386 if (grfFlags and BF_ADJUST) = BF_ADJUST then 2387 begin 2388 ARect := R; 2389 OffsetRect(ARect, -DCOrigin.X, -DCOrigin.Y); 2390 DPtoLP(DC, ARect, 2); 2391 end; 2392 Result := True; 2393 end; 2394end; 2395 2396{------------------------------------------------------------------------------ 2397 Method: DrawText 2398 Params: DC, Str, Count, Rect, Flags 2399 Returns: If the string was drawn, or CalcRect run 2400 2401 ------------------------------------------------------------------------------} 2402function TGtk2WidgetSet.DrawText(DC: HDC; Str: PChar; Count: Integer; 2403 var Rect: TRect; Flags: Cardinal): Integer; 2404const 2405 TabString = ' '; 2406var 2407 pIndex: Longint; 2408 AStr: String; 2409 2410 TM: TTextmetric; 2411 theRect: TRect; 2412 Lines: PPChar; 2413 I, NumLines: Longint; 2414 TempDC: HDC; 2415 TempPen: HPEN; 2416 TempBrush: HBRUSH; 2417 l: LongInt; 2418 Pt: TPoint; 2419 SavedRect: TRect; // if font orientation <> 0 2420 LineHeight: Integer; 2421 Size: TSize; 2422 2423 function LeftOffset: Longint; 2424 begin 2425 if (Flags and DT_RIGHT) = DT_RIGHT then 2426 Result := DT_RIGHT 2427 else 2428 if (Flags and DT_CENTER) = DT_CENTER then 2429 Result := DT_CENTER 2430 else 2431 Result := DT_LEFT; 2432 end; 2433 2434 function TopOffset: Longint; 2435 begin 2436 if (Flags and DT_BOTTOM) = DT_BOTTOM then 2437 Result := DT_BOTTOM 2438 else 2439 if (Flags and DT_VCENTER) = DT_VCENTER then 2440 Result := DT_VCENTER 2441 else 2442 Result := DT_TOP; 2443 end; 2444 2445 function CalcRect: Boolean; 2446 begin 2447 Result := (Flags and DT_CALCRECT) = DT_CALCRECT; 2448 end; 2449 2450 function TextExtentPoint(Str: PChar; Count: Integer; var Sz: TSize): Boolean; 2451 var 2452 NewStr: String; 2453 begin 2454 if (Flags and DT_EXPANDTABS) <> 0 then 2455 begin 2456 NewStr := StringReplace(Str, #9, TabString, [rfReplaceAll]); 2457 Result := GetTextExtentPoint(DC, PChar(NewStr), Length(NewStr), Sz); 2458 end 2459 else 2460 Result := GetTextExtentPoint(Dc, Str, Count, Sz); 2461 end; 2462 2463 procedure DoCalcRect; 2464 var 2465 AP: TSize; 2466 J, MaxWidth, 2467 LineWidth, ActualHeight: Integer; 2468 begin 2469 theRect := Rect; 2470 2471 MaxWidth := theRect.Right - theRect.Left; 2472 2473 if (Flags and DT_SINGLELINE) > 0 then 2474 begin 2475 // ignore word and line breaks 2476 TextExtentPoint(PChar(AStr), length(AStr), AP{%H-}); 2477 theRect.Bottom := theRect.Top + TM.tmHeight; 2478 if (Flags and DT_CALCRECT)<>0 then 2479 begin 2480 theRect.Right := theRect.Left + AP.cX; 2481 theRect.Bottom := theRect.Top + AP.cY; 2482 end 2483 else 2484 begin 2485 theRect.Right := theRect.Left + Min(MaxWidth, AP.cX); 2486 theRect.Bottom := theRect.Top + AP.cY; 2487 if (Flags and DT_VCENTER) > 0 then 2488 begin 2489 OffsetRect(theRect, 0, ((Rect.Bottom - Rect.Top) - (theRect.Bottom - theRect.Top)) div 2); 2490 end 2491 else 2492 if (Flags and DT_BOTTOM) > 0 then 2493 begin 2494 OffsetRect(theRect, 0, (Rect.Bottom - Rect.Top) - (theRect.Bottom - theRect.Top)); 2495 end; 2496 2497 end; 2498 end 2499 else 2500 begin 2501 // consider line breaks 2502 if (Flags and DT_WORDBREAK) = 0 then 2503 begin 2504 // do not break at word boundaries 2505 TextExtentPoint(PChar(AStr), length(AStr), AP); 2506 MaxWidth := AP.cX; 2507 end; 2508 Self.WordWrap(DC, PChar(AStr), MaxWidth, Lines, NumLines); 2509 2510 if (Flags and DT_CALCRECT)<>0 then 2511 begin 2512 LineWidth := 0; 2513 ActualHeight := 0; 2514 if (Lines <> nil) then 2515 begin 2516 for J := 0 to NumLines - 1 do 2517 begin 2518 TextExtentPoint(Lines[J], StrLen(Lines[J]), AP); 2519 LineWidth := Max(LineWidth, AP.cX); 2520 Inc(ActualHeight, AP.cY); 2521 end; 2522 end; 2523 LineWidth := Min(MaxWidth, LineWidth); 2524 end else 2525 begin 2526 LineWidth := MaxWidth; 2527 ActualHeight := NumLines*TM.tmHeight; 2528 end; 2529 2530 theRect.Right := theRect.Left + LineWidth; 2531 theRect.Bottom := theRect.Top + ActualHeight; 2532 if NumLines>1 then 2533 Inc(theRect.Bottom, (NumLines-1)*TM.tmExternalLeading);// space between lines 2534 2535 //debugln('TGtk2WidgetSet.DrawText A ',dbgs(theRect),' TM.tmHeight=',dbgs(TM.tmHeight),' LineWidth=',dbgs(LineWidth),' NumLines=',dbgs(NumLines)); 2536 end; 2537 2538 if not CalcRect then 2539 case LeftOffset of 2540 DT_CENTER: 2541 OffsetRect(theRect, (Rect.Right - theRect.Right) div 2, 0); 2542 DT_RIGHT: 2543 OffsetRect(theRect, Rect.Right - theRect.Right, 0); 2544 end; 2545 end; 2546 2547 // if our Font.Orientation <> 0 we must recalculate X,Y offset 2548 // also it works only with DT_TOP DT_LEFT. Gtk2 can handle multiline 2549 // text in this case too. 2550 procedure CalculateOffsetWithAngle(const AFontAngle: Integer; 2551 var TextLeft,TextTop: Integer); 2552 var 2553 OffsX, OffsY: integer; 2554 Angle: Double; 2555 Size: TSize; 2556 R: TRect; 2557 begin 2558 R := SavedRect; 2559 OffsX := R.Right - R.Left; 2560 OffsY := R.Bottom - R.Top; 2561 Size.cx := OffsX; 2562 Size.cy := OffsY; 2563 Angle := AFontAngle / 10; 2564 if Angle < 0 then 2565 Angle := 360 + Angle; 2566 2567 if Angle <= 90 then 2568 begin 2569 OffsX := 0; 2570 OffsY := Trunc(Size.cx * sin(Angle * Pi / 180)); 2571 end else 2572 if Angle <= 180 then 2573 begin 2574 OffsX := Trunc(Size.cx * -cos(Angle * Pi / 180)); 2575 OffsY := Trunc(Size.cx * sin(Angle * Pi / 180) + 2576 Size.cy * cos((180 - Angle) * Pi / 180)); 2577 end else 2578 if Angle <= 270 then 2579 begin 2580 OffsX := Trunc(Size.cx * -cos(Angle * Pi / 180) + 2581 Size.cy * sin((Angle - 180) * Pi / 180)); 2582 OffsY := Trunc(Size.cy * sin((270 - Angle) * Pi / 180)); 2583 end else 2584 if Angle <= 360 then 2585 begin 2586 OffsX := Trunc(Size.cy * sin((360 - Angle) * Pi / 180)); 2587 OffsY := 0; 2588 end; 2589 TextTop := OffsY; 2590 TextLeft := OffsX; 2591 end; 2592 2593 function NeedOffsetCalc: Boolean; 2594 var 2595 AClipRect: TRect; 2596 begin 2597 {see issue #27547} 2598 AClipRect := RectFromGdkRect(TGtkDeviceContext(DC).ClipRect); 2599 OffsetRect(AClipRect, -AClipRect.Left, -AClipRect.Top); 2600 Result := (TGtkDeviceContext(DC).CurrentFont^.LogFont.lfOrientation <> 0) and 2601 (Flags and DT_SINGLELINE <> 0) and 2602 (Flags and DT_VCENTER = 0) and (Flags and DT_CENTER = 0) and 2603 (Flags and DT_RIGHT = 0) and (Flags and DT_BOTTOM = 0) and 2604 (Flags and DT_CALCRECT = 0) and not IsRectEmpty(SavedRect) and 2605 EqualRect(AClipRect, Rect); 2606 end; 2607 2608 2609 procedure DrawLineRaw(theLine: PChar; LineLength, TopPos: Longint); 2610 var 2611 Points: array[0..1] of TSize; 2612 LeftPos: Longint; 2613 begin 2614 if LeftOffset <> DT_LEFT then 2615 GetTextExtentPoint(DC, theLine, LineLength, {%H-}Points[0]); 2616 2617 if TempBrush = HBRUSH(-1) then 2618 TempBrush := SelectObject(DC, GetStockObject(NULL_BRUSH)); 2619 case LeftOffset of 2620 DT_LEFT: 2621 LeftPos := theRect.Left; 2622 DT_CENTER: 2623 LeftPos := theRect.Left + (theRect.Right - theRect.Left) div 2 2624 - Points[0].cX div 2; 2625 DT_RIGHT: 2626 LeftPos := theRect.Right - Points[0].cX; 2627 end; 2628 2629 Pt := Point(0, 0); 2630 // Draw line of Text 2631 if NeedOffsetCalc then 2632 begin 2633 Pt.X := SavedRect.Left; 2634 Pt.Y := SavedRect.Top; 2635 CalculateOffsetWithAngle(TGtkDeviceContext(DC).CurrentFont^.LogFont.lfOrientation, Pt.X, Pt.Y); 2636 end; 2637 TextUtf8Out(DC, LeftPos + Pt.X, TopPos + Pt.Y, theLine, lineLength); 2638 end; 2639 2640 procedure DrawLine(theLine: PChar; LineLength, TopPos: Longint); 2641 var 2642 Points: array[0..1] of TSize; 2643 LogP: TLogPen; 2644 LeftPos: Longint; 2645 begin 2646 if TempBrush = HBRUSH(-1) then 2647 TempBrush := SelectObject(DC, GetStockObject(NULL_BRUSH)); 2648 2649 FillByte({%H-}Points[0],SizeOf(Points[0])*2,0); 2650 if LeftOffset <> DT_Left then 2651 GetTextExtentPoint(DC, theLine, LineLength, Points[0]); 2652 2653 case LeftOffset of 2654 DT_LEFT: 2655 LeftPos := theRect.Left; 2656 DT_CENTER: 2657 LeftPos := theRect.Left + (theRect.Right - theRect.Left) div 2 2658 - Points[0].cX div 2; 2659 DT_RIGHT: 2660 LeftPos := theRect.Right - Points[0].cX; 2661 end; 2662 2663 Pt := Point(0, 0); 2664 if NeedOffsetCalc then 2665 begin 2666 Pt.X := SavedRect.Left; 2667 Pt.Y := SavedRect.Top; 2668 CalculateOffsetWithAngle(TGtkDeviceContext(DC).CurrentFont^.LogFont.lfOrientation, Pt.X, Pt.Y); 2669 end; 2670 // Draw line of Text 2671 TextUtf8Out(DC, LeftPos + Pt.X, TopPos + Pt.Y, theLine, LineLength); 2672 2673 // Draw Prefix 2674 if (pIndex > 0) and (pIndex<=LineLength) then 2675 begin 2676 // Create & select pen of font color 2677 if TempPen = HPEN(-1) then 2678 begin 2679 LogP.lopnStyle := PS_SOLID; 2680 LogP.lopnWidth.X := 1; 2681 LogP.lopnColor := GetTextColor(DC); 2682 TempPen := SelectObject(DC, CreatePenIndirect(LogP)); 2683 end; 2684 2685 {Get prefix line position} 2686 GetTextExtentPoint(DC, theLine, pIndex - 1, Points[0]); 2687 Points[0].cX := LeftPos + Points[0].cX; 2688 Points[0].cY := TopPos + tm.tmHeight - TM.tmDescent + 1; 2689 2690 GetTextExtentPoint(DC, @aStr[pIndex], UTF8CodepointSize(@aStr[pIndex]), Points[1]); 2691 Points[1].cX := Points[0].cX + Points[1].cX; 2692 Points[1].cY := Points[0].cY; 2693 2694 {Draw prefix line} 2695 Polyline(DC, PPoint(@Points[0]), 2); 2696 end; 2697 end; 2698 2699begin 2700 if (Str=nil) or (Str[0]=#0) then Exit(0); 2701 2702 //DebugLn(Format('trace:> [TGtk2WidgetSet.DrawText] DC:0x%x, Str:''%s'', Count: %d, Rect = %d,%d,%d,%d, Flags:%d', 2703 // [DC, Str, Count, Rect.Left, Rect.Top, Rect.Right, Rect.Bottom, Flags])); 2704 2705 if not IsValidDC(DC) then Exit(0); 2706 if (Count < -1) or (IsRectEmpty(Rect) and 2707 ((Flags and DT_CALCRECT = 0) and (Flags and DT_NOCLIP = 0))) then Exit(0); 2708 2709 // Don't try to use StrLen(Str) in cases count >= 0 2710 // In those cases str is NOT required to have a null terminator ! 2711 if Count = -1 then Count := StrLen(Str); 2712 2713 Lines := nil; 2714 NumLines := 0; 2715 TempDC := HDC(-1); 2716 TempPen := HPEN(-1); 2717 TempBrush := HBRUSH(-1); 2718 2719 try 2720 if (Flags and (DT_SINGLELINE or DT_CALCRECT or DT_NOPREFIX or DT_NOCLIP or DT_EXPANDTABS)) = 2721 (DT_SINGLELINE or DT_NOPREFIX or DT_NOCLIP) 2722 then begin 2723 //DebugLn(['TGtk2WidgetSet.DrawText Calc single line']); 2724 CopyRect(theRect, Rect); 2725 SavedRect := Rect; 2726 DrawLineRaw(Str, Count, Rect.Top); 2727 Result := Rect.Bottom - Rect.Top; 2728 Exit; 2729 end; 2730 2731 SetLength(AStr{%H-},Count); 2732 if Count>0 then 2733 System.Move(Str^,AStr[1],Count); 2734 2735 if (Flags and DT_EXPANDTABS) <> 0 then 2736 AStr := StringReplace(AStr, #9, TabString, [rfReplaceAll]); 2737 2738 if (Flags and DT_NOPREFIX) <> DT_NOPREFIX then 2739 pIndex := DeleteAmpersands(AStr) 2740 else 2741 pIndex := -1; 2742 2743 GetTextMetrics(DC, TM{%H-}); 2744 DoCalcRect; 2745 Result := theRect.Bottom - theRect.Top; 2746 if (Flags and DT_CALCRECT) = DT_CALCRECT 2747 then begin 2748 //DebugLn(['TGtk2WidgetSet.DrawText Complex Calc']); 2749 CopyRect(Rect, theRect); 2750 exit; 2751 end; 2752 2753 TempDC := SaveDC(DC); 2754 2755 if (Flags and DT_NOCLIP) <> DT_NOCLIP then 2756 begin 2757 if theRect.Right > Rect.Right then 2758 theRect.Right := Rect.Right; 2759 if theRect.Bottom > Rect.Bottom then 2760 theRect.Bottom := Rect.Bottom; 2761 IntersectClipRect(DC, theRect.Left, theRect.Top, 2762 theRect.Right, theRect.Bottom); 2763 end; 2764 2765 if (Flags and DT_SINGLELINE) = DT_SINGLELINE 2766 then begin 2767 // DebugLn(['TGtk2WidgetSet.DrawText Draw single line']); 2768 SavedRect := TheRect; 2769 DrawLine(PChar(AStr), length(AStr), theRect.Top); 2770 Exit; //we're ready 2771 end; 2772 2773 // multiple lines 2774 if Lines = nil then Exit; // nothing to do 2775 if NumLines = 0 then Exit; // 2776 2777 2778 //DebugLn(['TGtk2WidgetSet.DrawText Draw multiline']); 2779 SavedRect := Classes.Rect(0, 0, 0, 0); // no font orientation change if multilined text 2780 for i := 0 to NumLines - 1 do 2781 begin 2782 if theRect.Top > theRect.Bottom then Break; 2783 2784 if ((Flags and DT_EDITCONTROL) = DT_EDITCONTROL) 2785 and (tm.tmHeight > (theRect.Bottom - theRect.Top)) 2786 then Break; 2787 2788 if Lines[i] <> nil then 2789 begin 2790 l:=StrLen(Lines[i]); 2791 DrawLine(Lines[i], l, theRect.Top); 2792 dec(pIndex,l+length(LineEnding)); 2793 GetTextExtentPoint(DC, Lines[i], l, Size{%H-}); 2794 LineHeight := Size.cY; 2795 end 2796 else 2797 LineHeight := TM.tmHeight; 2798 Inc(theRect.Top, LineHeight + TM.tmExternalLeading);// space between lines 2799 end; 2800 2801 finally 2802 Reallocmem(Lines, 0); 2803 if TempBrush <> HBRUSH(-1) then 2804 SelectObject(DC, TempBrush);// DeleteObject not needed here, because it was a default Brush 2805 if TempPen <> HPEN(-1) then 2806 DeleteObject(SelectObject(DC, TempPen)); 2807 if TempDC <> HDC(-1) then 2808 RestoreDC(DC, TempDC); 2809 end; 2810end; 2811 2812{------------------------------------------------------------------------------ 2813 Function: EnableScrollBar 2814 Params: Wnd, wSBflags, wArrows 2815 Returns: Nothing 2816 2817 2818 ------------------------------------------------------------------------------} 2819function TGtk2WidgetSet.EnableScrollBar(Wnd: HWND; wSBflags, wArrows: Cardinal): Boolean; 2820begin 2821 // TODO: implement TGtk2WidgetSet.EnableScrollBar 2822 Result := False; 2823end; 2824 2825{------------------------------------------------------------------------------ 2826 Function: EnableWindow 2827 Params: hWnd: 2828 bEnable: 2829 Returns: 2830 If the window was previously disabled, the return value is TRUE. 2831 If the window was not previously disabled, the return value is FALSE. 2832 ------------------------------------------------------------------------------} 2833function TGtk2WidgetSet.EnableWindow(hWnd: HWND; bEnable: Boolean): Boolean; 2834begin 2835 Result := False; 2836 if hWnd <> 0 then 2837 begin 2838 Result := not GTK_WIDGET_SENSITIVE({%H-}PGtkWidget(HWND)); 2839 gtk_widget_set_sensitive({%H-}PGtkWidget(hWnd), bEnable); 2840 InvalidateLastWFPResult(nil, RectFromGdkRect({%H-}PGtkWidget(HWND)^.allocation)); 2841 end; 2842end; 2843 2844{------------------------------------------------------------------------------ 2845 Function: EndPaint 2846 Params: 2847 Returns: 2848 2849 ------------------------------------------------------------------------------} 2850function TGtk2WidgetSet.EndPaint(Handle: hwnd; var PS: TPaintStruct): Integer; 2851var 2852 Widget: PGtkWidget; 2853 Info: PWidgetInfo; 2854 Control: TWinControl; 2855 2856begin 2857 Result:=1; 2858 if PS.HDC = 0 then Exit; 2859 2860 if Handle <> 0 2861 then Control := TWinControl(GetLCLObject({%H-}Pointer(Handle))) 2862 else Control := nil; 2863 2864 if (Control <> nil) 2865 and TWSWinControlClass(Control.WidgetSetClass).GetDoubleBuffered(Control) 2866 and not GTK_WIDGET_DOUBLE_BUFFERED({%H-}PGTKWidget(Handle)) 2867 then begin 2868 gdk_window_thaw_updates(TGtkDeviceContext(PS.HDC).Drawable); 2869 gdk_window_end_paint (TGtkDeviceContext(PS.HDC).Drawable); 2870 end; 2871 2872 Widget := {%H-}PGtkWidget(Handle); 2873 Info:=GetWidgetInfo(Widget); 2874 if Info<>nil then 2875 dec(Info^.PaintDepth); 2876 2877 ReleaseDC(Handle, PS.HDC); 2878end; 2879 2880function TGtk2WidgetSet.EnumDisplayMonitors(hdc: HDC; lprcClip: PRect; 2881 lpfnEnum: MonitorEnumProc; dwData: LPARAM): LongBool; 2882var 2883 i: integer; 2884begin 2885 Result := True; 2886 for i := 0 to gdk_screen_get_n_monitors(gdk_screen_get_default) - 1 do 2887 begin 2888 Result := Result and lpfnEnum(i + 1, 0, nil, dwData); 2889 if not Result then break; 2890 end; 2891end; 2892 2893{.$define VerboseEnumFonts} 2894{$IFDEF GTK2OLDENUMFONTFAMILIES} 2895function TGtk2WidgetSet.EnumFontFamilies(DC: HDC; Family: Pchar; 2896 EnumFontFamProc: FontEnumProc; LParam:Lparam):longint; 2897var 2898 xFonts: PPChar; 2899 FontList: TStringList; 2900 EnumLogFont: TEnumLogFont; 2901 Metric: TNewTextMetric; 2902 I,N: Integer; 2903 tmp: String; 2904 FontType: Integer; 2905begin 2906 result := 0; 2907 if not Assigned(EnumFontFamProc) then begin 2908 result := 2; 2909 DebugLn('EnumFontFamProc Callback not set'); 2910 // todo: raise exception? 2911 exit; 2912 end; 2913 FontList := TStringlist.Create; 2914 try 2915 if Family<>'' then 2916 Tmp := '-*-'+Family+'-*-*-*-*-*-*-*-*-*-*-*-*' 2917 else 2918 Tmp := '-*'; // get rid of aliases 2919 {$ifdef VerboseEnumFonts} 2920 WriteLn('Looking for fonts matching: ', tmp); 2921 {$endif} 2922 {$ifdef HasX} 2923 XFonts := XListFonts(gdk_display, pchar(Tmp), 10000, @N); 2924 {$else} 2925 {$IFDEF VerboseGtkToDos}{$warning implement getting XFonts for this OS}{$ENDIF} 2926 XFonts := nil; 2927 N:=0; 2928 {$endif} 2929 try 2930 for I := 0 to N - 1 do 2931 if XFonts[I] <> nil then begin 2932 Tmp := ExtractFamilyFromXLFDName(XFonts[I]); 2933 {$ifdef VerboseEnumFonts} 2934 WriteLn(I:5,' [', tmp, '] Font=',XFonts[i]); 2935 {$endif} 2936 if Tmp <> '' then begin 2937 if family='' then begin 2938 // get just the font names 2939 if FontList.IndexOf(Tmp) < 0 then begin 2940 EnumLogFont.elfLogFont := XLFDNameToLogFont(XFonts[i]); 2941 FillChar(Metric, SizeOf(Metric), #0); 2942 FontType := 0; // todo: GetFontTypeFromXLDF or FontId 2943 EnumLogFont.elfFullName := ''; 2944 EnumFontFamProc(EnumLogFont, Metric, FontType, Lparam); 2945 FontList.Append(Tmp); 2946 end; 2947 end else begin 2948 EnumLogFont.elfLogFont := XLFDNameToLogFont(XFonts[i]); 2949 EnumlogFont.elfFullname := ''; 2950 EnumLogFont.elfStyle := ''; 2951 FillChar(Metric, SizeOf(Metric), #0); 2952 FontType := 0; // todo: GetFontTypeFromXLDF or FontId 2953 EnumFontFamProc(EnumLogFont, Metric, FontType, Lparam); 2954 end; 2955 end; 2956 end; 2957 finally 2958 {$ifdef HasX} 2959 XFreeFontNames(XFonts); 2960 {$endif} 2961 end; 2962 finally 2963 Fontlist.Free; 2964 end; 2965end; 2966 2967function TGtk2WidgetSet.EnumFontFamiliesEx(DC: HDC; lpLogFont: PLogFont; 2968 Callback: FontEnumExProc; Lparam:LParam; Flags: dword): longint; 2969type 2970 TXLFD=record 2971 Foundry: string[15]; 2972 Family, CharsetReg, CharsetCod: string[32]; 2973 WeightName,widthName,StyleName: string[20]; 2974 Slant: string[5]; 2975 PixelSize,PointSize,ResX,ResY: Integer; 2976 end; 2977 2978var 2979 Xlfd: TXLFD; 2980 CharsetFilter: TStringList; 2981 PitchFilter: TStringList; 2982 EnumLogFont: TEnumLogFontEx; 2983 Metric: TNewTextMetricEx; 2984 2985 function ParseXLFDFont(const font: string): boolean; 2986 function MyStrToIntDef(const s: string; def: integer): integer; 2987 begin 2988 result := StrToIntDef(s, Def); 2989 if result=0 then 2990 result := def 2991 end; 2992 begin 2993 result := IsFontNameXLogicalFontDesc(font); 2994 fillchar(Xlfd, SizeOf(Xlfd), 0); 2995 if result then with Xlfd do begin 2996 Foundry := ExtractXLFDItem(Font, XLFD_FOUNDRY); 2997 Family := ExtractXLFDItem(Font, XLFD_FAMILY); 2998 CharsetReg := ExtractXLFDItem(Font, XLFD_CHARSET_REG); 2999 CharSetCod := ExtractXLFDItem(Font, XLFD_CHARSET_COD); 3000 WeightName := ExtractXLFDItem(Font, XLFD_WEIGHTNAME); 3001 Slant := ExtractXLFDItem(Font, XLFD_SLANT); 3002 WidthName := ExtractXLFDItem(Font, XLFD_WIDTHNAME); 3003 StyleName := ExtractXLFDItem(Font, XLFD_STYLENAME); 3004 ResX := MyStrToIntDef(ExtractXLFDItem(Font, XLFD_RESX), 72); 3005 ResY := MyStrToIntDef(ExtractXLFDItem(Font, XLFD_RESX), 72); 3006 PixelSize := StrToIntDef(ExtractXLFDItem(Font, XLFD_PIXELSIZE), 0); 3007 PointSize := StrToIntDef(ExtractXLFDItem(Font, XLFD_POINTSIZE), 0); 3008 end; 3009 end; 3010 3011 function XLFDToFontStyle: string; 3012 var 3013 s: string; 3014 begin 3015 result := xlfd.WeightName; 3016 s :=lowercase(xlfd.Slant); 3017 if s='i' then result := result + ' '+ 'italic' else 3018 if s='o' then result := result + ' '+ 'oblique' else 3019 if s='ri' then result := result + ' '+ 'reverse italic' else 3020 if s='ro' then result := result + ' '+ 'reverse oblique' 3021 else begin 3022 if (S<>'r')and(S<>'') then 3023 result := result + ' ' + S; 3024 end; 3025 end; 3026 3027 procedure QueueCharsetFilter(Charset: byte); 3028 var 3029 i: integer; 3030 rec: PCharsetEncodingRec; 3031 s: string; 3032 begin 3033 for i:=0 to CharsetEncodingList.count-1 do begin 3034 Rec := CharsetEncodingList[i]; 3035 if (Rec=nil) or (Rec^.CharSet<>Charset) or (not Rec^.EnumMap) then 3036 continue; 3037 s := Rec^.CharSetReg; 3038 if Rec^.CharsetRegPart then 3039 s := s + '*'; 3040 s := s + '-' + Rec^.CharSetCod; 3041 if Rec^.CharsetCodPart then 3042 s := s + '*'; 3043 CharsetFilter.Add(s); 3044 end; 3045 end; 3046 3047 procedure QueuePitchFilter(Pitch: byte); 3048 begin 3049 3050 if pitch and FIXED_PITCH = FIXED_PITCH then begin 3051 PitchFilter.Add('m'); 3052 PitchFilter.Add('c'); // character cell it's also fixed pitch 3053 end; 3054 3055 if pitch and VARIABLE_PITCH = VARIABLE_PITCH then 3056 PitchFilter.Add('p'); 3057 3058 if pitch and MONO_FONT = MONO_FONT then 3059 PitchFilter.Add('m'); 3060 3061 if PitchFilter.Count=0 then 3062 PitchFilter.Add('*'); 3063 end; 3064 3065 function XLFDToCharset: byte; 3066 const 3067 CharsetPriority: array[1..19] of byte = 3068 ( 3069 SYMBOL_CHARSET, MAC_CHARSET, SHIFTJIS_CHARSET, 3070 HANGEUL_CHARSET, JOHAB_CHARSET, GB2312_CHARSET, 3071 CHINESEBIG5_CHARSET, GREEK_CHARSET, TURKISH_CHARSET, 3072 VIETNAMESE_CHARSET, HEBREW_CHARSET, ARABIC_CHARSET, 3073 BALTIC_CHARSET, RUSSIAN_CHARSET, THAI_CHARSET, 3074 EASTEUROPE_CHARSET, OEM_CHARSET, FCS_ISO_10646_1, 3075 ANSI_CHARSET 3076 ); 3077 var 3078 i,n: integer; 3079 rec: PCharsetEncodingRec; 3080 begin 3081 for i := Low(CharsetPriority) to High(CharsetPriority) do 3082 for n:= 0 to CharsetEncodingList.count-1 do begin 3083 rec := CharsetEncodingList[n]; 3084 if (rec=nil) or (rec^.CharSet<>CharsetPriority[i]) then 3085 continue; 3086 // try to match registry part 3087 if rec^.CharSetReg<>'*' then begin 3088 if rec^.CharsetRegPart then begin 3089 if pos(rec^.CharSetReg, xlfd.CharsetReg)=0 then 3090 continue; 3091 end else begin 3092 if AnsiCompareText(Rec^.CharSetReg, xlfd.CharsetReg) <> 0 then 3093 continue; 3094 end; 3095 end; 3096 // try to match coding part 3097 if rec^.CharSetCod<>'*' then begin 3098 if rec^.CharsetCodPart then begin 3099 if pos(rec^.CharSetCod, xlfd.CharsetCod)=0 then 3100 continue; 3101 end else begin 3102 if AnsiCompareText(Rec^.CharSetCod, xlfd.CharsetCod) <> 0 then 3103 continue; 3104 end; 3105 end; 3106 // this one is good enought to match bot registry and encondig part 3107 result := CharsetPriority[i]; 3108 exit; 3109 end; 3110 result := DEFAULT_CHARSET; 3111 end; 3112 3113 function XLFDCharsetToScript: string; 3114 begin 3115 result := xlfd.CharsetReg + '-' + xlfd.CharsetCod; 3116 end; 3117 3118 function FoundryAndFamilyFilter(const FaceName: string): string; 3119 var 3120 foundry,family: string; 3121 i: LongInt; 3122 begin 3123 if FaceName='' then begin 3124 family := '*'; 3125 foundry := '*'; 3126 end else begin 3127 family := FaceName; 3128 // look for foundry encoded in family name 3129 i := pos(FOUNDRYCHAR_OPEN, family); 3130 if i<>0 then begin 3131 Foundry := copy(Family, i+1, Length(Family)); 3132 family := trim(copy(family, 1, i-1)); 3133 i := pos(FOUNDRYCHAR_CLOSE, Foundry); 3134 if i<>0 then 3135 Delete(Foundry, i, Length(Foundry)) 3136 else 3137 ; // ill formed but it's ok. 3138 end else 3139 Foundry := '*'; 3140 end; 3141 result := Foundry+'-'+Family; 3142 end; 3143 3144 function XLFDFamilyFace: string; 3145 begin 3146 with xlfd do 3147 if (Length(Foundry)>0) and (Length(Family) + length(Foundry) + 3 < 31) then 3148 result := Family + ' '+ FOUNDRYCHAR_OPEN + Foundry + FOUNDRYCHAR_CLOSE 3149 else 3150 result := Family; 3151 end; 3152 3153 function XLFDToFontType: integer; 3154 begin 3155 if ((xlfd.PointSize=0) and (xlfd.PixelSize=0)) 3156 or ((xlfd.PointSize=120) and (xlfd.PixelSize=17)) // see bug 16298 3157 then 3158 result := TRUETYPE_FONTTYPE 3159 else 3160 result := RASTER_FONTTYPE or DEVICE_FONTTYPE; 3161 end; 3162 3163 // process the current xlfd font, if user returns 0 from callback finish 3164 function ProcessXFont(const index: integer; const font: string; 3165 FontList: TStringList): boolean; 3166 var 3167 FontType: Integer; 3168 tmp: string; 3169 FullSearch: boolean; 3170 begin 3171 FullSearch := ( lpLogFont^.lfFaceName = ''); 3172 result := false; 3173 with xlfd, EnumLogFont do 3174 if FullSearch then begin 3175 // 3176 // quick enumeration of fonts, make sure this is 3177 // documented because only some fields are filled !!! 3178 // 3179 Foundry := ExtractXLFDItem(Font, XLFD_FOUNDRY); 3180 Family := ExtractXLFDItem(Font, XLFD_FAMILY); 3181 tmp := XLFDFamilyFace(); 3182 3183 if FontList.IndexOf(tmp) < 0 then begin 3184 PixelSize := StrToIntDef(ExtractXLFDItem(Font, XLFD_PIXELSIZE), 0); 3185 PointSize := StrToIntDef(ExtractXLFDItem(Font, XLFD_POINTSIZE), 0); 3186 CharsetReg := ExtractXLFDItem(Font, XLFD_CHARSET_REG); 3187 CharsetCod := ExtractXLFDItem(Font, XLFD_CHARSET_COD); 3188 FontType := XLFDToFontType(); 3189 elfLogFont.lfCharSet := XLFDToCharset(); 3190 elfLogFont.lfFaceName := tmp; 3191 result := Callback(EnumLogFont, Metric, FontType, LParam)=0; 3192 FontList.Append(tmp); 3193 end; 3194 end else 3195 if ParseXLFDFont(Font) then begin 3196 // 3197 // slow enumeration of fonts, only if face is present 3198 // 3199 // family 3200 tmp := XLFDFamilyFace(); 3201 {$ifdef verboseEnumFonts} 3202 DebugLn(dbgs(index),' face=', tmp, ' Font=', Font); 3203 {$endif} 3204 3205 //if FontList.IndexOf(tmp) < 0 then begin 3206 3207 // Fonttype 3208 FontType := XLFDToFontType(); 3209 // LogFont 3210 elfLogFont := XLFDNameToLogFont(Font); 3211 elfLogFont.lfFaceName := tmp; 3212 elfLogFont.lfCharSet := XLFDToCharset(); 3213 // from logfont 3214 3215 elfStyle := XLFDToFontStyle(); 3216 3217 elfScript := XLFDCharsetToScript(); 3218 // tempted to feed here full xlfd, but 63 chars might be to small 3219 if Foundry = '' then 3220 elfFullName := Family 3221 else 3222 elfFullName := Foundry + ' ' + Family ; 3223 3224 // Metric 3225 // 3226 fillchar(metric.ntmeFontSignature, 3227 sizeOf(metric.ntmeFontSignature), 0); 3228 with metric.ntmentm do begin 3229 tmheight := elfLogFont.lfHeight; 3230 tmAveCharWidth := elfLogFont.lfWidth; 3231 tmWeight := elfLogFont.lfWeight; 3232 tmDigitizedAspectX := ResX; 3233 tmDigitizedAspectY := ResY; 3234 tmItalic := elfLogFont.lfItalic; 3235 tmUnderlined := elfLogFont.lfUnderline; 3236 tmStruckOut := elfLogFont.lfStrikeOut; 3237 tmPitchAndFamily := elfLogFont.lfPitchAndFamily; 3238 tmCharSet := elfLogFont.lfCharSet; 3239 // todo fields 3240 tmMaxCharWidth := elfLogFont.lfWidth; // todo 3241 tmAscent := 0; // todo 3242 tmDescent := 0; // todo 3243 tmInternalLeading := 0; // todo 3244 tmExternalLeading := 0; // todo 3245 tmOverhang := 0; // todo; 3246 tmFirstChar := ' '; // todo, atm ascii 3247 tmLastChar := #255; // todo, atm ascii 3248 tmDefaultChar := '.'; // todo, atm dot 3249 tmBreakChar := ' '; // todo, atm space 3250 ntmFlags := 0; // todo combination of NTM_XXXX constants 3251 ntmSizeEM := tmHeight; // todo 3252 ntmCellHeight := ntmSizeEM; // todo 3253 ntmAvgWidth := ntmSizeEM; // todo 3254 end; // with metric.ntmentm do ... 3255 3256 // do callback 3257 result := Callback(EnumLogFont, Metric, FontType, LParam) = 0; 3258 FontList.Append(tmp); 3259 //end; // if not FullSearch or (FontList.IndexOf(tmp) < 0 then ... 3260 end; // with xlfd, EnumLogFont do ... 3261 end; 3262var 3263 xFonts: PPChar; 3264 FontList: TStringList; 3265 I,J,K,N: Integer; 3266 Tmp,FandF: String; 3267begin 3268 result := 0; 3269 // initial checks 3270 if not Assigned(Callback) then begin 3271 result := 2; 3272 DebugLn('EnumFontFamiliesEx: EnumFontFamProcEx Callback not set'); 3273 // todo: raise exception? 3274 exit; 3275 end; 3276 if not Assigned(lpLogFont) then begin 3277 result := 3; 3278 DebugLn('EnumFontFamiliesEx: lpLogFont not set'); 3279 // todo: enumerate all fonts? 3280 exit; 3281 end; 3282 3283 // foundry and family filter 3284 FandF := FoundryAndFamilyFilter(lpLogFont^.lfFaceName); 3285 3286 FontList := TStringlist.Create; 3287 CharSetFilter := TStringList.Create; 3288 PitchFilter := TStringList.Create; 3289 PitchFilter.Duplicates := dupIgnore; 3290 try 3291 QueueCharSetFilter(lpLogFont^.lfCharSet); 3292 QueuePitchFilter(lpLogFont^.lfPitchAndFamily); 3293 3294 {$ifdef verboseEnumFonts} 3295 for j:=0 to CharSetFilter.Count-1 do begin 3296 // pitch filter is guaranteed to have at least one element 3297 for k:=0 to PitchFilter.Count-1 do begin 3298 tmp := '-'+FAndF+'-*-*-*-*-*-*-*-*-'+PitchFilter[k]+'-*-'+CharSetFilter[j]; 3299 DebugLn('EnumFontFamiliesEx: will enumerate fonts matching: ', tmp); 3300 end; 3301 end; 3302 {$endif} 3303 for j:=0 to CharSetFilter.Count-1 do begin 3304 for k:=0 to PitchFilter.Count-1 do begin 3305 tmp := '-'+FAndF+'-*-*-*-*-*-*-*-*-'+PitchFilter[k]+'-*-'+CharSetFilter[j]; 3306 {$ifdef HasX} 3307 XFonts := XListFonts(gdk_display, pchar(Tmp), 10000, @N); 3308 {$else} 3309 {$IFDEF VerboseGtkToDos}{$warning implement getting XFonts for this OS}{$ENDIF} 3310 XFonts := nil; 3311 N:=0; 3312 {$endif} 3313 try 3314 {$ifdef VerboseEnumFonts} 3315 DebugLn('EnumFontFamiliesEx: found ',dbgs(N),' fonts matching: ', tmp); 3316 {$endif} 3317 for i:=0 to N-1 do 3318 if XFonts[i]<>nil then 3319 if ProcessXFont(i, XFonts[i], FontList) then 3320 break; 3321 finally 3322 {$ifdef HasX} 3323 XFreeFontNames(XFonts); 3324 {$endif} 3325 end; 3326 end; 3327 end; 3328 finally 3329 PitchFilter.Free; 3330 Fontlist.Free; 3331 CharSetFilter.Free; 3332 end; 3333end; 3334 3335{$ELSE} // pure pango font families 3336 3337function TGtk2WidgetSet.EnumFontFamiliesEx(DC: HDC; lpLogFont: PLogFont; 3338 Callback: FontEnumExProc; Lparam:LParam; Flags: dword): longint; 3339 3340type 3341 TPangoFontFaces = packed record 3342 FamilyName: String; 3343 Faces: Array of String; 3344 end; 3345 PPangoFontFaces = Array of TPangoFontFaces; 3346 3347var 3348 i: Integer; 3349 FontType: Integer; 3350 EnumLogFont: TEnumLogFontEx; 3351 Metric: TNewTextMetricEx; 3352 FontList: TStringList; 3353 Faces: PPangoFontFaces; 3354 3355 AStyle: String; 3356 StylesCount: Integer; 3357 StylesList: TStringList; 3358 y: Integer; 3359 CharsetList: TByteList; 3360 CS: Byte; 3361 3362 function Gtk2GetFontFamiliesDefault(var AList: TStringList): Integer; 3363 var 3364 i, j: Integer; 3365 AFamilies: PPPangoFontFamily; 3366 AFaces: PPPangoFontFace; 3367 ANumFaces: Integer; 3368 PContext: PPangoContext; 3369 begin 3370 AList.Clear; 3371 SetLength(Faces, 0); 3372 Result := -1; 3373 AFamilies := nil; 3374 3375 PContext := gdk_pango_context_get; 3376 pango_context_list_families(PContext, @AFamilies, @Result); 3377 SetLength(Faces, Result); 3378 for i := 0 to Result - 1 do 3379 begin 3380 j := AList.Add(StrPas(pango_font_family_get_name(AFamilies[i]))); 3381 AList.Objects[j] := TObject(PtrUInt(pango_font_family_is_monospace(AFamilies[i]))); 3382 Faces[i].FamilyName := AList[j]; 3383 AFaces := nil; 3384 pango_font_family_list_faces(AFamilies[i], @AFaces, @ANumFaces); 3385 SetLength(Faces[i].Faces, ANumFaces); 3386 for j := 0 to ANumFaces - 1 do 3387 Faces[i].Faces[j] := StrPas(pango_font_face_get_face_name(AFaces[j])); 3388 g_free(AFaces); 3389 end; 3390 g_free(AFamilies); 3391 g_object_unref(PContext); 3392 end; 3393 3394 function Gtk2GetFontFamilies(var List: TStringList; 3395 const APitch: Byte; 3396 const AFamilyName: String; 3397 const {%H-}AWritingSystem: Byte): Integer; 3398 var 3399 StrLst: TStringList; 3400 NewList: TStringList; 3401 S: String; 3402 j: integer; 3403 begin 3404 Result := -1; 3405 StrLst := TStringList.Create; 3406 NewList := TStringList.Create; 3407 3408 try 3409 Gtk2GetFontFamiliesDefault(StrLst); 3410 for j := 0 to StrLst.Count - 1 do 3411 begin 3412 S := StrLst[j]; 3413 if APitch <> DEFAULT_PITCH then 3414 begin 3415 case APitch of 3416 FIXED_PITCH, MONO_FONT: 3417 begin 3418 if StrLst.Objects[j] <> nil then 3419 NewList.Add(S); 3420 end; 3421 VARIABLE_PITCH: 3422 begin 3423 if StrLst.Objects[j] = nil then 3424 NewList.Add(S); 3425 end; 3426 end; 3427 end else 3428 NewList.Add(S); 3429 end; 3430 3431 if AFamilyName <> '' then 3432 begin 3433 for j := NewList.Count - 1 downto 0 do 3434 begin 3435 S := NewList[j];; 3436 if S <> AFamilyName then 3437 NewList.Delete(J); 3438 end; 3439 end; 3440 for j := 0 to NewList.Count - 1 do 3441 begin 3442 S := NewList[j]; 3443 List.Add(S); 3444 end; 3445 Result := List.Count; 3446 finally 3447 StrLst.Free; 3448 NewList.Free; 3449 end; 3450 end; 3451 3452 function GetStyleAt(AIndex: Integer): String; 3453 var 3454 S: String; 3455 begin 3456 Result := ''; 3457 if (AIndex >= 0) and (AIndex < StylesList.Count) then 3458 begin 3459 S := StylesList[AIndex]; 3460 Result := S; 3461 end; 3462 end; 3463 3464 function FillLogFontA(const AIndex: Integer; var ALogFontA: TLogFontA; 3465 var {%H-}AMetric: TNewTextMetricEx; var {%H-}AFontType: Integer; 3466 out AStyle: String): Integer; 3467 var 3468 Font: PPangoFontDescription; 3469 FontStyle: TPangoStyle; 3470 FontWeight: TPangoWeight; 3471 S: String; 3472 i: Integer; 3473 begin 3474 S := FontList[AIndex]; 3475 Font := pango_font_description_from_string(PChar(S)); 3476 3477 FontStyle := pango_font_description_get_style(Font); 3478 FontWeight := pango_font_description_get_weight(Font); 3479 3480 ALogFontA.lfItalic := Byte(FontStyle = PANGO_STYLE_ITALIC); 3481 3482 // keep newer pango compat to LCL 3483 if FontWeight = 380 {PANGO_WEIGHT_BOOK as of pango 1.24} then 3484 FontWeight := PANGO_WEIGHT_NORMAL 3485 else 3486 if FontWeight = 1000 {PANGO_WEIGHT_ULTRAHEAVY as of pango 1.24} then 3487 FontWeight := PANGO_WEIGHT_HEAVY; 3488 3489 ALogFontA.lfWeight := FontWeight; 3490 3491 ALogFontA.lfHeight := pango_font_description_get_size(Font); 3492 if not pango_font_description_get_size_is_absolute(Font) then 3493 ALogFontA.lfHeight := ALogFontA.lfHeight div PANGO_SCALE; 3494 3495 // pango does not have underline and strikeout params for font 3496 // ALogFontA.lfUnderline := ; 3497 // ALogFontA.lfStrikeOut := ; 3498 3499 StylesList.Clear; 3500 for i := High(Faces[AIndex].Faces) downto 0 do 3501 StylesList.Add(Faces[AIndex].Faces[i]); 3502 3503 AStyle := ''; 3504 Result := StylesList.Count; 3505 3506 if StylesList.Count > 0 then 3507 AStyle := GetStyleAt(0); 3508 3509 // current pango support in fpc is really poor, we cannot 3510 // get PangoScript since it's in pango >= 1.4 3511 // FillCharsetListForFont() 3512 end; 3513 3514begin 3515 Result := 0; 3516 {$ifdef VerboseEnumFonts} 3517 WriteLn('[TGtk2WidgetSet.EnumFontFamiliesEx] Charset=',lpLogFont^.lfCharSet, 3518 ' face ',lpLogFont^.lfFaceName,' pitchAndFamily=',lpLogFont^.lfPitchAndFamily); 3519 {$endif} 3520 Result := 0; 3521 Metric.ntmentm.ntmAvgWidth := 0; // just to shutup compiler 3522 if (lpLogFont^.lfCharSet = DEFAULT_CHARSET) and 3523 (lpLogFont^.lfFaceName= '') and 3524 (lpLogFont^.lfPitchAndFamily = 0) then 3525 begin 3526 FontType := 0; 3527 FontList := TStringList.create; 3528 try 3529 if Gtk2GetFontFamiliesDefault(FontList) > 0 then 3530 begin 3531 for i := 0 to FontList.Count - 1 do 3532 begin 3533 EnumLogFont.elfLogFont.lfFaceName := FontList[i]; 3534 Result := Callback(EnumLogFont, Metric, FontType, LParam); 3535 end; 3536 end; 3537 finally 3538 FontList.free; 3539 end; 3540 end else 3541 begin 3542 Result := 0; 3543 FontType := TRUETYPE_FONTTYPE; 3544 FontList := TStringList.Create; 3545 StylesList := TStringList.Create; 3546 CharsetList := TByteList.Create; 3547 for i := 0 to CharsetEncodingList.Count - 1 do 3548 begin 3549 CS := TCharSetEncodingRec(CharsetEncodingList.Items[i]^).CharSet; 3550 if CharsetList.IndexOf(CS) = -1 then 3551 CharsetList.Add(CS); 3552 end; 3553 try 3554 if Gtk2GetFontFamilies(FontList, lpLogFont^.lfPitchAndFamily, 3555 lpLogFont^.lfFaceName, lpLogFont^.lfCharSet) > 0 then 3556 begin 3557 for i := 0 to FontList.Count - 1 do 3558 begin 3559 EnumLogFont.elfLogFont.lfFaceName := FontList[i]; 3560 EnumLogFont.elfLogFont.lfPitchAndFamily := lpLogFont^.lfPitchAndFamily; 3561 EnumLogFont.elfFullName := FontList[i]; 3562 3563 StylesCount := FillLogFontA(i, EnumLogFont.elfLogFont, Metric, FontType, 3564 AStyle); 3565 EnumLogFont.elfStyle := AStyle; 3566 3567 if CharSetList.Count > 0 then 3568 EnumLogFont.elfLogFont.lfCharSet := CharsetList.Items[0]; 3569 3570 Result := Callback(EnumLogFont, Metric, FontType, LParam); 3571 for y := 1 to StylesCount - 1 do 3572 begin 3573 AStyle := GetStyleAt(y); 3574 EnumLogFont.elfStyle := AStyle; 3575 Result := Callback(EnumLogFont, Metric, FontType, LParam); 3576 end; 3577 for y := 1 to CharSetList.Count - 1 do 3578 begin 3579 EnumLogFont.elfLogFont.lfCharSet := CharsetList.Items[y]; 3580 Result := Callback(EnumLogFont, Metric, FontType, LParam); 3581 end; 3582 end; 3583 end; 3584 finally 3585 CharSetList.Free; 3586 StylesList.Free; 3587 FontList.Free; 3588 end; 3589 end; 3590end; 3591{$ENDIF} 3592 3593 3594{------------------------------------------------------------------------------ 3595 Method: Ellipse 3596 Params: X1, Y1, X2, Y2 3597 Returns: Nothing 3598 3599 Use Ellipse to draw a filled circle or ellipse. 3600 ------------------------------------------------------------------------------} 3601function TGtk2WidgetSet.Ellipse(DC: HDC; x1, y1, x2, y2: Integer): Boolean; 3602var 3603 DevCtx: TGtkDeviceContext absolute DC; 3604 Left, Top, Width, Height: Integer; 3605 DCOrigin: TPoint; 3606begin 3607 Result := IsValidDC(DC); 3608 if not Result then Exit; 3609 3610 if DevCtx.HasTransf then 3611 DevCtx.TransfRect(X1, Y1, X2, Y2); 3612 3613 CalculateLeftTopWidthHeight(X1, Y1, X2, Y2, Left, Top, Width, Height); 3614 if (Width = 0) or (Height = 0) then Exit(True); 3615 // X2, Y2 is not part of the rectangle 3616 dec(Width); 3617 dec(Height); 3618 3619 // first draw interior in brush color 3620 DCOrigin := DevCtx.Offset; 3621 3622 {$IFDEF DebugGDKTraps} 3623 BeginGDKErrorTrap; 3624 {$ENDIF} 3625 3626 if not DevCtx.IsNullBrush then 3627 begin 3628 DevCtx.SelectBrushProps; 3629 DevCtx.RemovePixbuf; 3630 gdk_draw_arc(DevCtx.Drawable, DevCtx.GC, 1, 3631 Left+DCOrigin.X, Top+DCOrigin.Y, Width, Height, 0, 360 shl 6); 3632 end; 3633 3634 // Draw outline 3635 3636 DevCtx.SelectPenProps; 3637 if (dcfPenSelected in DevCtx.Flags) then 3638 begin 3639 Result := True; 3640 if not DevCtx.IsNullPen then 3641 begin 3642 DevCtx.RemovePixbuf; 3643 gdk_draw_arc(DevCtx.Drawable, DevCtx.GC, 0, 3644 Left+DCOrigin.X, Top+DCOrigin.Y, Width, Height, 0, 360 shl 6); 3645 end; 3646 end 3647 else 3648 Result := False; 3649 3650 {$IFDEF DebugGDKTraps} 3651 EndGDKErrorTrap; 3652 {$ENDIF} 3653end; 3654 3655{------------------------------------------------------------------------------ 3656 Method: EqualRgn 3657 Params: Rgn1: HRGN; Rgn2: HRGN 3658 Returns: True if the two regions are equal 3659 3660 Checks the two specified regions to determine whether they are identical. The 3661 function considers two regions identical if they are equal in size and shape. 3662 ------------------------------------------------------------------------------} 3663function TGtk2WidgetSet.EqualRgn(Rgn1: HRGN; Rgn2: HRGN): Boolean; 3664var 3665 AGdiObject: PGdiObject absolute Rgn1; 3666 BGdiObject: PGdiObject absolute Rgn2; 3667begin 3668 Result := IsValidGDIObject(Rgn1) and IsValidGDIObject(Rgn2); 3669 if Result then 3670 Result := gdk_region_equal(AGdiObject^.GDIRegionObject, 3671 BGdiObject^.GDIRegionObject); 3672end; 3673 3674{------------------------------------------------------------------------------ 3675 Function: ExcludeClipRect 3676 Params: dc: hdc; Left, Top, Right, Bottom : Integer 3677 Returns: integer 3678 3679 Subtracts all intersecting points of the passed bounding rectangle 3680 (Left, Top, Right, Bottom) from the Current clipping region in the 3681 device context (dc). 3682 3683 The result can be one of the following constants 3684 Error 3685 NullRegion 3686 SimpleRegion 3687 ComplexRegion 3688 ------------------------------------------------------------------------------} 3689function TGtk2WidgetSet.ExcludeClipRect(dc: hdc; 3690 Left, Top, Right, Bottom : Integer) : Integer; 3691begin 3692 Result := Inherited ExcludeClipRect(DC, Left, Top, Right, Bottom); 3693end; 3694 3695function TGtk2WidgetSet.ExtCreatePen(dwPenStyle, dwWidth: DWord; 3696 const lplb: TLogBrush; dwStyleCount: DWord; lpStyle: PDWord): HPEN; 3697var 3698 GObject: PGdiObject; 3699 i: integer; 3700begin 3701 GObject := NewGDIObject(gdiPen); 3702 GObject^.UnTransfPenWidth := 0; 3703 GObject^.IsExtPen := True; 3704 GObject^.GDIPenStyle := dwPenStyle; 3705 GObject^.GDIPenWidth := dwWidth; 3706 SetGDIColorRef(GObject^.GDIPenColor, lplb.lbColor); 3707 GObject^.GDIPenDashesCount := dwStyleCount; 3708 3709 if dwStyleCount > 0 then 3710 begin 3711 GetMem(GObject^.GDIPenDashes, dwStyleCount * SizeOf(gint8)); 3712 for i := 0 to dwStyleCount - 1 do 3713 GObject^.GDIPenDashes[i] := lpStyle[i]; 3714 end; 3715 3716 Result := HPEN({%H-}PtrUInt(GObject)); 3717end; 3718 3719{------------------------------------------------------------------------------ 3720 Function: ExtSelectClipRGN 3721 Params: dc, RGN, Mode 3722 Returns: integer 3723 3724 Combines the passed Region with the current clipping region in the device 3725 context (dc), using the specified mode. 3726 3727 The Combine Mode can be one of the following: 3728 RGN_AND : all points which are in both regions 3729 3730 RGN_COPY : an exact copy of the source region, same as SelectClipRGN 3731 3732 RGN_DIFF : all points which are in the Clipping Region but 3733 not in the Source.(Clip - RGN) 3734 3735 RGN_OR : all points which are in either the Clip Region or 3736 in the Source.(Clip + RGN) 3737 3738 RGN_XOR : all points which are in either the Clip Region 3739 or in the Source, but not in both. 3740 3741 The result can be one of the following constants 3742 Error 3743 NullRegion 3744 SimpleRegion 3745 ComplexRegion 3746 ------------------------------------------------------------------------------} 3747function TGtk2WidgetSet.ExtSelectClipRGN(dc: hdc; rgn : hrgn; 3748 Mode : Longint) : Integer; 3749var 3750 Clip, 3751 Tmp : hRGN; 3752 X, Y : Longint; 3753begin 3754 Result := SIMPLEREGION; 3755 if not IsValidDC(DC) then 3756 Result := ERROR 3757 else with TGtkDeviceContext(DC) do 3758 begin 3759 //DebugLn('TGtk2WidgetSet.ExtSelectClipRGN A ClipRegValid=',dbgs(DCClipRegionValid(DC)), 3760 // ' Mode=',dbgs(Mode),' RGN=',GDKRegionAsString(PGdiObject(RGN)^.GDIRegionObject)); 3761 if ClipRegion = nil then 3762 begin 3763 // there is no clipping region in the DC 3764 case Mode of 3765 RGN_COPY: 3766 begin 3767 Result := RegionType({%H-}PGdiObject(RGN)^.GDIRegionObject); 3768 If Result <> ERROR then 3769 Result := SelectClipRGN(DC, RGN); 3770 end; 3771 RGN_OR, 3772 RGN_XOR, 3773 RGN_AND, 3774 RGN_DIFF: 3775 begin 3776 // get existing clip 3777 if Drawable=nil then 3778 Clip:=CreateEmptyRegion 3779 else begin 3780 GDK_Window_Get_Size(Drawable, @X, @Y); 3781 Clip := CreateRectRGN(-Offset.X, -Offset.Y, X - Offset.X, Y - Offset.Y); 3782 end; 3783 // create target clip 3784 Tmp := CreateEmptyRegion; 3785 // combine 3786 Result := CombineRGN(Tmp, Clip, RGN, Mode); 3787 // commit 3788 //DebugLn('TGtk2WidgetSet.ExtSelectClipRGN B ClipRegValid=',dbgs(ClipRegion),' TmpRGN=',GDKRegionAsString(PGdiObject(Tmp)^.GDIRegionObject)); 3789 SelectClipRGN(DC, Tmp); 3790 // clean up 3791 DeleteObject(Clip); 3792 DeleteObject(Tmp); 3793 end; 3794 end; 3795 end 3796 else 3797 Result := inherited ExtSelectClipRGN(dc, rgn, mode); 3798 end; 3799end; 3800 3801{------------------------------------------------------------------------------ 3802 Function: ExtTextOut 3803 Params: none 3804 Returns: Nothing 3805 3806 gdk_drawable_get_size(pixmap, @Width, @Height); 3807 3808 ------------------------------------------------------------------------------} 3809function TGtk2WidgetSet.ExtTextOut(DC: HDC; X, Y: Integer; Options: Longint; 3810 Rect: PRect; Str: PChar; Count: Longint; Dx: PInteger): Boolean; 3811var 3812 DevCtx: TGtkDeviceContext absolute DC; 3813 3814 LineStart, LineEnd, StrEnd: PChar; 3815 Width, Height: Integer; 3816 TopY, LineLen, LineHeight, SavedDC: Integer; 3817 TxtPt: TPoint; 3818 DCOrigin: TPoint; 3819 Foreground, BackgroundColor: PGDKColor; 3820 CurDx: PInteger; 3821 CurStr: PChar; 3822 R: TRect; 3823 3824 procedure DoTextOut(X,Y : Integer; Str: Pchar; CurCount: Integer); 3825 var 3826 CurScreenX: LongInt; 3827 CharLen: LongInt; 3828 begin 3829 if (Dx <> nil) then 3830 begin 3831 CurScreenX := X; 3832 while CurCount > 0 do 3833 begin 3834 CharLen := UTF8CodepointSize(CurStr); 3835 DevCtx.DrawTextWithColors(CurStr, CharLen, CurScreenX, Y, Foreground, BackgroundColor); 3836 inc(CurScreenX, CurDx^); 3837 inc(CurDx); 3838 inc(CurStr, CharLen); 3839 dec(CurCount, CharLen); 3840 end; 3841 end 3842 else 3843 DevCtx.DrawTextWithColors(Str, Count, X, Y, Foreground, BackgroundColor); 3844 end; 3845 3846begin 3847 //DebugLn(['TGtk2WidgetSet.ExtTextOut X=',X,' Y=',Y,' Str="',copy(Str,1,Count),'" Count=',Count,' DX=',dbgs(DX)]); 3848 //DebugLn(Format('trace:> [TGtk2WidgetSet.ExtTextOut] DC:0x%x, X:%d, Y:%d, Options:%d, Str:''%s'', Count: %d', [DC, X, Y, Options, Str, Count])); 3849 Result := IsValidDC(DC); 3850 if not Result then Exit; 3851 3852 if DevCtx.GC <> nil then; // create GC 3853 3854 if ((Options and (ETO_OPAQUE + ETO_CLIPPED)) <> 0) and (Rect = nil) then 3855 begin 3856 R := RectFromGdkRect(DevCtx.ClipRect); 3857 OffsetRect(R, -R.Left, -R.Top); 3858 OffsetRect(R, X, Y); 3859 DrawText(DC, Str, Count, R, DT_SINGLELINE or DT_CALCRECT); 3860 Rect := @R; 3861 end; 3862 3863 BackgroundColor := nil; 3864 3865 // to reduce flickering calculate first and then paint 3866 3867 DCOrigin := DevCtx.Offset; 3868 3869 if (Options and ETO_CLIPPED) <> 0 then 3870 begin 3871 SavedDC := SaveDC(DC); 3872 IntersectClipRect(DC, Rect^.Left, Rect^.Top, Rect^.Right, Rect^.Bottom); 3873 end; 3874 3875 if DevCtx.HasTransf then 3876 begin 3877 if Assigned(Rect) then 3878 Rect^ := DevCtx.TransfRectIndirect(Rect^); 3879 DevCtx.TransfPoint(X, Y); 3880 end; 3881 3882 LineLen := FindLineLen(Str,Count); 3883 TopY := Y; 3884 UpdateDCTextMetric(DevCtx); 3885 TxtPt.X := X + DCOrigin.X; 3886 LineHeight := DevCtx.DCTextMetric.TextMetric.tmHeight; 3887 TxtPt.Y := TopY + DCOrigin.Y; 3888 3889 DevCtx.SelectedColors := dcscCustom; 3890 3891 if ((Options and ETO_OPAQUE) <> 0) then 3892 begin 3893 Width := Rect^.Right - Rect^.Left; 3894 Height := Rect^.Bottom - Rect^.Top; 3895 EnsureGCColor(DC, dccCurrentBackColor, True, False); 3896 DevCtx.RemovePixbuf; 3897 gdk_draw_rectangle(DevCtx.Drawable, DevCtx.GC, 1, 3898 Rect^.Left+DCOrigin.X, Rect^.Top+DCOrigin.Y, 3899 Width, Height); 3900 end; 3901 3902 3903 if (DevCtx.BkMode = OPAQUE) then 3904 begin 3905 AllocGDIColor(DC, @DevCtx.CurrentBackColor); 3906 BackGroundColor := @DevCtx.CurrentBackColor.Color; 3907 end; 3908 3909 EnsureGCColor(DC, dccCurrentTextColor, True, False); 3910 Foreground := nil;//StyleForegroundColor(CurrentTextColor.ColorRef, nil); 3911 3912 CurDx:=Dx; 3913 CurStr:=Str; 3914 LineStart:=Str; 3915 if LineLen < 0 then 3916 begin 3917 LineLen:=Count; 3918 if Count> 0 then 3919 DoTextOut(TxtPt.X, TxtPt.Y, LineStart, LineLen); 3920 end else 3921 begin //write multiple lines 3922 StrEnd := Str + Count; 3923 while LineStart < StrEnd do 3924 begin 3925 LineEnd := LineStart + LineLen; 3926 if LineLen>0 then 3927 DoTextOut(TxtPt.X, TxtPt.Y, LineStart, LineLen); 3928 inc(TxtPt.Y, LineHeight); 3929 //writeln('TGtk2WidgetSet.ExtTextOut ',LineHeight,' ',DevCtx.DCTextMetric.TextMetric.tmAscent,' ',DevCtx.DCTextMetric.TextMetric.tmDescent); 3930 LineStart := LineEnd + 1; // skip #13 3931 if (LineStart<StrEnd) and (LineStart^ in [#10,#13]) 3932 and (LineStart^ <> LineEnd^) then 3933 inc(LineStart); // skip #10 3934 Count := StrEnd - LineStart; 3935 LineLen := FindLineLen(LineStart, Count); 3936 if LineLen < 0 then 3937 LineLen := Count; 3938 end; 3939 end; 3940 3941 if (Options and ETO_CLIPPED) <> 0 then 3942 RestoreDC(DC, SavedDC); 3943 Result := True; 3944 //DebugLn(Format('trace:< [TGtk2WidgetSet.ExtTextOut] DC:0x%x, X:%d, Y:%d, Options:%d, Str:''%s'', Count: %d', [DC, X, Y, Options, Str, Count])); 3945end; 3946 3947{------------------------------------------------------------------------------ 3948 Function: FillRect 3949 Params: none 3950 Returns: Nothing 3951 3952 The FillRect function fills a rectangle by using the specified brush. 3953 This function includes the left and top borders, but excludes the right and 3954 bottom borders of the rectangle. 3955 ------------------------------------------------------------------------------} 3956function TGtk2WidgetSet.FillRect(DC: HDC; const Rect: TRect; Brush: HBRUSH): Boolean; 3957var 3958 TempBr: HBrush; 3959begin 3960 Result := IsValidDC(DC) and IsValidGDIObject(Brush); 3961 if not Result or IsRectEmpty(Rect) then 3962 Exit; 3963 if ({%H-}PGdiObject(Brush)^.GDIBrushFill = GDK_TILED) and (TGtkDeviceContext(DC).BkMode = OPAQUE) then 3964 begin 3965 // fill a rectangle with a solid back color first 3966 TempBr := CreateSolidBrush(TGtkDeviceContext(DC).CurrentBackColor.ColorRef); 3967 TGtkDeviceContext(DC).FillRect(Rect, TempBr, True); 3968 DeleteObject(TempBr); 3969 end; 3970 Result := TGtkDeviceContext(DC).FillRect(Rect, Brush, True); 3971 //DebugLn(Format('trace:< [TGtk2WidgetSet.FillRect] DC:0x%x; Rect: ((%d,%d)(%d,%d)); brush: %x', [Integer(DC), Rect.left, rect.top, rect.right, rect.bottom, brush])); 3972end; 3973 3974{------------------------------------------------------------------------------ 3975 Function: FillRgn 3976 Params: DC: HDC; RegionHnd: HRGN; hbr: HBRUSH 3977 Returns: True if the function succeeds 3978 3979 Fills a region by using the specified brush 3980 ------------------------------------------------------------------------------} 3981function TGtk2WidgetSet.FillRgn(DC: HDC; RegionHnd: HRGN; hbr: HBRUSH): Bool; 3982var 3983 GtkDC: Integer; 3984 OldRgn: PGdkRegion; 3985 DevCtx: TGtkDeviceContext absolute DC; 3986 ARect: TRect; 3987 CRect : TGDKRectangle; 3988 hasClipping: Boolean; 3989begin 3990 3991 Result := IsValidDC(DC) and IsValidGDIObject(hbr) and IsValidGDIObject(RegionHnd); 3992 if not Result then Exit; 3993 GtkDC := SaveDC(DC); 3994 if (DevCtx.ClipRegion <> nil) and (DevCtx.ClipRegion^.GDIRegionObject <> nil) then 3995 OldRgn := gdk_region_copy(DevCtx.ClipRegion^.GDIRegionObject) 3996 else 3997 OldRgn := nil; 3998 hasClipping := Assigned(OldRgn); 3999 try 4000 if SelectClipRGN(DC, RegionHnd) <> ERROR then 4001 begin 4002 gdk_region_get_clipbox({%H-}PGDIObject(RegionHnd)^.GDIRegionObject, @CRect); 4003 ARect := RectFromGdkRect(CRect); 4004 DevCtx.FillRect(ARect, hbr, True); 4005 // revert clip (whatever it is - null or valid region) 4006 SelectClipRGN(DC, {%H-}HRGN(OldRgn)); 4007 Result := True; 4008 end; 4009 finally 4010 if hasClipping then 4011 gdk_region_destroy(OldRgn); 4012 RestoreDC(DC, GtkDC); 4013 end; 4014end; 4015 4016{------------------------------------------------------------------------------ 4017 Function: Frame3d 4018 Params: - 4019 Returns: Nothing 4020 4021 Draws a 3d border in GTK native style. 4022 ------------------------------------------------------------------------------} 4023function TGtk2WidgetSet.Frame3d(DC: HDC; var ARect: TRect; 4024 const FrameWidth: integer; const Style: TBevelCut): Boolean; 4025var 4026 DevCtx: TGtkDeviceContext absolute DC; 4027 TheStyle: PGtkStyle; 4028 i, AWidth: integer; 4029 P: TPoint; 4030 gc1, gc2: PGdkGC; 4031 OldGC1Values, OldGC2Values: TGdkGCValues; 4032begin 4033 Result := IsValidDC(DC); 4034 if not Result or (FrameWidth = 0) then Exit; 4035 TheStyle := gtk_widget_get_style(GetStyleWidget(lgsButton)); 4036 if TheStyle = nil then exit; 4037 4038 if DevCtx.HasTransf then 4039 begin 4040 ARect := DevCtx.TransfRectIndirect(ARect); 4041 DevCtx.TransfNormalize(ARect.Left, ARect.Right); 4042 DevCtx.TransfNormalize(ARect.Top, ARect.Bottom); 4043 P.X := FrameWidth; 4044 P.Y := FrameWidth; 4045 P := DevCtx.TransfExtentIndirect(P); 4046 AWidth := Abs(Min(P.X, P.Y)); 4047 end else 4048 AWidth := FrameWidth; 4049 4050 case Style of 4051 bvNone: 4052 begin 4053 InflateRect(ARect, -AWidth, -AWidth); 4054 Exit; 4055 end; 4056 bvLowered: 4057 begin 4058 gc1 := TheStyle^.dark_gc[GTK_STATE_NORMAL]; 4059 gc2 := TheStyle^.light_gc[GTK_STATE_NORMAL]; 4060 end; 4061 bvRaised: 4062 begin 4063 gc1 := TheStyle^.light_gc[GTK_STATE_NORMAL]; 4064 gc2 := TheStyle^.dark_gc[GTK_STATE_NORMAL]; 4065 end; 4066 bvSpace: 4067 begin 4068 InflateRect(ARect, -AWidth, -AWidth); 4069 Exit; 4070 end; 4071 end; 4072 4073 with DevCtx do 4074 begin 4075 if WithChildWindows then 4076 begin 4077 gdk_gc_get_values(gc1, @OldGC1Values); 4078 gdk_gc_get_values(gc2, @OldGC2Values); 4079 gdk_gc_set_subwindow(gc1, GDK_INCLUDE_INFERIORS); 4080 gdk_gc_set_subwindow(gc2, GDK_INCLUDE_INFERIORS); 4081 end; 4082 4083 DevCtx.RemovePixbuf; 4084 for i := 1 to AWidth do 4085 begin 4086 gdk_draw_line(Drawable, gc1, ARect.Left + Offset.x, ARect.Top + Offset.y, 4087 ARect.Right + Offset.x - 2, ARect.Top + Offset.y); 4088 gdk_draw_line(Drawable, gc1, ARect.Left + Offset.x, ARect.Top + Offset.y, 4089 ARect.Left + Offset.x, ARect.Bottom + Offset.y - 2); 4090 gdk_draw_line(Drawable, gc2, ARect.Left + Offset.x, ARect.Bottom + Offset.y - 1, 4091 ARect.Right + Offset.x - 1, ARect.Bottom + Offset.y - 1); 4092 gdk_draw_line(Drawable, gc2, ARect.Right + Offset.x - 1, ARect.Top + Offset.y, 4093 ARect.Right + Offset.x - 1, ARect.Bottom + Offset.y - 1); 4094 // inflate the rectangle (! ARect will be returned to the user with this) 4095 InflateRect(ARect, -1, -1); 4096 end; 4097 4098 if WithChildWindows then 4099 begin 4100 gdk_gc_set_subwindow(gc1, OldGC1Values.subwindow_mode); 4101 gdk_gc_set_subwindow(gc2, OldGC2Values.subwindow_mode); 4102 end; 4103 4104 end; 4105end; 4106 4107{------------------------------------------------------------------------------ 4108 function TGtk2WidgetSet.FrameRect(DC: HDC; const ARect: TRect; 4109 hBr: HBRUSH): Integer; 4110 ------------------------------------------------------------------------------} 4111function TGtk2WidgetSet.FrameRect(DC: HDC; const ARect: TRect; 4112 hBr: HBRUSH): Integer; 4113var 4114 DevCtx: TGtkDeviceContext absolute DC; 4115 DCOrigin: TPoint; 4116 R: TRect; 4117 OldBrush: HBrush; 4118begin 4119 Result:=0; 4120 if not IsValidDC(DC) then Exit; 4121 if not IsValidGDIObject(hBr) then Exit; 4122 4123 // Draw outline 4124 Result := 1; 4125 if {%H-}PGdiObject(hBr)^.IsNullBrush then Exit; 4126 4127 OldBrush := SelectObject(DC, hBr); 4128 DevCtx.SelectedColors := dcscCustom; 4129 EnsureGCColor(DC, dccGDIBrushColor, True, False);//Brush Color 4130 4131 R := ARect; 4132 LPtoDP(DC, R, 2); 4133 4134 DCOrigin := DevCtx.Offset; 4135 DevCtx.RemovePixbuf; 4136 gdk_draw_rectangle(DevCtx.Drawable, DevCtx.GC, 0, 4137 R.Left + DCOrigin.X, R.Top + DCOrigin.Y, 4138 R.Right-R.Left-1, R.Bottom-R.Top-1); 4139 SelectObject(DC, OldBrush); 4140end; 4141 4142{------------------------------------------------------------------------------ 4143 Function: GetActiveWindow 4144 Params: none 4145 Returns: 4146 4147 ------------------------------------------------------------------------------} 4148function TGtk2WidgetSet.GetActiveWindow : HWND; 4149var 4150 TopList, List: PGList; 4151 Widget: PGTKWidget; 4152 Window: PGTKWindow; 4153begin 4154 // Default to 0 4155 Result := 0; 4156 4157 TopList := gdk_window_get_toplevels; 4158 List := TopList; 4159 while List <> nil do 4160 begin 4161 if (List^.Data <> nil) then 4162 begin 4163 gdk_window_get_user_data(PGDKWindow(List^.Data), Pgpointer(@Window)); 4164 if GDK_IS_WINDOW(PGDKWindow(List^.Data)) and 4165 gdk_window_is_visible(PGDKWindow(List^.Data)) and 4166 gtk_is_window(Window) then 4167 begin 4168 Widget := Window^.focus_widget; 4169 if Widget=nil then Widget:=PGtkWidget(Window); 4170 //DebugLn('TGtk2WidgetSet.GetActiveWindow Window=',GetWidgetDebugReport(PgtkWidget(Window)),' Window^.focus_widget= ',GetWidgetDebugReport(Window^.focus_widget)); 4171 4172 if (Widget <> nil) and gtk_widget_has_focus(Widget) then 4173 begin 4174 // return the window 4175 Result := HWND({%H-}PtrUInt(GetMainWidget(PGtkWidget(Window)))); 4176 //DebugLn('TGtk2WidgetSet.GetActiveWindow Result=',GetWidgetDebugReport(PgtkWidget(Result))); 4177 Break; 4178 end; 4179 end; 4180 end; 4181 list := g_list_next(list); 4182 end; 4183 if TopList <> nil 4184 then g_list_free(TopList); 4185end; 4186 4187function TGtk2WidgetSet.GetForegroundWindow: HWND; 4188begin 4189 Result:=0; 4190 {$IFDEF HASX} 4191 Result:=X11GetActiveWindow; 4192 {$ENDIF} 4193end; 4194 4195{------------------------------------------------------------------------------ 4196 Function: GetDIBits 4197 Params: 4198 Returns: 4199 4200 ------------------------------------------------------------------------------} 4201function TGtk2WidgetSet.GetDIBits(DC: HDC; Bitmap: HBitmap; StartScan, NumScans: UINT; 4202 Bits: Pointer; var BitInfo: BitmapInfo; Usage: UINT): Integer; 4203begin 4204 Result := 0; 4205 if IsValidGDIObject(Bitmap) 4206 then begin 4207 case {%H-}PGDIObject(Bitmap)^.GDIType of 4208 gdiBitmap: 4209 Result := InternalGetDIBits(DC, Bitmap, StartScan, NumScans, -1, Bits, 4210 BitInfo, Usage, True); 4211 else 4212 DebugLn('WARNING: [TGtk2WidgetSet.GetDIBits] not a Bitmap!'); 4213 end; 4214 end 4215 else 4216 DebugLn('WARNING: [TGtk2WidgetSet.GetDIBits] invalid Bitmap!'); 4217end; 4218 4219{------------------------------------------------------------------------------ 4220 Function: GetBitmapBits 4221 Params: 4222 Returns: 4223 4224 ------------------------------------------------------------------------------} 4225function TGtk2WidgetSet.GetBitmapBits(Bitmap: HBITMAP; Count: Longint; Bits: Pointer): Longint; 4226var 4227 BitInfo : tagBitmapInfo; 4228begin 4229 Result := 0; 4230 if IsValidGDIObject(Bitmap) 4231 then begin 4232 case {%H-}PGDIObject(Bitmap)^.GDIType of 4233 gdiBitmap: 4234 Result := InternalGetDIBits(0, Bitmap, 0, 0, Count, Bits, BitInfo, 0, False); 4235 else 4236 DebugLn('WARNING: [TGtk2WidgetSet.GetBitmapBits] not a Bitmap!'); 4237 end; 4238 end 4239 else 4240 DebugLn('WARNING: [TGtk2WidgetSet.GetBitmapBits] invalid Bitmap!'); 4241end; 4242 4243function TGtk2WidgetSet.GetBkColor(DC: HDC): TColorRef; 4244var 4245 DevCtx: TGtkDeviceContext absolute DC; 4246begin 4247 Result := CLR_INVALID; 4248 if IsValidDC(DC) then 4249 Result := DevCtx.CurrentBackColor.ColorRef; 4250end; 4251 4252{------------------------------------------------------------------------------ 4253 Function: GetCapture 4254 Params: none 4255 Returns: Nothing 4256 4257 4258 ------------------------------------------------------------------------------} 4259function TGtk2WidgetSet.GetCapture: HWND; 4260var 4261 Widget: PGtkWidget; 4262 AWindow: PGtkWindow; 4263 IsModal: gboolean; 4264begin 4265 Widget:=gtk_grab_get_current; 4266 // for the LCL a modal window is not capturing 4267 if Widget<>nil then begin 4268 if GtkWidgetIsA(Widget,GTK_TYPE_WINDOW) then begin 4269 AWindow:=PGtkWindow(Widget); 4270 IsModal:=gtk_window_get_modal(AWindow); 4271 if IsModal then 4272 Widget:=nil; 4273 end; 4274 end; 4275 Result := HWnd({%H-}PtrUInt(Widget)); 4276end; 4277 4278{------------------------------------------------------------------------------ 4279 Function: GetCaretPos 4280 Params: lpPoint: The caretposition 4281 Returns: True if succesful 4282 4283 ------------------------------------------------------------------------------} 4284function TGtk2WidgetSet.GetCaretPos(var lpPoint: TPoint): Boolean; 4285var 4286 //FocusObject: PGTKObject; 4287 modmask : TGDKModifierType; 4288begin 4289 {$IFDEF DebugGDKTraps} 4290 BeginGDKErrorTrap; 4291 {$ENDIF} 4292 gdk_window_get_pointer(nil,@lpPoint.X,@lpPoint.y,@modmask); 4293 {$IFDEF DebugGDKTraps} 4294 EndGDKErrorTrap; 4295 {$ENDIF} 4296 Result := True; 4297end; 4298 4299{------------------------------------------------------------------------------ 4300 function TGtk2WidgetSet.GetCaretRespondToFocus(handle: HWND; 4301 var ShowHideOnFocus: boolean): Boolean; 4302 ------------------------------------------------------------------------------} 4303function TGtk2WidgetSet.GetCaretRespondToFocus(handle: HWND; 4304 var ShowHideOnFocus: boolean): Boolean; 4305begin 4306 if handle<>0 then begin 4307 if gtk_type_is_a({%H-}g_object_type({%H-}PGTKObject(handle)), GTKAPIWidget_GetType) 4308 then begin 4309 GTKAPIWidget_GetCaretRespondToFocus({%H-}PGTKAPIWidget(handle), 4310 ShowHideOnFocus); 4311 Result:=true; 4312 end 4313 else begin 4314 Result := False; 4315 end; 4316 end else 4317 Result:=false; 4318end; 4319 4320{------------------------------------------------------------------------------ 4321 Function: GetCharABCWidths pbd 4322 Params: Don't care yet 4323 Returns: False so that the font cache in the newest mwEdit will use 4324 TextMetrics info which is working already 4325 ------------------------------------------------------------------------------} 4326function TGtk2WidgetSet.GetCharABCWidths(DC: HDC; p2, p3: UINT; 4327 const ABCStructs): Boolean; 4328begin 4329 Result := False; 4330end; 4331 4332{------------------------------------------------------------------------------ 4333 Function: GetClientBounds 4334 Params: handle: 4335 Result: 4336 Returns: true on success 4337 4338 Returns the client bounds of a control. The client bounds is the rectangle of 4339 the inner area of a control, where the child controls are visible. The 4340 coordinates are relative to the control's left and top. 4341 ------------------------------------------------------------------------------} 4342function TGtk2WidgetSet.GetClientBounds(handle : HWND; var ARect : TRect) : Boolean; 4343var 4344 Widget, ClientWidget: PGtkWidget; 4345 CurGDKWindow: PGdkWindow; 4346 ClientOrigin: TPoint; 4347 ClientWindow, MainWindow: PGdkWindow; 4348begin 4349 Result := False; 4350 if Handle = 0 then Exit; 4351 Widget := {%H-}pgtkwidget(Handle); 4352 ClientWidget := GetFixedWidget(Widget); 4353 if (ClientWidget <> Widget) then begin 4354 ClientWindow:=GetControlWindow(ClientWidget); 4355 MainWindow:=GetControlWindow(Widget); 4356 if MainWindow<>ClientWindow then begin 4357 // widget and client are on different gdk windows 4358 if (GTK_WIDGET_NO_WINDOW(ClientWidget)) then begin 4359 // ClientWidget is a sub widget 4360 ARect.Left:=ClientWidget^.allocation.x; 4361 ARect.Top:=ClientWidget^.allocation.y; 4362 end else begin 4363 // ClientWidget owns the gdkwindow 4364 ARect.Left:=0; 4365 ARect.Top:=0; 4366 end; 4367 CurGDKWindow:=ClientWindow; 4368 while (CurGDKWindow<>MainWindow) do 4369 begin 4370 if not GDK_IS_WINDOW(CurGDKWindow) then 4371 break; 4372 gdk_window_get_position(CurGDKWindow,@ClientOrigin.x,@ClientOrigin.y); 4373 inc(ARect.Left,ClientOrigin.x); 4374 inc(ARect.Top,ClientOrigin.y); 4375 CurGDKWindow:=gdk_window_get_parent(CurGDKWindow); 4376 end; 4377 if GTK_WIDGET_NO_WINDOW(Widget) then begin 4378 // Widget is a sub widget 4379 dec(ARect.Left,Widget^.allocation.x); 4380 dec(ARect.Top,Widget^.allocation.y); 4381 end; 4382 ARect.Right:=ARect.Left+ClientWidget^.Allocation.Width; 4383 ARect.Bottom:=ARect.Top+ClientWidget^.Allocation.Height; 4384 4385 Result:=true; 4386 end else if MainWindow<>nil then begin 4387 // both are on the same gdkwindow 4388 ARect.Left:=ClientWidget^.allocation.X-Widget^.allocation.X; 4389 ARect.Top:=ClientWidget^.allocation.Y-Widget^.allocation.Y; 4390 ARect.Right:=ARect.Left+ClientWidget^.allocation.Width; 4391 ARect.Bottom:=ARect.Top+ClientWidget^.allocation.Height; 4392 Result:=true; 4393 end; 4394 end; 4395 if not Result then begin 4396 with Widget^.Allocation do 4397 ARect := Rect(0,0,Width,Height); 4398 end; 4399 Result:=true; 4400end; 4401 4402{------------------------------------------------------------------------------ 4403 Function: GetClientRect 4404 Params: handle: 4405 Result: 4406 Returns: true on success 4407 4408 Returns the client rectangle of a control. Left and Top are always 0. 4409 The client rectangle is the size of the inner area of a control, where the 4410 child controls are visible. 4411 ------------------------------------------------------------------------------} 4412function TGtk2WidgetSet.GetClientRect(handle : HWND; var ARect : TRect) : Boolean; 4413begin 4414 Result := false; 4415 if Handle = 0 then Exit; 4416 ARect := GetWidgetClientRect({%H-}PGtkWidget(Handle)); 4417 Result := True; 4418end; 4419 4420{------------------------------------------------------------------------------ 4421 Function: GetClipBox 4422 Params: dc, lprect 4423 Returns: Integer 4424 4425 Returns the smallest rectangle which includes the entire current 4426 Clipping Region, or if no Clipping Region is set, the current 4427 dimensions of the Drawable. 4428 4429 The result can be one of the following constants 4430 Error 4431 NullRegion 4432 SimpleRegion 4433 ComplexRegion 4434 ------------------------------------------------------------------------------} 4435function TGtk2WidgetSet.GetClipBox(DC : hDC; lpRect : PRect) : Longint; 4436var 4437 DevCtx: TGtkDeviceContext absolute DC; 4438 4439 CRect : TGDKRectangle; 4440 X, Y : Longint; 4441 DCOrigin: Tpoint; 4442begin 4443 // set default values 4444 Result := SIMPLEREGION; 4445 if lpRect <> nil then 4446 lpRect^ := Rect(0,0,0,0); 4447 4448 if not IsValidDC(DC) 4449 then begin 4450 Result := ERROR; 4451 Exit; 4452 end; 4453 4454 DCOrigin := DevCtx.Offset; 4455 if DevCtx.ClipRegion = nil then 4456 begin 4457 if (DevCtx.PaintRectangle.Left<>0) 4458 or (DevCtx.PaintRectangle.Top<>0) 4459 or (DevCtx.PaintRectangle.Right<>0) 4460 or (DevCtx.PaintRectangle.Bottom<>0) then 4461 lpRect^ := DevCtx.PaintRectangle 4462 else 4463 begin 4464 gdk_window_get_size(DevCtx.Drawable, @X, @Y); 4465 lpRect^ := Rect(0,0,X,Y); 4466 end; 4467 Result := SIMPLEREGION; 4468 end 4469 else 4470 begin 4471 Result := RegionType(DevCtx.ClipRegion^.GDIRegionObject); 4472 gdk_region_get_clipbox(DevCtx.ClipRegion^.GDIRegionObject, @CRect); 4473 lpRect^.Left := CRect.X; 4474 lpRect^.Top := CRect.Y; 4475 lpRect^.Right := lpRect^.Left + CRect.Width; 4476 lpRect^.Bottom := lpRect^.Top + CRect.Height; 4477 end; 4478 DPtoLP(DC, lpRect^, 2); 4479 OffsetRect(lpRect^, -DCOrigin.X, -DCOrigin.Y); 4480end; 4481 4482{------------------------------------------------------------------------------ 4483 Function: GetRGNBox 4484 Params: rgn, lprect 4485 Returns: Integer 4486 4487 Returns the smallest rectangle which includes the entire passed 4488 Region, if lprect is null then just returns RegionType. 4489 4490 The result can be one of the following constants 4491 Error 4492 NullRegion 4493 SimpleRegion 4494 ComplexRegion 4495 4496 4497 ------------------------------------------------------------------------------} 4498function TGtk2WidgetSet.GetRgnBox(RGN : HRGN; lpRect : PRect) : Longint; 4499var 4500 ClipR : TGDKRectangle; 4501begin 4502 Result := SIMPLEREGION; 4503 If lpRect <> nil then 4504 lpRect^ := Rect(0,0,0,0); 4505 If Not IsValidGDIObject(RGN) then 4506 Result := ERROR 4507 else begin 4508 Result := RegionType({%H-}PGDIObject(RGN)^.GDIRegionObject); 4509 If lpRect <> nil then begin 4510 gdk_region_get_clipbox({%H-}PGDIObject(RGN)^.GDIRegionObject, 4511 @ClipR); 4512 With lpRect^ do begin 4513 Left := ClipR.X; 4514 Top := ClipR.Y; 4515 Right := ClipR.X + ClipR.Width; 4516 Bottom := ClipR.Y + ClipR.Height; 4517 end; 4518 end; 4519 end; 4520end; 4521 4522function TGtk2WidgetSet.GetROP2(DC: HDC): Integer; 4523begin 4524 if IsValidDC(DC) 4525 then Result := TGtkDeviceContext(DC).ROP2 4526 else Result := 0; 4527end; 4528 4529{------------------------------------------------------------------------------ 4530 Function: GetClipRGN 4531 Params: dc, rgn 4532 Returns: Integer 4533 4534 Returns a copy of the current Clipping Region. 4535 4536 The result can be one of the following constants 4537 0 = no clipping set 4538 1 = ok 4539 -1 = error 4540 ------------------------------------------------------------------------------} 4541function TGtk2WidgetSet.GetClipRGN(DC: hDC; RGN: hRGN): Longint; 4542var 4543 DCOrigin: TPoint; 4544 ClipRegionWithDCOffset: PGdkRegion; 4545 CurRegionObject: PGdkRegion; 4546 ARect: TRect; 4547begin 4548 Result := SIMPLEREGION; 4549 If (not IsValidDC(DC)) then 4550 Result := ERROR 4551 else 4552 if Not IsValidGDIObject(RGN) then 4553 begin 4554 Result := ERROR; 4555 DebugLn('WARNING: [TGtk2WidgetSet.GetClipRGN] Invalid HRGN'); 4556 end 4557 else 4558 if Assigned(TGtkDeviceContext(DC).ClipRegion) and 4559 not IsValidGDIObject(HGDIOBJ({%H-}PtrUInt(TGtkDeviceContext(DC).ClipRegion))) then 4560 Result := ERROR 4561 else with TGtkDeviceContext(DC) do 4562 begin 4563 CurRegionObject := nil; 4564 if Assigned(ClipRegion) then 4565 CurRegionObject := ClipRegion^.GDIRegionObject; 4566 ARect := Rect(0, 0, 0, 0); 4567 //debugln(['TGtk2WidgetSet.GetClipRGN ',GetWidgetDebugReport(Widget),' CurRegionObject=',Assigned(CurRegionObject),' DC=',dbgs(DC)]); 4568 4569 if Assigned(CurRegionObject) then begin 4570 // create a copy of the current clipregion 4571 ClipRegionWithDCOffset := gdk_region_copy(CurRegionObject); 4572 // move it to the DC offset 4573 // Example: if the ClipRegion is at 10,10 and the DCOrigin is at 10,10, 4574 // then the ClipRegion must be moved to 0,0 4575 DCOrigin := Offset; 4576 gdk_region_offset(ClipRegionWithDCOffset, -DCOrigin.x, -DCOrigin.Y); 4577 end 4578 else 4579 begin 4580 // create a default clipregion 4581 GetClipBox(DC, @ARect); 4582 LPtoDP(DC, ARect, 2); 4583 ClipRegionWithDCOffset := CreateRectGDKRegion(ARect); 4584 end; 4585 4586 // free the old region in RGN 4587 if Assigned({%H-}PGdiObject(RGN)^.GDIRegionObject) then 4588 gdk_region_destroy({%H-}PGdiObject(RGN)^.GDIRegionObject); 4589 // set the new region in RGN 4590 {%H-}PGdiObject(RGN)^.GDIRegionObject := ClipRegionWithDCOffset; 4591 4592 Result := RegionType(ClipRegionWithDCOffset); 4593 //DebugLn('TGtk2WidgetSet.GetClipRGN B DC=',DbgS(DC), 4594 // ' DCOrigin=',dbgs(DCOrigin),' RGN=',GDKRegionAsString(ClipRegionWithDCOffset),' Result=',dbgs(Result)); 4595 If Result = NULLREGION then 4596 Result := 0 4597 else If Result <> ERROR then 4598 Result := 1; 4599 end; 4600 If Result = ERROR then 4601 Result := -1; 4602end; 4603 4604{------------------------------------------------------------------------------ 4605 Function: GetCmdLineParamDescForInterface 4606 Params: none 4607 Returns: ansistring 4608 4609 Returns a description of the command line parameters, that are understood by 4610 the interface. 4611 ------------------------------------------------------------------------------} 4612function TGtk2WidgetSet.GetCmdLineParamDescForInterface: string; 4613 function b(const s: string): string; 4614 begin 4615 Result:=BreakString(s,75,22)+LineEnding+LineEnding; 4616 end; 4617 4618begin 4619 Result:= 4620 b(rsgtkOptionNoTransient) 4621 +b(rsgtkOptionModule) 4622 +b(rsgOptionFatalWarnings) 4623 +b(rsgtkOptionDebug) 4624 +b(rsgtkOptionNoDebug) 4625 +b(rsgdkOptionDebug) 4626 +b(rsgdkOptionNoDebug) 4627 +b(rsgtkOptionDisplay) 4628 +b(rsgtkOptionSync) 4629 +b(rsgtkOptionNoXshm) 4630 +b(rsgtkOptionName) 4631 +b(rsgtkOptionClass) 4632 +b(rsqtOptionDisableAccurateFrame); 4633end; 4634 4635{------------------------------------------------------------------------------ 4636 Method: GetCurrentObject 4637 Params: 4638 DC - A handle to the DC 4639 uObjectType - The object type to be queried 4640 Returns: If the function succeeds, the return value is a handle to the specified object. 4641 If the function fails, the return value is NULL. 4642 ------------------------------------------------------------------------------} 4643 4644function TGtk2WidgetSet.GetCurrentObject(DC: HDC; uObjectType: UINT): HGDIOBJ; 4645var 4646 Gtk2DC: TGtkDeviceContext absolute DC; 4647begin 4648 Result := 0; 4649 if not GTK2WidgetSet.IsValidDC(DC) then 4650 Exit; 4651 case uObjectType of 4652 OBJ_BITMAP: Result := {%H-}HGDIOBJ(Gtk2DC.CurrentBitmap); 4653 OBJ_BRUSH: Result := {%H-}HGDIOBJ(Gtk2DC.CurrentBrush); 4654 OBJ_FONT: Result := {%H-}HGDIOBJ(Gtk2DC.CurrentFont); 4655 OBJ_PEN: Result := {%H-}HGDIOBJ(Gtk2DC.CurrentPen); 4656 end; 4657end; 4658 4659{------------------------------------------------------------------------------ 4660 Function: GetCursorPos 4661 Params: lpPoint: The cursorposition 4662 Returns: True if succesful 4663 4664 ------------------------------------------------------------------------------} 4665function TGtk2WidgetSet.GetCursorPos(var lpPoint: TPoint ): Boolean; 4666begin 4667 gdk_display_get_pointer(gdk_display_get_default(), nil, @lpPoint.X, @lpPoint.Y, nil); 4668 Result := True; 4669end; 4670 4671{------------------------------------------------------------------------------ 4672 Function: GetDC 4673 Params: none 4674 Returns: Nothing 4675 4676 hWnd is any widget. 4677 The DC will be created for the client area and without the child areas 4678 (they are clipped away). Child areas are all child gdkwindows 4679 (e.g. not TControls). 4680 ------------------------------------------------------------------------------} 4681function TGtk2WidgetSet.GetDC(hWnd: HWND): HDC; 4682begin 4683 Result:=CreateDCForWidget({%H-}PGtkWidget(hWnd),nil,false); 4684end; 4685 4686{------------------------------------------------------------------------------ 4687 function TGtk2WidgetSet.GetDeviceCaps(DC: HDC; Index: Integer): Integer; 4688 4689 4690 ------------------------------------------------------------------------------} 4691function TGtk2WidgetSet.GetDeviceCaps(DC: HDC; Index: Integer): Integer; 4692var 4693 Visual: PGdkVisual; 4694 4695 function GetVisual: boolean; 4696 begin 4697 Visual:=nil; 4698 with TGtkDeviceContext(DC) do begin 4699 If Drawable <> nil then 4700 Visual:=gdk_window_get_visual(PGdkWindow(Drawable)); 4701 if Visual = nil then 4702 Visual := GDK_Visual_Get_System; 4703 end; 4704 Result:=Visual<>nil; 4705 end; 4706 4707begin 4708 Result := -1; 4709 If DC = 0 then begin 4710 DC := GetDC(0); 4711 If DC = 0 then 4712 exit; 4713 Result := GetDeviceCaps(DC, Index); 4714 ReleaseDC(0, DC); 4715 exit; 4716 end; 4717 if not IsValidDC(DC) then exit; 4718 with TGtkDeviceContext(DC) do 4719 Case Index of 4720 HORZRES : { Horizontal width in pixels } 4721 If Drawable = nil then 4722 Result := GetSystemMetrics(SM_CXSCREEN) 4723 else 4724 gdk_drawable_get_size(Drawable, @Result, nil); 4725 4726 VERTRES : { Vertical height in pixels } 4727 If Drawable = nil then 4728 Result := GetSystemMetrics(SM_CYSCREEN) 4729 else 4730 gdk_drawable_get_size(Drawable, nil, @Result); 4731 4732 BITSPIXEL : { Number of used bits per pixel = depth } 4733 If Drawable = nil then 4734 Result := GDK_Visual_Get_System^.Depth 4735 else 4736 Result := gdk_drawable_get_depth(Drawable); 4737 4738 PLANES : { Number of planes } 4739 // ToDo 4740 Result := 1; 4741 4742 //For Size in MM, MM = (Pixels*100)/(PPI*25.4) 4743 4744 HORZSIZE : { Horizontal size in millimeters } 4745 Result := RoundToInt((GetDeviceCaps(DC, HORZRES) * 100) / 4746 (GetDeviceCaps(DC, LOGPIXELSX) * 25.4)); 4747 4748 VERTSIZE : { Vertical size in millimeters } 4749 Result := RoundToInt((GetDeviceCaps(DC, VERTRES) * 100) / 4750 (GetDeviceCaps(DC, LOGPIXELSY) * 25.4)); 4751 4752 //So long as gdk_screen_width_mm is acurate, these should be 4753 //acurate for Screen GDKDrawables. Once we get Metafiles 4754 //we will also have to add internal support for Papersizes etc.. 4755 4756 LOGPIXELSX : { Logical pixels per inch in X } 4757 Result := ScreenInfo.PixelsPerInchX; 4758 4759 LOGPIXELSY : { Logical pixels per inch in Y } 4760 Result := ScreenInfo.PixelsPerInchY; 4761 4762 SIZEPALETTE: { number of entries in color palette } 4763 if GetVisual then 4764 Result:=Visual^.colormap_size 4765 else 4766 Result:=0; 4767 4768 NUMRESERVED: { number of reserverd colors in color palette } 4769 Result:=0; 4770 4771 else 4772 DebugLn('TGtk2WidgetSet.GetDeviceCaps not supported: Type=',dbgs(Index)); 4773 end; 4774end; 4775 4776{------------------------------------------------------------------------------ 4777 function GetDeviceSize(DC: HDC; var p: TPoint): boolean; 4778 4779 Retrieves the width and height of the device context in pixels. 4780 ------------------------------------------------------------------------------} 4781function TGtk2WidgetSet.GetDeviceSize(DC: HDC; var p: TPoint): boolean; 4782var 4783 DevCtx: TGtkDeviceContext absolute DC; 4784begin 4785 if not IsValidDC(DC) then Exit(False); 4786 4787 if DevCtx.Drawable <> nil 4788 then begin 4789 P := Point(0,0); 4790 gdk_window_get_size(PGdkWindow(DevCtx.Drawable), @P.X, @P.Y); 4791 Exit(True); 4792 end; 4793 4794 {$IFDEF RaiseExceptionOnNilPointers} 4795 RaiseGDBException('TGtk2WidgetSet.GetDeviceSize Window=nil'); 4796 {$ENDIF} 4797 DebugLn('TGtk2WidgetSet.GetDeviceSize:', ' WARNING: DC ',DbgS(DC),' without gdkwindow.', 4798 ' Widget=',DbgS(DevCtx.Widget)); 4799 Result := False; 4800end; 4801 4802{------------------------------------------------------------------------------ 4803 function TGtk2WidgetSet.GetDCOriginRelativeToWindow(PaintDC: HDC; 4804 WindowHandle: HWND; var OriginDiff: TPoint): boolean; 4805 4806 Returns the origin of PaintDC relative to the window handle. 4807 Example: 4808 A PaintDC of a TButton at 20,10 with a DC Offset of 0,0 on a form and the 4809 WindowHandle is the form. 4810 Then OriginDiff is the difference between the Forms client origin 4811 and the PaintDC: 20,10. 4812 ------------------------------------------------------------------------------} 4813function TGtk2WidgetSet.GetDCOriginRelativeToWindow(PaintDC: HDC; 4814 WindowHandle: HWND; var OriginDiff: TPoint): boolean; 4815 4816var 4817 DevCtx: TGtkDeviceContext absolute PaintDC; 4818 4819 DCOrigin: TPoint; 4820 DCScreenOrigin: TPoint; 4821 WindowScreenOrigin: TPoint; 4822 Widget: PGtkWidget; 4823 DCWindow: PGdkWindow; 4824begin 4825 Result := false; 4826 OriginDiff := Point(0, 0); 4827 if not IsValidDC(PaintDC) then exit; 4828 4829 DCOrigin := DevCtx.Offset; 4830 4831 DCWindow := PGdkWindow(DevCtx.Drawable); 4832 gdk_window_get_origin(DCWindow, @(DCScreenOrigin.X), @(DCScreenOrigin.Y)); 4833 inc(DCScreenOrigin.X, DCOrigin.X); 4834 inc(DCScreenOrigin.Y, DCOrigin.Y); 4835 4836 Widget := GetFixedWidget({%H-}PGtkWidget(WindowHandle)); 4837 if Widget = nil then 4838 Widget := {%H-}PGtkWidget(WindowHandle); 4839 4840 gdk_window_get_origin(PGdkWindow(Widget^.window), @(WindowScreenOrigin.X), @(WindowScreenOrigin.Y)); 4841 4842 OriginDiff.X := DCScreenOrigin.X - WindowScreenOrigin.X; 4843 OriginDiff.Y := DCScreenOrigin.Y - WindowScreenOrigin.Y; 4844 Result := True; 4845 //DebugLn(['TGtk2WidgetSet.GetDCOriginRelativeToWindow DCScreenOrigin=',dbgs(DCScreenOrigin),' WindowScreenOrigin=',dbgs(WindowScreenOrigin),' OriginDiff=',dbgs(OriginDiff)]); 4846end; 4847 4848{------------------------------------------------------------------------------ 4849 Function: GetDesignerDC 4850 Params: none 4851 Returns: Nothing 4852 4853 WindowHandle is any widget. 4854 The DC will be created for the client area including the child areas. 4855 ------------------------------------------------------------------------------} 4856function TGtk2WidgetSet.GetDesignerDC(WindowHandle: HWND): HDC; 4857begin 4858 //DebugLn('TGtk2WidgetSet.GetDesignerDC A'); 4859 Result:=CreateDCForWidget({%H-}PGtkWidget(WindowHandle),nil,true); 4860end; 4861 4862{------------------------------------------------------------------------------ 4863 Function: GetFocus 4864 Params: none 4865 Returns: The handle of the window with focus 4866 4867 The GetFocus function retrieves the handle of the window that has the focus. 4868 ------------------------------------------------------------------------------} 4869function TGtk2WidgetSet.GetFocus: HWND; 4870var 4871 TopList, List: PGList; 4872 Widget: PGTKWidget; 4873 Window: PGTKWindow; 4874 Info: PWidgetInfo; 4875begin 4876 // Default to 0 4877 Result := 0; 4878 4879 {$IFDEF DebugGDKTraps} 4880 BeginGDKErrorTrap; 4881 {$ENDIF} 4882 4883 TopList := gdk_window_get_toplevels; 4884 List := TopList; 4885 while List <> nil do 4886 begin 4887 if (List^.Data <> nil) 4888 then begin 4889 gdk_window_get_user_data(PGDKWindow(List^.Data), Pgpointer(@Window)); 4890 4891 if gtk_is_window(Window) 4892 then begin 4893 Widget := Window^.focus_widget; 4894 {$IFDEF DebugLCLComponents} 4895 if DebugGtkWidgets.IsDestroyed(Widget) then begin 4896 DebugLn(['TGtk2WidgetSet.GetFocus Window^.focus_widget was already destroyed:']); 4897 DebugLn(DebugGtkWidgets.GetInfo(Widget,true)); 4898 end; 4899 {$ENDIF} 4900 4901 if (Widget <> nil) and gtk_widget_has_focus(Widget) 4902 then begin 4903 Info:=GetWidgetInfo(PGtkWidget(Window)); 4904 if (Info=nil) or (not (wwiDeactivating in Info^.Flags)) then 4905 Result := HWND({%H-}PtrUInt(GetMainWidget(Widget))); 4906 Break; 4907 end; 4908 end; 4909 end; 4910 list := g_list_next(list); 4911 end; 4912 4913 if TopList <> nil 4914 then g_list_free(TopList); 4915 {$IFDEF VerboseFocus} 4916 DebugLn('TGtk2WidgetSet.GetFocus: Result=',dbgHex(Result)); 4917 {$ENDIF} 4918 4919 {$IFDEF DebugGDKTraps}EndGDKErrorTrap;{$ENDIF} 4920end; 4921 4922{------------------------------------------------------------------------------ 4923 function GetFontLanguageInfo(DC: HDC): DWord; override; 4924 ------------------------------------------------------------------------------} 4925function TGtk2WidgetSet.GetFontLanguageInfo(DC: HDC): DWord; 4926begin 4927 Result := 0; 4928 If IsValidDC(DC) then 4929 with TGtkDeviceContext(DC) do begin 4930 UpdateDCTextMetric(TGtkDeviceContext(DC)); 4931 if TGtkDeviceContext(DC).DCTextMetric.IsDoubleByteChar then 4932 inc(Result,GCP_DBCS); 4933 end; 4934end; 4935 4936{------------------------------------------------------------------------------ 4937 Function: GetKeyState 4938 Params: nVirtKey: The requested key 4939 Returns: If the function succeeds, the return value specifies the status of 4940 the given virtual key. If the high-order bit is 1, the key is down; 4941 otherwise, it is up. If the low-order bit is 1, the key is toggled. 4942 4943 The GetKeyState function retrieves the status of the specified virtual key. 4944 ------------------------------------------------------------------------------} 4945function TGtk2WidgetSet.GetKeyState(nVirtKey: Integer): Smallint; 4946const 4947 StateDown = -128; // $FF80 4948 StateToggled = 1; 4949 KEYSTATE: array[Boolean] of Smallint = (0, StateDown); 4950 TOGGLESTATE: array[Boolean] of Smallint = (0, StateToggled); 4951 GDK_BUTTON_MASKS: array[VK_LBUTTON..VK_XBUTTON2] of guint32 = 4952 ( 4953{ VK_LBUTTON } GDK_BUTTON1_MASK, 4954{ VK_RBUTTON } GDK_BUTTON3_MASK, 4955{ VK_CANCEL } 0, 4956{ VK_MBUTTON } GDK_BUTTON2_MASK, 4957{ VK_XBUTTON1 } GDK_BUTTON4_MASK, 4958{ VK_XBUTTON2 } GDK_BUTTON5_MASK 4959 ); 4960var 4961 GdkModMask: TGdkModifierType; 4962 x, y: gint; 4963begin 4964 case nVirtKey of 4965 // remap 4966 VK_LSHIFT: nVirtKey := VK_SHIFT; 4967 VK_LCONTROL: nVirtKey := VK_CONTROL; 4968 VK_LMENU: nVirtKey := VK_MENU; 4969 end; 4970 4971 {$IFDEF Use_KeyStateList} 4972 Result := KEYSTATE[FKeyStateList_.IndexOf({%H-}Pointer(PtrUInt(nVirtKey))) >=0]; 4973 {$ELSE} 4974 Implement this 4975 {$ENDIF} 4976 4977 // try extended keys 4978 if Result = 0 4979 then begin 4980 {$IFDEF Use_KeyStateList} 4981 Result := KEYSTATE[FKeyStateList_.IndexOf({%H-}Pointer(PtrUInt(nVirtKey or KEYMAP_EXTENDED))) >=0]; 4982 {$ELSE} 4983 Implement this 4984 {$ENDIF} 4985 end; 4986 4987 {$IFDEF Use_KeyStateList} 4988 // add toggle 4989 Result := Result or TOGGLESTATE[FKeyStateList_.IndexOf({%H-}Pointer( 4990 PtrUInt(nVirtKey or KEYMAP_TOGGLE))) >=0]; 4991 // If there are tons of new keyboard errors this is probably the cause 4992 GdkModMask := gtk_accelerator_get_default_mod_mask; 4993 if (Result and StateDown) <> 0 then 4994 begin 4995 if (nVirtKey = VK_CONTROL) and (GdkModMask and GDK_CONTROL_MASK = 0) then 4996 Result := Result and not StateDown; 4997 //if (nVirtKey = VK_SHIFT) and (GtkModMask and GDK_SHIFT_MASK = 0 then 4998 // Result := Result and not StateDown; 4999 end; 5000 {$ENDIF} 5001 5002 // Mouse buttons. Toggle state is not tracked 5003 if nVirtKey in [VK_LBUTTON, VK_RBUTTON, VK_MBUTTON..VK_XBUTTON2] then 5004 begin 5005 gdk_display_get_pointer(gdk_display_get_default, nil, 5006 @x, @y, @GdkModMask); 5007 Result := Result or KEYSTATE[GdkModMask and GDK_BUTTON_MASKS[nVirtKey] <> 0] 5008 end; 5009end; 5010 5011function TGtk2WidgetSet.GetMapMode(DC: HDC): Integer; 5012var 5013 DevCtx: TGtkDeviceContext absolute DC; 5014begin 5015 if IsValidDC(DC) then 5016 Result := DevCtx.MapMode 5017 else 5018 Result := 0; 5019end; 5020 5021function TGtk2WidgetSet.GetMonitorInfo(Monitor: HMONITOR; lpmi: PMonitorInfo): Boolean; 5022var 5023 MonitorRect: TGdkRectangle; 5024 {$IFDEF HasX} 5025 x, y, w, h: gint; 5026 {$ENDIF} 5027begin 5028 Result := (lpmi <> nil) and (lpmi^.cbSize >= SizeOf(TMonitorInfo)) or (Monitor = 0); 5029 if not Result then Exit; 5030 Dec(Monitor); 5031 gdk_screen_get_monitor_geometry(gdk_screen_get_default, Monitor, @MonitorRect); 5032 with MonitorRect do 5033 lpmi^.rcMonitor := Bounds(x, y, width, height); 5034 // there is no way to determine workarea in gtk 5035 {$IFDEF HasX} 5036 if XGetWorkarea(x, y, w, h) <> -1 then 5037 lpmi^.rcWork := Bounds(Max(MonitorRect.x, x), Max(MonitorRect.y, y), 5038 Min(MonitorRect.Width, w), Min(MonitorRect.Height, h)) 5039 else 5040 {$ENDIF} 5041 lpmi^.rcWork := lpmi^.rcMonitor; 5042 // since gtk-2.20 we have correct api to get primary monitor. issue #32464 5043 if Assigned(gdk_screen_get_primary_monitor) then 5044 begin 5045 if (Monitor = gdk_screen_get_primary_monitor(gdk_screen_get_default)) then 5046 lpmi^.dwFlags := MONITORINFOF_PRIMARY 5047 else 5048 lpmi^.dwFlags := 0; 5049 end else 5050 begin 5051 // gtk2 below 2.20 5052 if Monitor = 0 then 5053 lpmi^.dwFlags := MONITORINFOF_PRIMARY 5054 else 5055 lpmi^.dwFlags := 0; 5056 end; 5057end; 5058 5059{------------------------------------------------------------------------------ 5060 Function: GetObject 5061 Params: GDIObj - handle, BufSize - size of Buf argument, Buf - buffer 5062 Returns: Size of buffer 5063 ------------------------------------------------------------------------------} 5064function TGtk2WidgetSet.GetObject(GDIObj: HGDIOBJ; BufSize: Integer; Buf: Pointer): Integer; 5065 function GetObject_Bitmap: Integer; 5066 var 5067 NumColors, ImageDepth: Longint; 5068 BitmapSection : TDIBSECTION; 5069 begin 5070 if Buf = nil 5071 then begin 5072 Result := SizeOf(TDIBSECTION); 5073 Exit; 5074 end; 5075 5076 Result := 0; 5077 5078 FillChar(BitmapSection{%H-}, SizeOf(TDIBSECTION), 0); 5079 with {%H-}PGDIObject(GDIObj)^, BitmapSection, 5080 BitmapSection.dsBm, BitmapSection.dsBmih 5081 do begin 5082 {dsBM - BITMAP} 5083 bmType := LeToN($4D42); 5084 bmWidth := 0 ; 5085 bmHeight := 0; 5086 {bmWidthBytes: Longint;} 5087 bmPlanes := 1;//Does Bitmap Format support more? 5088 bmBitsPixel := 1; 5089 bmBits := nil; 5090 5091 {dsBmih - BITMAPINFOHEADER} 5092 biSize := 40; 5093 biWidth := 0; 5094 biHeight := 0; 5095 biPlanes := bmPlanes; 5096 biBitCount := 1; 5097 5098 biCompression := 0; 5099 biSizeImage := 0; 5100 5101 biXPelsPerMeter := 0; 5102 biYPelsPerMeter := 0; 5103 5104 biClrUsed := 0; 5105 biClrImportant := 0; 5106 5107 {dsBitfields: array[0..2] of DWORD; 5108 dshSection: THandle; 5109 dsOffset: DWORD;} 5110 5111 {$ifdef DebugGDKTraps}BeginGDKErrorTrap;{$endif} 5112 case GDIBitmapType of 5113 gbBitmap: 5114 if GDIBitmapObject <> nil 5115 then begin 5116 gdk_window_get_size(GDIBitmapObject, @biWidth, @biHeight); 5117 NumColors := 2; 5118 biBitCount := 1; 5119 end; 5120 gbPixmap: 5121 if GDIPixmapObject.Image <> nil 5122 then begin 5123 gdk_drawable_get_size(GDIPixmapObject.Image, @biWidth, @biHeight); 5124 ImageDepth := gdk_drawable_get_depth(GDIPixmapObject.Image); 5125 biBitCount := ImageDepth; 5126 end; 5127 gbPixbuf: 5128 if GDIPixbufObject <> nil 5129 then begin 5130 biWidth := gdk_pixbuf_get_width(GDIPixbufObject); 5131 biHeight := gdk_pixbuf_get_height(GDIPixbufObject); 5132 biBitCount := gdk_pixbuf_get_bits_per_sample(GDIPixbufObject) * gdk_pixbuf_get_n_channels(GDIPixbufObject); 5133 end; 5134 end; 5135 5136 if Visual = nil 5137 then begin 5138 Visual := gdk_visual_get_best_with_depth(biBitCount); 5139 if Visual = nil 5140 then { Depth not supported } 5141 Visual := gdk_visual_get_system; 5142 SystemVisual := True; { This visual should not be referenced } 5143 5144 if Colormap <> nil then 5145 gdk_colormap_unref(Colormap); 5146 ColorMap := gdk_colormap_new(Visual, GdkTrue); 5147 end 5148 else 5149 biBitCount := Visual^.Depth; 5150 5151 {$ifdef DebugGDKTraps}EndGDKErrorTrap;{$enDIF} 5152 5153 if biBitCount < 16 then 5154 NumColors := Colormap^.Size; 5155 5156 biSizeImage := (((biBitCount*biWidth+31) shr 5) shl 2)*biHeight; 5157 5158 if GetSystemMetrics(SM_CXSCREEN) >= biWidth then 5159 biXPelsPerMeter := GetDeviceCaps(0, LOGPIXELSX) 5160 else 5161 biXPelsPerMeter := 5162 RoundToInt((single(biWidth) / GetSystemMetrics(SM_CXSCREEN)) * 5163 GetDeviceCaps(0, LOGPIXELSX)); 5164 5165 if GetSystemMetrics(SM_CYSCREEN) >= biHeight then 5166 biYPelsPerMeter := GetDeviceCaps(0, LOGPIXELSY) 5167 else 5168 biYPelsPerMeter := 5169 RoundToInt((Single(biHeight) / GetSystemMetrics(SM_CYSCREEN))* 5170 GetDeviceCaps(0, LOGPIXELSY)); 5171 5172 bmWidth := biWidth; 5173 bmHeight := biHeight; 5174 bmBitsPixel := biBitCount; 5175 5176 //Need to retrieve actual Number of Colors if Indexed Image 5177 if bmBitsPixel < 16 5178 then begin 5179 biClrUsed := NumColors; 5180 biClrImportant := biClrUsed; 5181 end; 5182 end; 5183 5184 if BufSize >= SizeOf(BitmapSection) 5185 then begin 5186 PDIBSECTION(Buf)^ := BitmapSection; 5187 Result := SizeOf(TDIBSECTION); 5188 end 5189 else if BufSize>0 5190 then begin 5191 Move(BitmapSection,Buf^,BufSize); 5192 Result := BufSize; 5193 end; 5194 end; 5195 5196var 5197 GDIObject: PGDIObject absolute GDIObj; 5198 ALogPen: PLogPen absolute Buf; 5199 AExtLogPen: PExtLogPen absolute Buf; 5200 AFont: PPangoLayout; 5201 AFontName: String; 5202 PangoDesc: PPangoFontDescription; 5203 i, RequiredSize: Integer; 5204 AFontSize: gint; 5205begin 5206 Result := 0; 5207 if not IsValidGDIObject(GDIObj) then Exit; 5208 5209 case GDIObject^.GDIType of 5210 gdiBitmap: 5211 Result := GetObject_Bitmap; 5212 gdiBrush: 5213 begin 5214 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetObject] gdiBrush'); 5215 end; 5216 gdiFont: 5217 begin 5218 if Buf = nil 5219 then begin 5220 Result := SizeOf(GDIObject^.LogFont); 5221 Exit; 5222 end; 5223 if BufSize >= SizeOf(GDIObject^.LogFont) then 5224 begin 5225 PLogfont(Buf)^ := GDIObject^.LogFont; 5226 Result:= SizeOf(TLogFont); 5227 if IsFontNameDefault(GDIObject^.LogFont.lfFaceName) then 5228 begin 5229 AFontName := GetDefaultFontName; 5230 5231 if (AFontName = '') or IsFontNameDefault(AFontName) then 5232 begin 5233 AFont := GetDefaultGtkFont(False); 5234 if PANGO_IS_LAYOUT(AFont) then 5235 begin 5236 PangoDesc := pango_layout_get_font_description(AFont); 5237 if PangoDesc = nil then 5238 PangoDesc := pango_context_get_font_description(pango_layout_get_context(AFont)); 5239 AFontName := StrPas(pango_font_description_get_family(PangoDesc)); 5240 end; 5241 end; 5242 5243 if AFontName <> '' then 5244 PLogfont(Buf)^.lfFaceName := AFontName; 5245 end; 5246 5247 if (GDIObject^.GDIFontObject <> nil) then 5248 begin 5249 AFont := GDIObject^.GDIFontObject; 5250 if PANGO_IS_LAYOUT(AFont) then 5251 begin 5252 PangoDesc := pango_layout_get_font_description(GDIObject^.GDIFontObject); 5253 if PangoDesc = nil then 5254 PangoDesc := pango_context_get_font_description(pango_layout_get_context(AFont)); 5255 5256 AFontSize := pango_font_description_get_size(PangoDesc); 5257 if not pango_font_description_get_size_is_absolute(PangoDesc) then 5258 AFontSize := MulDiv(AFontSize, Screen.PixelsPerInch, 72 * PANGO_SCALE) 5259 else 5260 AFontSize := AFontSize div PANGO_SCALE;; 5261 5262 PLogfont(Buf)^.lfHeight := AFontSize; 5263 end; 5264 end; 5265 end else 5266 if BufSize > 0 then 5267 begin 5268 Move(GDIObject^.LogFont,Buf^,BufSize); 5269 Result:=BufSize; 5270 end; 5271 end; 5272 gdiPen: 5273 begin 5274 if GDIObject^.IsExtPen then 5275 begin 5276 RequiredSize := SizeOf(TExtLogPen); 5277 if GDIObject^.GDIPenDashesCount > 1 then 5278 RequiredSize := RequiredSize + (GDIObject^.GDIPenDashesCount - 1) * SizeOf(DWord); 5279 5280 if Buf = nil then 5281 Result := RequiredSize 5282 else 5283 if BufSize >= RequiredSize then 5284 begin 5285 Result := RequiredSize; 5286 5287 AExtLogPen^.elpPenStyle := GDIObject^.GDIPenStyle; 5288 AExtLogPen^.elpWidth := GDIObject^.GDIPenWidth; 5289 AExtLogPen^.elpBrushStyle := BS_SOLID; 5290 AExtLogPen^.elpColor := GDIObject^.GDIPenColor.ColorRef; 5291 AExtLogPen^.elpHatch := 0; 5292 AExtLogPen^.elpNumEntries := GDIObject^.GDIPenDashesCount; 5293 if GDIObject^.GDIPenDashesCount > 0 then 5294 begin 5295 for i := 0 to GDIObject^.GDIPenDashesCount - 1 do 5296 PDWord(@AExtLogPen^.elpStyleEntry)[i] := GDIObject^.GDIPenDashes[i]; 5297 end 5298 else 5299 AExtLogPen^.elpStyleEntry[0] := 0; 5300 end; 5301 end 5302 else 5303 begin 5304 if Buf = nil then 5305 Result := SizeOf(TLogPen) 5306 else 5307 if BufSize >= SizeOf(TLogPen) then 5308 begin 5309 Result := SizeOf(TLogPen); 5310 ALogPen^.lopnColor := GDIObject^.GDIPenColor.ColorRef; 5311 ALogPen^.lopnWidth := Point(GDIObject^.GDIPenWidth, 0); 5312 ALogPen^.lopnStyle := GDIObject^.GDIPenStyle; 5313 end; 5314 end; 5315 end; 5316 gdiRegion: 5317 begin 5318 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetObject] gdiRegion'); 5319 end; 5320 else 5321 DebugLn('WARNING: [TGtk2WidgetSet.GetObject] Unknown type %d', [Integer(GDIObject^.GDIType)]); 5322 end; 5323end; 5324 5325{------------------------------------------------------------------------------ 5326 Function: GetParent 5327 Params: Handle: 5328 Returns: 5329 5330 ------------------------------------------------------------------------------} 5331function TGtk2WidgetSet.GetParent(Handle : HWND): HWND; 5332begin 5333 if Handle <> 0 then 5334 Result := {%H-}HWnd({%H-}PGtkWidget(Handle)^.Parent) 5335 else 5336 Result := 0; 5337end; 5338 5339 5340{------------------------------------------------------------------------------ 5341 Function: GetProp 5342 Params: Handle: Str 5343 Returns: Pointer 5344 5345 ------------------------------------------------------------------------------} 5346function TGtk2WidgetSet.GetProp(Handle : hwnd; Str : PChar): Pointer; 5347Begin 5348 Result := g_object_get_data({%H-}PGObject(Handle),Str); 5349end; 5350 5351{------------------------------------------------------------------------------ 5352 function TGtk2WidgetSet.GetScrollBarSize(Handle: HWND; BarKind: Integer): integer; 5353 5354 Returns the current width of the scrollbar of the widget. 5355 ------------------------------------------------------------------------------} 5356function TGtk2WidgetSet.GetScrollBarSize(Handle: HWND; BarKind: Integer): integer; 5357var 5358 Widget, ScrollWidget, BarWidget: PGtkWidget; 5359begin 5360 Result:=0; 5361 Widget:={%H-}PGtkWidget(Handle); 5362 if GtkWidgetIsA(Widget,GTK_TYPE_SCROLLED_WINDOW) then begin 5363 ScrollWidget:=Widget; 5364 end else begin 5365 ScrollWidget:=PGtkWidget(g_object_get_data(PGObject(Widget),odnScrollArea)); 5366 end; 5367 if ScrollWidget=nil then exit; 5368 if BarKind=SM_CYVSCROLL then begin 5369 BarWidget:=PGtkScrolledWindow(ScrollWidget)^.vscrollbar; 5370 if BarWidget<>nil then 5371 Result:=BarWidget^.Requisition.Width; 5372 end else begin 5373 BarWidget:=PGtkScrolledWindow(ScrollWidget)^.hscrollbar; 5374 if BarWidget<>nil then 5375 Result:=BarWidget^.Requisition.Height; 5376 end; 5377end; 5378 5379{------------------------------------------------------------------------------ 5380 function TGtk2WidgetSet.GetScrollbarVisible(Handle: HWND; 5381 SBStyle: Integer): boolean; 5382 ------------------------------------------------------------------------------} 5383function TGtk2WidgetSet.GetScrollbarVisible(Handle: HWND; SBStyle: Integer): boolean; 5384var 5385 Widget, ScrollWidget, BarWidget: PGtkWidget; 5386begin 5387 Result:=false; 5388 if Handle=0 then exit; 5389 Widget:={%H-}PGtkWidget(Handle); 5390 if GtkWidgetIsA(Widget,GTK_TYPE_SCROLLED_WINDOW) then begin 5391 ScrollWidget:=Widget; 5392 end else begin 5393 ScrollWidget:=PGtkWidget(g_object_get_data(PGObject(Widget),odnScrollArea)); 5394 end; 5395 if ScrollWidget=nil then exit; 5396 if SBStyle=SB_VERT then begin 5397 BarWidget:=PGtkScrolledWindow(ScrollWidget)^.vscrollbar; 5398 end else begin 5399 BarWidget:=PGtkScrolledWindow(ScrollWidget)^.hscrollbar; 5400 end; 5401 if BarWidget<>nil then 5402 Result:=GTK_WIDGET_VISIBLE(BarWidget); 5403end; 5404 5405{------------------------------------------------------------------------------ 5406 Function: GetScrollInfo 5407 Params: Handle, BarFlag, ScrollInfo 5408 Returns: Nothing 5409 5410 ------------------------------------------------------------------------------} 5411function TGtk2WidgetSet.GetScrollInfo(Handle: HWND; SBStyle: Integer; 5412 var ScrollInfo: TScrollInfo): Boolean; 5413var 5414 Adjustment: PGtkAdjustment; 5415 Scroll : PGTKWidget; 5416 IsScrollWindow: Boolean; 5417begin 5418 Result := false; 5419 if (Handle = 0) then exit; 5420 5421 5422 Scroll := g_object_get_data({%H-}PGObject(Handle), odnScrollArea); 5423 if GtkWidgetIsA(Scroll, gtk_scrolled_window_get_type) 5424 then begin 5425 IsScrollWindow := True; 5426 end 5427 else begin 5428 Scroll := {%H-}PGTKWidget(Handle); 5429 IsScrollWindow := GtkWidgetIsA(Scroll, gtk_scrolled_window_get_type); 5430 end; 5431 5432 Adjustment := nil; 5433 5434 case SBStyle of 5435 SB_HORZ: 5436 if IsScrollWindow 5437 then begin 5438 Adjustment := gtk_scrolled_window_get_hadjustment( 5439 PGTKScrolledWindow(Scroll)); 5440 end 5441 else if GtkWidgetIsA(PGtkWidget(Scroll),gtk_clist_get_type) 5442 then begin 5443 //clist 5444 {TODO check is this is needed for listviews} 5445 DebugLn('[GetScrollInfo] Possible obsolete get use of CList (Listview ?)'); 5446 Adjustment := gtk_clist_get_hadjustment(PgtkCList(Scroll)); 5447 end 5448 // obsolete stuff 5449 else if GtkWidgetIsA(PGtkWidget(Scroll),gtk_hscrollbar_get_type) 5450 then begin 5451 // this one shouldn't be possible, scrolbar messages are sent to the CTL 5452 DebugLN('!!! direct SB_HORZ get call to scrollbar'); 5453 Adjustment := PgtkhScrollBar(Scroll)^.Scrollbar.Range.Adjustment; 5454 end; 5455 5456 SB_VERT: 5457 if GtkWidgetIsA(PGtkWidget(Scroll),gtk_scrolled_window_get_type) 5458 then begin 5459 Adjustment := gtk_scrolled_window_get_vadjustment( 5460 PGTKScrolledWindow(Scroll)); 5461 end 5462 else if GtkWidgetIsA(PGtkWidget(Scroll), gtk_clist_get_type) 5463 then begin 5464 //clist 5465 //TODO: check is this is needed for listviews 5466 DebugLn('[GetScrollInfo] Possible obsolete get use of CList (Listview ?)'); 5467 Adjustment := gtk_clist_get_vadjustment(PgtkCList(Scroll)); 5468 end 5469 // obsolete stuff 5470 else if GtkWidgetIsA(PGtkWidget(Scroll),gtk_vscrollbar_get_type) 5471 then begin 5472 // this one shouldn't be possible, scrolbar messages are sent to the CTL 5473 DebugLN('!!! direct SB_HORZ get call to scrollbar'); 5474 Adjustment := PgtkvScrollBar(Scroll)^.Scrollbar.Range.Adjustment; 5475 end; 5476 5477 SB_CTL: 5478 if GtkWidgetIsA(PGtkWidget(Scroll),gtk_vscrollbar_get_type) then 5479 Adjustment := PgtkvScrollBar(Scroll)^.Scrollbar.Range.Adjustment 5480 else 5481 if GtkWidgetIsA(PGtkWidget(Scroll),gtk_hscrollbar_get_type) then 5482 Adjustment := PgtkhScrollBar(Scroll)^.Scrollbar.Range.Adjustment 5483 else 5484 if GtkWidgetIsA(PGtkWidget(Scroll), gtk_range_get_type) then 5485 Adjustment := gtk_range_get_adjustment(PGTKRange(Scroll)); 5486 5487 SB_BOTH: 5488 DebugLn('[GetScrollInfo] Got SB_BOTH ???'); 5489 end; 5490 5491 if Adjustment = nil then Exit; 5492 5493 // POS 5494 if (ScrollInfo.fMask and SIF_POS) <> 0 5495 then begin 5496 ScrollInfo.nPos := Round(Adjustment^.Value); 5497 end; 5498 // RANGE 5499 if (ScrollInfo.fMask and SIF_RANGE) <> 0 5500 then begin 5501 ScrollInfo.nMin:= Round(Adjustment^.Lower); 5502 ScrollInfo.nMax:= Round(Adjustment^.Upper); 5503 end; 5504 // PAGE 5505 if (ScrollInfo.fMask and SIF_PAGE) <> 0 5506 then begin 5507 ScrollInfo.nPage := Round(Adjustment^.Page_Size); 5508 end; 5509 // TRACKPOS 5510 if (ScrollInfo.fMask and SIF_TRACKPOS) <> 0 5511 then begin 5512 ScrollInfo.nTrackPos := Round(Adjustment^.Value); 5513 end; 5514 5515 Result := true; 5516end; 5517 5518{------------------------------------------------------------------------------ 5519 Function: GetStockObject 5520 Params: 5521 Returns: Nothing 5522 5523 5524 ------------------------------------------------------------------------------} 5525function TGtk2WidgetSet.GetStockObject(Value: Integer): THandle; 5526begin 5527 Result := 0; 5528 case Value of 5529 BLACK_BRUSH: // Black brush. 5530 Result := FStockBlackBrush; 5531 DKGRAY_BRUSH: // Dark gray brush. 5532 Result := FStockDKGrayBrush; 5533 GRAY_BRUSH: // Gray brush. 5534 Result := FStockGrayBrush; 5535 LTGRAY_BRUSH: // Light gray brush. 5536 Result := FStockLtGrayBrush; 5537 NULL_BRUSH: // Null brush (equivalent to HOLLOW_BRUSH). 5538 Result := FStockNullBrush; 5539 WHITE_BRUSH: // White brush. 5540 Result := FStockWhiteBrush; 5541 5542 BLACK_PEN: // Black pen. 5543 Result := FStockBlackPen; 5544 NULL_PEN: // Null pen. 5545 Result := FStockNullPen; 5546 WHITE_PEN: // White pen. 5547 Result := FStockWhitePen; 5548 5549 (* ANSI_FIXED_FONT: // Fixed-pitch (monospace) system font. 5550 begin 5551 {If FStockFixedFont = 0 then 5552 FStockFixedFont := GetStockFixedFont; 5553 Result := FStockFixedFont;} 5554 end; 5555 ANSI_VAR_FONT: // Variable-pitch (proportional space) system font. 5556 begin 5557 end; 5558 DEVICE_DEFAULT_FONT: // Device-dependent font. 5559 begin 5560 end; *) 5561(* OEM_FIXED_FONT: // Original equipment manufacturer (OEM) dependent fixed-pitch (monospace) font. 5562 begin 5563 end; 5564*) 5565 DEFAULT_GUI_FONT, SYSTEM_FONT: // System font. By default, Windows uses the system font to draw menus, dialog box controls, and text. In Windows versions 3.0 and later, the system font is a proportionally spaced font; earlier versions of Windows used a monospace system font. 5566 begin 5567 // MG: this should only be done, when theme changed: 5568 {If FStockSystemFont <> 0 then begin //This is a Temporary Hack!!! This 5569 DeleteObject(FStockSystemFont); //should really only be done on 5570 FStockSystemFont := 0; //theme change. 5571 end;} 5572 5573 If FStockSystemFont = 0 then 5574 FStockSystemFont := HFont({%H-}PtrUInt(CreateDefaultFont)); 5575 Result := FStockSystemFont; 5576 end; 5577(* SYSTEM_FIXED_FONT: // Fixed-pitch (monospace) system font used in Windows versions earlier than 3.0. This stock object is provided for compatibility with earlier versions of Windows. 5578 begin 5579 Result := GetStockObject(ANSI_FIXED_FONT); 5580 end; 5581 DEFAULT_PALETTE: // Default palette. This palette consists of the static colors in the system palette. 5582 begin 5583 end; 5584*) 5585 end; 5586end; 5587 5588{------------------------------------------------------------------------------ 5589 Function: GetSysColor 5590 Params: index to the syscolors array 5591 Returns: RGB value 5592 5593 ------------------------------------------------------------------------------} 5594function TGtk2WidgetSet.GetSysColor(nIndex: Integer): DWORD; 5595begin 5596 if (nIndex < 0) or (nIndex > MAX_SYS_COLORS) 5597 then begin 5598 Result := 0; 5599 DumpStack; 5600 DebugLn(Format('ERROR: [TGtk2WidgetSet.GetSysColor] Bad Value: %d. Valid Range between 0 and %d', [nIndex, MAX_SYS_COLORS])); 5601 end 5602 else 5603 Result := SysColorMap[nIndex]; 5604end; 5605 5606function TGtk2WidgetSet.GetSysColorBrush(nIndex: Integer): HBrush; 5607begin 5608 if (nIndex < 0) or (nIndex > MAX_SYS_COLORS) 5609 then begin 5610 Result := 0; 5611 DumpStack; 5612 DebugLn(Format('ERROR: [TGtk2WidgetSet.GetSysColorBrush] Bad Value: %d. Valid Range between 0 and %d', [nIndex, MAX_SYS_COLORS])); 5613 end 5614 else 5615 Result := FSysColorBrushes[nIndex]; 5616end; 5617 5618{------------------------------------------------------------------------------ 5619 Function: GetSystemMetrics 5620 Params: 5621 Returns: Nothing 5622 5623 5624 ------------------------------------------------------------------------------} 5625function TGtk2WidgetSet.GetSystemMetrics(nIndex: Integer): Integer; 5626var 5627 P: Pointer; 5628{$ifdef HasX} 5629 ax,ay,ah,aw: gint; 5630{$endif} 5631{$IFDEF Win32} 5632 auw, auh: guint; 5633{$ENDIF} 5634 screen: PGdkScreen; 5635 ARect: TGdkRectangle; 5636 AValue: TGValue; 5637begin 5638 Result := 0; 5639 case nIndex of 5640 SM_ARRANGE: 5641 begin 5642 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_ARRANGE '); 5643 end; 5644 SM_CLEANBOOT: 5645 begin 5646 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CLEANBOOT '); 5647 end; 5648 SM_CMOUSEBUTTONS: 5649 begin 5650 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CMOUSEBUTTONS '); 5651 end; 5652 SM_CXBORDER: 5653 begin 5654 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CXBORDER '); 5655 Result := Max(FCachedBorderSize, 0); 5656 end; 5657 SM_CYBORDER: 5658 begin 5659 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CYBORDER '); 5660 Result := Max(FCachedBorderSize, 0); 5661 end; 5662 SM_CXCURSOR, 5663 SM_CYCURSOR: 5664 begin 5665 {$IFDEF Win32} 5666 // Width and height of a cursor, in pixels. For win32 system cannot create cursors of other sizes. 5667 // For gtk this should be maximal cursor sizes 5668 gdk_display_get_maximal_cursor_size(gdk_display_get_default, @auw, @auh); 5669 if nIndex = SM_CXCURSOR 5670 then Result := auw // return width 5671 else Result := auh; // return height 5672 {$ELSE} 5673 // At least on Linux, the default size should be taken: Issue #32385 5674 Result := gdk_display_get_default_cursor_size(gdk_display_get_default); 5675 {$ENDIF} 5676 end; 5677 SM_CXDOUBLECLK: 5678 begin 5679 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CXDOUBLECLK '); 5680 end; 5681 SM_CYDOUBLECLK: 5682 begin 5683 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CYDOUBLECLK '); 5684 end; 5685 SM_CXDRAG: 5686 begin 5687 Result := 2; 5688 end; 5689 SM_CYDRAG: 5690 begin 5691 Result := 2; 5692 end; 5693 SM_CXEDGE: 5694 begin 5695 Result := 2; 5696 end; 5697 SM_CYEDGE: 5698 begin 5699 Result := 2; 5700 end; 5701 SM_CXFIXEDFRAME: 5702 begin 5703 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CXFIXEDFRAME '); 5704 end; 5705 SM_CYFIXEDFRAME: 5706 begin 5707 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CYFIXEDFRAME '); 5708 end; 5709 SM_CXHSCROLL: 5710 begin 5711 P := GetStyleWidget(lgsVerticalScrollbar); 5712 if P <> nil then 5713 Result := GTK_Widget(P)^.requisition.Width; 5714 end; 5715 SM_CYHSCROLL: 5716 begin 5717 P := GetStyleWidget(lgsHorizontalScrollbar); 5718 if P <> nil then 5719 Result := GTK_Widget(P)^.requisition.Height; 5720 end; 5721 SM_CXHTHUMB, 5722 SM_CYVTHUMB: 5723 begin 5724 P := GetStyleWidget(lgsHorizontalScrollbar); 5725 if P <> nil then 5726 begin 5727 FillChar(AValue{%H-}, SizeOf(AValue), 0); 5728 g_value_init(@AValue, G_TYPE_INT); 5729 gtk_widget_style_get_property(P, 'slider-width', @AValue); 5730 Result := AValue.data[0].v_int; 5731 end; 5732 end; 5733 SM_CXICON, 5734 SM_CYICON: 5735 // big icon size 5736 // gtk recommends sizes 16,32,48. optional: 64 and 128 5737 Result := 128; 5738 SM_CXICONSPACING: 5739 begin 5740 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CXICONSPACING '); 5741 end; 5742 SM_CYICONSPACING: 5743 begin 5744 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CYICONSPACING '); 5745 end; 5746 SM_CXMAXIMIZED: 5747 begin 5748 {$IFDEF HasX} 5749 if XGetWorkarea(ax,ay,aw,ah)>=0 then 5750 Result := aw 5751 else 5752 Result := getSystemMetrics(SM_CXSCREEN); 5753 {$ENDIF} 5754 end; 5755 SM_CYMAXIMIZED: 5756 begin 5757 {$IFDEF HasX} 5758 if XGetWorkarea(ax,ay,aw,ah)>=0 then 5759 Result := ah 5760 else 5761 Result := getSystemMetrics(SM_CYSCREEN); 5762 {$ENDIF} 5763 end; 5764 SM_CXMAXTRACK: 5765 begin 5766 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CXMAXTRACK '); 5767 end; 5768 SM_CYMAXTRACK: 5769 begin 5770 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CYMAXTRACK '); 5771 end; 5772 SM_CXMENUCHECK: 5773 begin 5774 Result := 19; 5775 P := GetStyleWidget(lgsCheckbox); 5776 if P <> nil then 5777 Result := GTK_Widget(P)^.requisition.Width; 5778 end; 5779 SM_CYMENUCHECK: 5780 begin 5781 Result := 19; 5782 P := GetStyleWidget(lgsCheckbox); 5783 if P <> nil then 5784 Result := GTK_Widget(P)^.requisition.Height; 5785 end; 5786 SM_CXMENUSIZE, 5787 SM_CYMENUSIZE: 5788 begin 5789 Result := GetTitleBarHeight - (FCachedBorderSize * 2); 5790 end; 5791 SM_CXMIN: 5792 begin 5793 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CXMIN '); 5794 end; 5795 SM_CYMIN: 5796 begin 5797 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CYMIN '); 5798 end; 5799 SM_CXMINIMIZED: 5800 begin 5801 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CXMINIMIZED '); 5802 end; 5803 SM_CYMINIMIZED: 5804 begin 5805 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CYMINIMIZED '); 5806 end; 5807 SM_CXMINSPACING: 5808 begin 5809 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CXMINSPACING '); 5810 end; 5811 SM_CYMINSPACING: 5812 begin 5813 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CYMINSPACING '); 5814 end; 5815 SM_CXMINTRACK: 5816 begin 5817 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CXMINTRACK '); 5818 end; 5819 SM_CYMINTRACK: 5820 begin 5821 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CYMINTRACK '); 5822 end; 5823 SM_CXFULLSCREEN, 5824 SM_CXSCREEN: 5825 begin 5826 screen := gdk_screen_get_default(); 5827 gdk_screen_get_monitor_geometry(screen, 0, @ARect); 5828 Result := ARect.width; 5829 end; 5830 SM_CXVIRTUALSCREEN: 5831 begin 5832 Result := gdk_Screen_Width; 5833 end; 5834 SM_CYFULLSCREEN, 5835 SM_CYSCREEN: 5836 begin 5837 screen := gdk_screen_get_default(); 5838 gdk_screen_get_monitor_geometry(screen, 0, @ARect); 5839 Result := ARect.height; 5840 end; 5841 SM_CYVIRTUALSCREEN: 5842 begin 5843 result := gdk_Screen_Height; 5844 end; 5845 SM_CXSIZE: 5846 begin 5847 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CXSIZE '); 5848 end; 5849 SM_CYSIZE: 5850 begin 5851 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CYSIZE '); 5852 end; 5853 SM_CXSIZEFRAME, 5854 SM_CYSIZEFRAME: 5855 begin 5856 Result := FCachedBorderSize; 5857 end; 5858 SM_CXSMICON, 5859 SM_CYSMICON: 5860 // small icon size 5861 // gtk recommends sizes 16,32,48. optional: 64 and 128 5862 Result := 16; 5863 SM_CXSMSIZE: 5864 begin 5865 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CXSMSIZE '); 5866 end; 5867 SM_CYSMSIZE: 5868 begin 5869 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CYSMSIZE '); 5870 end; 5871 SM_CXVSCROLL: 5872 begin 5873 P := GetStyleWidget(lgsVerticalScrollbar); 5874 if P <> nil then 5875 Result := GTK_Widget(P)^.requisition.Width; 5876 end; 5877 SM_CYVSCROLL: 5878 begin 5879 P := GetStyleWidget(lgsHorizontalScrollbar); 5880 if P <> nil then 5881 Result := GTK_Widget(P)^.requisition.Height; 5882 end; 5883 SM_CYCAPTION: 5884 begin 5885 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CYCAPTION '); 5886 Result := GetTitleBarHeight; 5887 end; 5888 SM_CYKANJIWINDOW: 5889 begin 5890 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CYKANJIWINDOW '); 5891 end; 5892 SM_CYMENU: 5893 begin 5894 Result := 24; // default gtk2 menusize inside menubar. 5895 P := GetStyleWidget(lgsMenu); 5896 if P <> nil then 5897 Result := GTK_Widget(P)^.requisition.Height; 5898 end; 5899 SM_CYSMCAPTION: 5900 begin 5901 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CYSMCAPTION '); 5902 end; 5903 SM_DBCSENABLED: 5904 begin 5905 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_DBCSENABLED '); 5906 end; 5907 SM_DEBUG: 5908 begin 5909 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_DEBUG '); 5910 end; 5911 SM_MENUDROPALIGNMENT: 5912 begin 5913 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_MENUDROPALIGNMENT'); 5914 end; 5915 SM_MIDEASTENABLED: 5916 begin 5917 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_MIDEASTENABLED '); 5918 end; 5919 SM_MOUSEPRESENT: 5920 begin 5921 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_MOUSEPRESENT '); 5922 end; 5923 SM_MOUSEWHEELPRESENT: 5924 begin 5925 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_MOUSEWHEELPRESENT'); 5926 end; 5927 SM_NETWORK: 5928 begin 5929 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_NETWORK '); 5930 end; 5931 SM_PENWINDOWS: 5932 begin 5933 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_PENWINDOWS '); 5934 end; 5935 SM_SECURE: 5936 begin 5937 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_SECURE '); 5938 end; 5939 SM_SHOWSOUNDS: 5940 begin 5941 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_SHOWSOUNDS '); 5942 end; 5943 SM_SLOWMACHINE: 5944 begin 5945 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_SLOWMACHINE '); 5946 end; 5947 SM_SWAPBUTTON: 5948 begin 5949 //DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_SWAPBUTTON '); 5950 end; 5951 SM_SWSCROLLBARSPACING: 5952 begin 5953 P := GetStyleWidget(lgsScrolledWindow); 5954 if P <> nil then begin 5955 result := GTK_SCROLLED_WINDOW_CLASS(gtk_widget_get_class(P))^.scrollbar_spacing; 5956 if result<0 then 5957 gtk_widget_style_get(P, 'scrollbar-spacing', @result, nil); 5958 end; 5959 end; 5960 5961 SM_LCLMAXIMIZEDWIDTH: 5962 begin 5963 Result := GetSystemMetrics(SM_CXMAXIMIZED); 5964 end; 5965 SM_LCLMAXIMIZEDHEIGHT: 5966 begin 5967 Result := GetSystemMetrics(SM_CYMAXIMIZED) - 1 - 5968 (GetSystemMetrics(SM_CYCAPTION) - (GetSystemMetrics(SM_CYSIZEFRAME) * 2)); 5969 end; 5970 SM_LCLHasFormAlphaBlend: 5971 begin 5972 Result:=1; 5973 end; 5974 end; 5975end; 5976 5977{------------------------------------------------------------------------------ 5978 Function: GetTextColor 5979 Params: DC 5980 Returns: TColorRef 5981 5982 Gets the Font Color currently assigned to the Device Context 5983 ------------------------------------------------------------------------------} 5984function TGtk2WidgetSet.GetTextColor(DC: HDC) : TColorRef; 5985begin 5986 Result := 0; 5987 if IsValidDC(DC) then 5988 with TGtkDeviceContext(DC) do 5989 begin 5990 Result := CurrentTextColor.ColorRef; 5991 end; 5992end; 5993 5994{------------------------------------------------------------------------------ 5995 Function: GetTextExtentExPoint 5996 Params: 5997 Returns: 5998 5999 ------------------------------------------------------------------------------} 6000function TGtk2WidgetSet.GetTextExtentExPoint(DC: HDC; Str: PChar; 6001 Count, MaxWidth: Integer; MaxCount, PartialWidths: PInteger; 6002 var Size: TSize): Boolean; 6003var 6004 DevCtx: TGtkDeviceContext absolute DC; 6005 UseFont : TGtkIntfFont; 6006 Utf8Len, Accu, I: PtrInt; 6007 Iter: PPangoLayoutIter; 6008 CharRect: TPangoRectangle; 6009begin 6010 if not IsValidDC(DC) then 6011 Exit(False); 6012 6013 Size.cx := 0; 6014 Size.cy := 0; 6015 if MaxCount <> nil then 6016 MaxCount^ := 0; 6017 6018 if Count = 0 then 6019 Exit(True); 6020 if (Count < -1) or (Str = nil) then 6021 Exit(False); 6022 6023 if Count = -1 then 6024 Count := Length(Str); 6025 Utf8Len := UTF8Length(Str, Count); 6026 if Utf8Len = 0 then 6027 Exit(True); 6028 6029 UseFont := GetGtkFont(DevCtx); 6030 UpdateDCTextMetric(DevCtx); 6031 SetLayoutText(UseFont, Str, Count); 6032 pango_layout_get_pixel_size(UseFont, @Size.cx, @Size.cy); 6033 if DevCtx.HasTransf then 6034 begin 6035 DevCtx.InvTransfExtent(Size.cx, Size.cy); 6036 Size.cx := Abs(Size.cx); 6037 Size.cy := Abs(Size.cy); 6038 end; 6039 6040 if PartialWidths = nil then 6041 begin 6042 if MaxCount = nil then 6043 Exit(True); 6044 if Size.cx <= MaxWidth then 6045 begin 6046 MaxCount^ := Utf8Len; 6047 Exit(True); 6048 end; 6049 end; 6050 6051 I := 1; 6052 Accu := 0; 6053 Iter := pango_layout_get_iter(UseFont); 6054 repeat 6055 pango_layout_iter_get_char_extents(Iter, @CharRect); 6056 Inc(Accu, CharRect.Width); 6057 6058 CharRect.Width := Accu; 6059 pango_extents_to_pixels(nil, @CharRect); 6060 if DevCtx.HasTransf then 6061 begin 6062 DevCtx.InvTransfExtent(CharRect.Width, CharRect.Height); 6063 CharRect.Width := Abs(CharRect.Width); 6064 end; 6065 6066 if MaxCount <> nil then 6067 begin 6068 if CharRect.Width > MaxWidth then 6069 Break; 6070 MaxCount^ := I; 6071 end; 6072 if PartialWidths <> nil then 6073 PartialWidths[I - 1] := CharRect.Width; 6074 6075 Inc(I); 6076 until not pango_layout_iter_next_char(Iter); 6077 pango_layout_iter_free(Iter); 6078 6079 Exit(True); 6080end; 6081 6082{------------------------------------------------------------------------------ 6083 Function: GetTextExtentPoint 6084 Params: none 6085 Returns: Nothing 6086 6087 6088 ------------------------------------------------------------------------------} 6089function TGtk2WidgetSet.GetTextExtentPoint(DC: HDC; Str: PChar; Count: Integer; 6090 var Size: TSize): Boolean; 6091begin 6092 Result := GetTextExtentExPoint(DC, Str, Count, 0, nil, nil, Size); 6093end; 6094 6095{------------------------------------------------------------------------------ 6096 Function: GetTextMetrics 6097 Params: none 6098 Returns: Nothing 6099 6100 6101 ------------------------------------------------------------------------------} 6102function TGtk2WidgetSet.GetTextMetrics(DC: HDC; var TM: TTextMetric): Boolean; 6103var 6104 DevCtx: TGtkDeviceContext absolute DC; 6105begin 6106 Result := IsValidDC(DC); 6107 if Result then 6108 begin 6109 UpdateDCTextMetric(DevCtx); 6110 TM := DevCtx.DCTextMetric.TextMetric; 6111 end; 6112end; 6113 6114function TGtk2WidgetSet.GetViewPortExtEx(DC: HDC; Size: PSize): Integer; 6115var 6116 DevCtx: TGtkDeviceContext absolute DC; 6117begin 6118 if IsValidDC(DC) and (Size <> nil) then 6119 begin 6120 Size^.cx := DevCtx.ViewPortExt.x; 6121 Size^.cy := DevCtx.ViewPortExt.y; 6122 Result := Integer(True); 6123 end else 6124 Result := Integer(False); 6125end; 6126 6127function TGtk2WidgetSet.GetViewPortOrgEx(DC: HDC; P: PPoint): Integer; 6128var 6129 DevCtx: TGtkDeviceContext absolute DC; 6130begin 6131 if IsValidDC(DC) and (P <> nil) then 6132 begin 6133 P^.x := DevCtx.ViewPortOrg.x; 6134 P^.y := DevCtx.ViewPortOrg.y; 6135 Result := Integer(True); 6136 end else 6137 Result := Integer(False); 6138end; 6139 6140function TGtk2WidgetSet.GetWindowExtEx(DC: HDC; Size: PSize): Integer; 6141var 6142 DevCtx: TGtkDeviceContext absolute DC; 6143begin 6144 if IsValidDC(DC) and (Size <> nil) then 6145 begin 6146 Size^.cx := DevCtx.WindowExt.x; 6147 Size^.cy := DevCtx.WindowExt.y; 6148 Result := Integer(True); 6149 end else 6150 Result := Integer(False); 6151end; 6152 6153{------------------------------------------------------------------------------ 6154 Function: GetWindowLong 6155 Params: none 6156 Returns: Nothing 6157 ------------------------------------------------------------------------------} 6158function TGtk2WidgetSet.GetWindowLong(Handle: HWND; int: Integer): PtrInt; 6159 6160 function GetObjectData(Name: PChar): PtrInt; 6161 begin 6162 Result := PtrInt({%H-}PtrUInt({%H-}g_object_get_data({%H-}PGObject(Handle),Name))); 6163 end; 6164var 6165 WidgetInfo: PWidgetInfo; 6166begin 6167 //TODO:Started but not finished 6168 6169 case int of 6170 GWL_WNDPROC : 6171 begin 6172 WidgetInfo := GetWidgetInfo({%H-}Pointer(Handle)); 6173 if WidgetInfo <> nil then 6174 Result := WidgetInfo^.WndProc 6175 else 6176 Result := 0; 6177 end; 6178 GWL_HINSTANCE : 6179 begin 6180 Result := GetObjectData('HINSTANCE'); 6181 end; 6182 GWL_HWNDPARENT : 6183 begin 6184 Result := GetObjectData('HWNDPARENT'); 6185 end; 6186 6187{ GWL_WNDPROC : 6188 begin 6189 Data := GetLCLObject(Pointer(Handle)); 6190 if Data is TControl 6191 then Result := PtrInt(@(TControl(Data).WindowProc)); 6192 // TODO fix this, a method pointer (2 pointers) can not be casted to a longint 6193 end; 6194} 6195{ GWL_HWNDPARENT : 6196 begin 6197 Data := GetLCLObject(Pointer(Handle)); 6198 if (Data is TWinControl) 6199 then Result := PtrInt(TWincontrol(Data).Handle) 6200 else Result := 0; 6201 end; 6202 } 6203 GWL_STYLE : 6204 begin 6205 WidgetInfo := GetWidgetInfo({%H-}Pointer(Handle)); 6206 if WidgetInfo <> nil then 6207 Result := WidgetInfo^.Style 6208 else 6209 Result := 0; 6210 end; 6211 GWL_EXSTYLE : 6212 begin 6213 WidgetInfo := GetWidgetInfo({%H-}Pointer(Handle)); 6214 if WidgetInfo <> nil then 6215 Result := WidgetInfo^.ExStyle 6216 else 6217 Result := 0; 6218 end; 6219 GWL_USERDATA : 6220 begin 6221 Result := GetObjectData('Userdata'); 6222 end; 6223 GWL_ID : 6224 begin 6225 Result := GetObjectData('ID'); 6226 end; 6227 else Result := 0; 6228 end; //case 6229end; 6230 6231{------------------------------------------------------------------------------ 6232 Function: GetWindowOrgEx 6233 Params: none 6234 Returns: Nothing 6235 6236 Returns the current offset of the DC. 6237 ------------------------------------------------------------------------------} 6238function TGtk2WidgetSet.GetWindowOrgEx(dc: hdc; P: PPoint): Integer; 6239var 6240 DevCtx: TGtkDeviceContext absolute DC; 6241begin 6242 if P = nil then Exit(0); 6243 P^ := Point(0,0); 6244 if not IsValidDC(DC) then exit(0); 6245 6246 P^ := DevCtx.WindowOrg; 6247 Result := 1; 6248end; 6249 6250{------------------------------------------------------------------------------ 6251 Function: GetWindowRect 6252 Params: none 6253 Returns: 0 6254 6255 After the call, ARect will be the control area in screen coordinates. 6256 That means, Left and Top will be the screen coordinate of the TopLeft pixel 6257 of the Handle object and Right and Bottom will be the screen coordinate of 6258 the BottomRight pixel. 6259 ------------------------------------------------------------------------------} 6260function TGtk2WidgetSet.GetWindowRect(Handle: hwnd; var ARect: TRect): Integer; 6261var 6262 Widget: PGTKWidget; 6263 GRect: TGdkRectangle; 6264 P: TPoint; 6265 AInfo: PWidgetInfo; 6266 AForm: TCustomForm; 6267 R, AFrame: TRect; 6268begin 6269 Result := 0; // error 6270 if Handle = 0 then 6271 Exit; 6272 6273 Widget := {%H-}PGtkWidget(Handle); 6274 6275 if GTK_IS_WINDOW(Widget) and Assigned(Widget^.window) 6276 and GTK_WIDGET_VISIBLE(Widget) // Gtk2 returns invalid origin/frame for invisible widgets 6277 then 6278 begin 6279 P := GetWidgetOrigin(Widget); 6280 gdk_window_get_frame_extents(Widget^.window, @GRect); 6281 ARect := Bounds(P.X,P.Y,GRect.width,GRect.height); 6282 // writeln('Frame extents are: ',dbgs(R),' ARECT=',dbgs(ARect)); 6283 Result := 1; // success 6284 end else 6285 begin 6286 {$IFDEF HASX} 6287 AInfo := GetWidgetInfo(Widget); 6288 if (AInfo^.LCLObject is TCustomForm) and not AInfo^.FirstPaint then 6289 begin 6290 AForm := TCustomForm(AInfo^.LCLObject); 6291 if not IsFormDesign(AForm) and (AForm.BorderStyle <> bsNone) and 6292 not (AForm.FormStyle in [fsMDIChild, fsSplash]) 6293 and (Gtk2WidgetSet.GetDummyWidgetFrame <> Rect(0, 0, 0, 0)) then 6294 begin 6295 R := AForm.BoundsRect; 6296 AFrame := Gtk2WidgetSet.GetDummyWidgetFrame; 6297 // apply frame size to lcl form. 6298 R.Right += AFrame.Left + AFrame.Right; 6299 R.Bottom += AFrame.Top + AFrame.Bottom; 6300 ARect := R; //this is now real size under x11 even on unmapped window :) 6301 exit(-1); 6302 end; 6303 end; 6304 {$ENDIF} 6305 ARect.TopLeft := GetWidgetOrigin(Widget); 6306 if (ARect.Top <> -1) or (ARect.Left <> -1) 6307 or (Widget^.allocation.width <> 1) or (Widget^.allocation.height <> 1) then 6308 begin 6309 ARect.BottomRight := Point( 6310 ARect.Left + Widget^.allocation.width, 6311 ARect.Top + Widget^.allocation.height); 6312 Result := 1; // success 6313 end; 6314 end; 6315end; 6316{------------------------------------------------------------------------------ 6317 Function: GetWindowRelativePosition 6318 Params: Handle : hwnd; 6319 Returns: true on success 6320 6321 Returns the Left, Top, relative to the client origin of its parent 6322 ------------------------------------------------------------------------------} 6323function TGtk2WidgetSet.GetWindowRelativePosition(Handle : hwnd; 6324 var Left, Top: integer): boolean; 6325var 6326 aWidget: PGtkWidget; 6327begin 6328 aWidget := {%H-}PGtkWidget(Handle); 6329 if GtkWidgetIsA(aWidget, GTK_TYPE_WIDGET) then 6330 begin 6331 Result := true; 6332 GetWidgetRelativePosition(aWidget, Left, Top); 6333 end else 6334 Result := false; 6335end; 6336 6337{------------------------------------------------------------------------------ 6338 Function: GetWindowSize 6339 Params: Handle : hwnd; 6340 Returns: true on success 6341 6342 Returns the current widget Width and Height 6343 ------------------------------------------------------------------------------} 6344function TGtk2WidgetSet.GetWindowSize(Handle : hwnd; 6345 var Width, Height: integer): boolean; 6346begin 6347 if GtkWidgetIsA({%H-}PGtkWidget(Handle),GTK_TYPE_WIDGET) then begin 6348 Result:=true; 6349 Width:=Max(0,{%H-}PGtkWidget(Handle)^.Allocation.Width); 6350 Height:=Max(0,{%H-}PGtkWidget(Handle)^.Allocation.Height); 6351 //DebugLn(['TGtk2WidgetSet.GetWindowSize ',DbgSName(GetLCLOwnerObject(Handle)),' Allocation=',Width,'x',Height]); 6352 end else 6353 Result:=false; 6354end; 6355 6356{------------------------------------------------------------------------------ 6357 Function: HideCaret 6358 Params: none 6359 Returns: Nothing 6360 6361 6362 ------------------------------------------------------------------------------} 6363function TGtk2WidgetSet.HideCaret(hWnd: HWND): Boolean; 6364var 6365 GTKObject: PGTKObject; 6366 WasVisible: boolean; 6367begin 6368 GTKObject := {%H-}PGTKObject(HWND); 6369 Result := GTKObject <> nil; 6370 6371 if Result 6372 then begin 6373 if gtk_type_is_a(g_object_type(GTKObject), GTKAPIWidget_GetType) 6374 then begin 6375 WasVisible:=false; 6376 GTKAPIWidget_HideCaret(PGTKAPIWidget(GTKObject),WasVisible); 6377 end 6378// else if // TODO: other widgettypes 6379 else begin 6380 Result := False; 6381 end; 6382 end 6383 else DebugLn('WARNING: [TGtk2WidgetSet.HideCaret] Got null HWND'); 6384 6385end; 6386 6387{------------------------------------------------------------------------------ 6388 Function: InvalidateRect 6389 Params: aHandle: 6390 Rect: 6391 bErase: 6392 Returns: 6393 6394 ------------------------------------------------------------------------------} 6395function TGtk2WidgetSet.InvalidateRect(aHandle : HWND; Rect : pRect; 6396 bErase : Boolean) : Boolean; 6397var 6398 gdkRect : TGDKRectangle; 6399 Widget, PaintWidget: PGtkWidget; 6400 LCLObject: TObject; 6401 WidgetInfo: PWidgetInfo; 6402 r: TRect; 6403 Adjustment: PGtkAdjustment; 6404 Pt: TPoint; 6405begin 6406 // DebugLn(format('Rect = %d,%d,%d,%d',[rect^.left,rect^.top,rect^.Right,rect^.Bottom])); 6407 Widget:={%H-}PGtkWidget(aHandle); 6408 LCLObject:=GetLCLObject(Widget); 6409 if (LCLObject<>nil) then 6410 begin 6411 if (LCLObject=CurrentSentPaintMessageTarget) then 6412 begin 6413 DebugLn('WARNING: TGtk2WidgetSet.InvalidateRect refused invalidating during paint message: ', 6414 LCLObject.ClassName); 6415 exit(False); 6416 end; 6417 {$IFDEF VerboseDsgnPaintMsg} 6418 if (LCLObject is TComponent) 6419 and (csDesigning in TComponent(LCLObject).ComponentState) then begin 6420 write('TGtk2WidgetSet.InvalidateRect A '); 6421 write(TComponent(LCLObject).Name,':'); 6422 write(LCLObject.ClassName); 6423 with Rect^ do 6424 write(' Rect=',Left,',',Top,',',Right,',',Bottom); 6425 DebugLn(' Erase=',bErase); 6426 end; 6427 {$ENDIF} 6428 end; 6429 Result := True; 6430 PaintWidget:=GetFixedWidget(Widget); 6431 if PaintWidget=nil then PaintWidget:=Widget; 6432 6433 if Rect = nil then 6434 begin 6435 Rect := @r; 6436 Rect^.Left := 0;//PaintWidget^.Allocation.X; 6437 Rect^.Top := 0;//PaintWidget^.Allocation.Y; 6438 Rect^.Right := PaintWidget^.Allocation.Width; 6439 Rect^.Bottom := PaintWidget^.Allocation.Height; 6440 end else 6441 begin 6442 // normalize rect 6443 r := Rect^; 6444 if r.Left>r.Right then 6445 begin 6446 r.Left := r.Right; 6447 r.Right := Rect^.Left; 6448 end; 6449 if r.Top>r.Bottom then 6450 begin 6451 r.Top := r.Bottom; 6452 r.Bottom := Rect^.Top; 6453 end; 6454 Rect := @r; 6455 end; 6456 6457 gdkRect.X := Rect^.Left; 6458 gdkRect.Y := Rect^.Top; 6459 gdkRect.Width := (Rect^.Right - Rect^.Left); 6460 gdkRect.Height := (Rect^.Bottom - Rect^.Top); 6461 6462 if (PaintWidget<>nil) and GTK_WIDGET_NO_WINDOW(PaintWidget) and (Rect<>nil) and 6463 (not GtkWidgetIsA(PGTKWidget(PaintWidget),GTKAPIWidget_GetType)) then 6464 begin 6465 Inc(gdkRect.X, PaintWidget^.Allocation.x); 6466 Inc(gdkRect.Y, PaintWidget^.Allocation.y); 6467 // issue #25572 6468 if GTK_IS_FIXED(PaintWidget) and GTK_IS_EVENT_BOX(PaintWidget^.parent) then 6469 begin 6470 Inc(gdkRect.Width, PaintWidget^.Allocation.x); 6471 Inc(gdkRect.Height, PaintWidget^.Allocation.y); 6472 // DebugLn('#25572 PATCH FOR ',dbgsName(LCLObject),' GdkRect=',dbgs(gdkRect),' Alloc=',dbgs(TGdkRectangle(PaintWidget^.allocation))); 6473 {GtkWidget isn't yet allocated to LCL size, do not call invalid area update - update complete gtkwidget} 6474 if (gdkRect.Width > PaintWidget^.allocation.width) or (gdkRect.Height > PaintWidget^.allocation.Height) then 6475 begin 6476 // DebugLn('*** WARNING: Rect to paint is bigger than widget Width diff=',dbgs(gdkRect.Width - PaintWidget^.allocation.width), 6477 // ' Height diff=',dbgs(gdkRect.Height - PaintWidget^.allocation.height)); 6478 if bErase then 6479 gtk_widget_queue_clear(PaintWidget); 6480 gtk_widget_queue_draw(PaintWidget); 6481 exit; 6482 end; 6483 end; 6484 end; 6485 if (LCLObject is TScrollingWinControl) and GTK_IS_SCROLLED_WINDOW(Widget) then 6486 begin 6487 Pt := Point(0, 0); 6488 Adjustment := gtk_scrolled_window_get_vadjustment(PGtkScrolledWindow(Widget)); 6489 if Adjustment <> nil then 6490 Pt.Y := Round(Adjustment^.value); 6491 Adjustment := gtk_scrolled_window_get_hadjustment(PGtkScrolledWindow(Widget)); 6492 if Adjustment <> nil then 6493 Pt.X := Round(Adjustment^.value); 6494 dec(gdkRect.x, Pt.X); 6495 dec(gdkRect.y, Pt.Y); 6496 OffsetRect(Rect^, -Pt.X, -Pt.Y); 6497 end; 6498 WidgetInfo := GetWidgetInfo(Widget); // GetOrCreateWidgetInfo() ?? 6499 if WidgetInfo <> nil then 6500 UnionRect(WidgetInfo^.UpdateRect, WidgetInfo^.UpdateRect, Rect^); 6501 6502 if bErase then 6503 gtk_widget_queue_clear_area(PaintWidget, 6504 gdkRect.X,gdkRect.Y,gdkRect.Width,gdkRect.Height); 6505 6506 gtk_widget_queue_draw_area(PaintWidget, 6507 gdkRect.X,gdkRect.Y,gdkRect.Width,gdkRect.Height); 6508 6509 //DebugLn(['TGtk2WidgetSet.InvalidateRect ',GetWidgetDebugReport(Widget),' IsAPI=',GtkWidgetIsA(PGTKWidget(Widget),GTKAPIWidget_GetType)]); 6510 if GtkWidgetIsA(PGTKWidget(Widget),GTKAPIWidget_GetType) then 6511 GTKAPIWidget_InvalidateCaret(PGTKAPIWidget(Widget)); 6512end; 6513 6514function TGtk2WidgetSet.InvalidateRgn(Handle: HWND; Rgn: HRGN; Erase: Boolean 6515 ): Boolean; 6516var 6517 R: TRect; 6518begin 6519 // TODO: use gdk_window_invalidate_region to implement this function 6520 Result:=GetRgnBox(Rgn, @R)=0; 6521 InvalidateRect(Handle, @R, Erase); 6522end; 6523 6524function TGtk2WidgetSet.IsIconic(handle: HWND): boolean; 6525var 6526 GtkWindow: PGtkWindow absolute handle; 6527begin 6528 Result := False; 6529 if GtkWindow = nil then 6530 Exit; 6531 6532 Result := (PGtkWidget(GtkWindow)^.Window<>nil) 6533 and (gdk_window_get_state(PGtkWidget(GtkWindow)^.Window) 6534 and GDK_WINDOW_STATE_ICONIFIED <> 0); 6535end; 6536 6537function TGtk2WidgetSet.IsWindow(handle: HWND): boolean; 6538begin 6539 if Handle = 0 then 6540 Exit(False); 6541 6542 Result := GtkWidgetIsA({%H-}PGtkWidget(Handle), GTK_TYPE_WIDGET); 6543end; 6544 6545{------------------------------------------------------------------------------ 6546 function TGtk2WidgetSet.IsWindowEnabled(handle: HWND): boolean; 6547 6548 ------------------------------------------------------------------------------} 6549function TGtk2WidgetSet.IsWindowEnabled(handle: HWND): boolean; 6550var 6551 LCLObject: TObject; 6552 Widget: PGtkWidget; 6553 AForm: TCustomForm; 6554 //i: Integer; 6555begin 6556 Widget:={%H-}PGtkWidget(handle); 6557 Result:=(Widget<>nil) and GTK_WIDGET_SENSITIVE(Widget) 6558 and GTK_WIDGET_PARENT_SENSITIVE(Widget) and GTK_WIDGET_VISIBLE(Widget); 6559 LCLObject:=GetLCLObject({%H-}PGtkWidget(Handle)); 6560 //debugln('TGtk2WidgetSet.IsWindowEnabled A ',DbgSName(LCLObject),' Result=',dbgs(Result), 6561 // ' SENSITIVE=',dbgs(GTK_WIDGET_SENSITIVE(Widget)), 6562 // ' PARENT_SENSITIVE=',dbgs(GTK_WIDGET_PARENT_SENSITIVE(Widget)), 6563 // ' TOPLEVEL=',dbgs(GTK_WIDGET_TOPLEVEL(Widget)), 6564 // ''); 6565 if Result and GtkWidgetIsA(Widget,GTK_TYPE_WINDOW) then begin 6566 LCLObject:=GetLCLObject(Widget); 6567 if (LCLObject is TCustomForm) then begin 6568 AForm:=TCustomForm(LCLObject); 6569 if not Screen.CustomFormBelongsToActiveGroup(AForm) then 6570 Result:=false; 6571 //debugln('TGtk2WidgetSet.IsWindowEnabled B ',dbgs(Screen.CustomFormBelongsToActiveGroup(AForm))); 6572 //for i:=0 to Screen.CustomFormCount-1 do begin 6573 // debugln(' ',dbgs(i),' ',DbgSName(Screen.CustomFormsZOrdered[i])); 6574 //end; 6575 end; 6576 end; 6577end; 6578 6579{------------------------------------------------------------------------------ 6580 function TGtk2WidgetSet.IsWindowVisible(handle: HWND): boolean; 6581 6582 ------------------------------------------------------------------------------} 6583function TGtk2WidgetSet.IsWindowVisible(handle: HWND): boolean; 6584begin 6585 Result := (handle <> 0) and GTK_WIDGET_VISIBLE({%H-}PGtkWidget(handle)); 6586end; 6587 6588function TGtk2WidgetSet.IsZoomed(handle: HWND): boolean; 6589var 6590 GtkWindow: PGtkWindow absolute handle; 6591begin 6592 Result := False; 6593 if GtkWindow = nil then 6594 Exit; 6595 6596 Result := gdk_window_get_state(PGtkWidget(GtkWindow)^.Window) and GDK_WINDOW_STATE_MAXIMIZED <> 0; 6597end; 6598 6599{------------------------------------------------------------------------------ 6600 Function: LineTo 6601 Params: none 6602 Returns: Nothing 6603 6604 6605 ------------------------------------------------------------------------------} 6606function TGtk2WidgetSet.LineTo(DC: HDC; X, Y: Integer): Boolean; 6607var 6608 DevCtx: TGtkDeviceContext absolute DC; 6609 FromPt: TPoint; 6610 ToPt: TPoint; 6611begin 6612 if not IsValidDC(DC) then Exit(False); 6613 6614 DevCtx.SelectPenProps; 6615 if not (dcfPenSelected in DevCtx.Flags) then Exit(False); 6616 6617 if DevCtx.IsNullPen then Exit(True); 6618 6619 FromPt := Point(DevCtx.PenPos.X + DevCtx.Offset.X, DevCtx.PenPos.Y + DevCtx.Offset.Y); 6620 LPtoDP(DC, FromPt, 1); 6621 ToPt := Point(X+DevCtx.Offset.X, Y+DevCtx.Offset.Y); 6622 LPToDP(DC, ToPt, 1); 6623 6624 {$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF} 6625 DevCtx.RemovePixbuf; 6626 gdk_draw_line(DevCtx.Drawable, DevCtx.GC, FromPt.X, FromPt.Y, ToPt.X, ToPt.Y); 6627 {$IFDEF DebugGDK}EndGDKErrorTrap;{$ENDIF} 6628 6629 DevCtx.PenPos := Point(X, Y); 6630 6631 Result := True; 6632end; 6633 6634function TGtk2WidgetSet.LPtoDP(DC: HDC; var Points; Count: Integer): BOOL; 6635var 6636 DevCtx: TGtkDeviceContext absolute DC; 6637 P: PPoint; 6638begin 6639 Result := False; 6640 6641 if not IsValidDC(DC) then Exit(False); 6642 6643 if not DevCtx.HasTransf then Exit(True); 6644 6645 P := @Points; 6646 while Count > 0 do 6647 begin 6648 Dec(Count); 6649 DevCtx.TransfPoint(P^.X, P^.Y); 6650 Inc(P); 6651 end; 6652 6653 Result := True; 6654end; 6655 6656{------------------------------------------------------------------------------ 6657 Function: MessageBox 6658 Params: hWnd: The handle of parent window 6659 Returns: 0 if not successful (out of memory), otherwise one of the defined value : 6660 IDABORT, IDCANCEL, IDIGNORE, IDNO, IDOK, IDRETRY, IDYES 6661 6662 The MessageBox function displays a modal dialog, with text and caption defined, 6663 and includes buttons. 6664 ------------------------------------------------------------------------------} 6665 6666function MessageButtonClicked(Widget : PGtkWidget; data: gPointer) : GBoolean; cdecl; 6667begin 6668 //DebugLn('[MessageButtonClicked] ',dbgs(data),' ',dbgs(g_object_get_data(PGtkObject(Widget), 'modal_result'))); 6669 if PInteger(data)^ = 0 then 6670 PInteger(data)^:={%H-}PtrUInt(g_object_get_data(PGObject(Widget), 'modal_result')); 6671 Result:=false; 6672end; 6673 6674function MessageBoxClosed(Widget : PGtkWidget; {%H-}Event : PGdkEvent; 6675 data: gPointer) : GBoolean; cdecl; 6676var ModalResult : PtrUInt; 6677begin 6678 { We were requested by window manager to close } 6679 if PInteger(data)^ = 0 then begin 6680 ModalResult:= {%H-}PtrUInt(g_object_get_data(PGObject(Widget), 'modal_result')); 6681 { Don't allow to close if we don't have a default return value } 6682 Result:= (ModalResult = 0); 6683 if not Result then PInteger(data)^:= ModalResult 6684 else DebugLn('Do not close !!!'); 6685 end else Result:= false; 6686end; 6687 6688function TGtk2WidgetSet.MessageBox(hWnd: HWND; lpText, lpCaption: PChar; 6689 uType : Cardinal): integer; 6690var Dialog, ALabel : PGtkWidget; 6691 ButtonCount, DefButton, ADialogResult : Integer; 6692 6693 procedure CreateButton(const ALabel : PChar; const RetValue : integer); 6694 var AButton : PGtkWidget; 6695 begin 6696 AButton:= gtk_button_new_with_mnemonic(Ampersands2Underscore(ALabel)); 6697 Inc(ButtonCount); 6698 if ButtonCount = DefButton then begin 6699 gtk_window_set_focus(PGtkWindow(Dialog), AButton); 6700 end; 6701 { If there is the Cancel button, allow the dialog to close } 6702 if RetValue = IDCANCEL then begin 6703 g_object_set_data(PGObject(Dialog), 'modal_result', Pointer(IDCANCEL)); 6704 end; 6705 g_object_set_data(PGObject(AButton), 'modal_result', 6706 {%H-}Pointer(PtrInt(RetValue))); 6707 g_signal_connect(PGtkObject(AButton), 'clicked', 6708 TGtkSignalFunc(@MessageButtonClicked), @ADialogResult); 6709 gtk_container_add (PGtkContainer(PGtkDialog(Dialog)^.action_area), AButton); 6710 end; 6711 6712begin 6713 ButtonCount:= 0; 6714 { Determine which is the default button } 6715 DefButton:= ((uType and $00000300) shr 8) + 1; 6716 //DebugLn('Trace:Default button is ' + IntToStr(DefButton)); 6717 6718 ADialogResult:= 0; 6719 Dialog:= gtk_dialog_new; 6720 {$IFDEF DebugLCLComponents} 6721 DebugGtkWidgets.MarkCreated(Dialog,'TGtk2WidgetSet.MessageBox'); 6722 {$ENDIF} 6723 g_signal_connect(PGtkObject(Dialog), 'delete-event', TGtkSignalFunc(@MessageBoxClosed), @ADialogResult); 6724 gtk_window_set_default_size(PGtkWindow(Dialog), 100, 100); 6725 ALabel:= gtk_label_new(lpText); 6726 gtk_container_add (PGtkContainer(PGtkDialog(Dialog)^.vbox), ALabel); 6727 case (uType and $0000000F) of 6728 MB_OKCANCEL: 6729 begin 6730 CreateButton(PChar(rsMbOK), IDOK); 6731 CreateButton(PChar(rsMbCancel), IDCANCEL); 6732 end; 6733 MB_ABORTRETRYIGNORE: 6734 begin 6735 CreateButton(PChar(rsMbAbort), IDABORT); 6736 CreateButton(PChar(rsMbRetry), IDRETRY); 6737 CreateButton(PChar(rsMbIgnore), IDIGNORE); 6738 end; 6739 MB_YESNOCANCEL: 6740 begin 6741 CreateButton(PChar(rsMbYes), IDYES); 6742 CreateButton(PChar(rsMbNo), IDNO); 6743 CreateButton(PChar(rsMbCancel), IDCANCEL); 6744 end; 6745 MB_YESNO: 6746 begin 6747 CreateButton(PChar(rsMbYes), IDYES); 6748 CreateButton(PChar(rsMbNo), IDNO); 6749 end; 6750 MB_RETRYCANCEL: 6751 begin 6752 CreateButton(PChar(rsMbRetry), IDRETRY); 6753 CreateButton(PChar(rsMbCancel), IDCANCEL); 6754 end; 6755 else 6756 begin 6757 { We have no buttons to show. Create the default of OK button } 6758 CreateButton(PChar(rsMbOK), IDOK); 6759 end; 6760 end; 6761 gtk_window_set_title(PGtkWindow(Dialog), lpCaption); 6762 gtk_window_set_position(PGtkWindow(Dialog), GTK_WIN_POS_CENTER); 6763 gtk_window_set_modal(PGtkWindow(Dialog), true); 6764 gtk_widget_show_all(Dialog); 6765 while ADialogResult = 0 do begin 6766 Application.HandleMessage; 6767 end; 6768 DestroyConnectedWidget(Dialog,true); 6769 Result:= ADialogResult; 6770end; 6771 6772{------------------------------------------------------------------------------ 6773 Function: MoveToEx 6774 Params: none 6775 Returns: Nothing 6776 6777 6778 ------------------------------------------------------------------------------} 6779function TGtk2WidgetSet.MoveToEx(DC: HDC; X, Y: Integer; OldPoint: PPoint): Boolean; 6780var 6781 DevCtx: TGtkDeviceContext absolute DC; 6782begin 6783 Result := IsValidDC(DC); 6784 if Result then 6785 with DevCtx do 6786 begin 6787 if Assigned(OldPoint) then 6788 OldPoint^ := PenPos; 6789 PenPos := Point(X, Y) 6790 end; 6791end; 6792 6793function TGtk2WidgetSet.OffsetRgn(RGN: HRGN; nXOffset, nYOffset: Integer): Integer; 6794var 6795 GdkRGN: PGDKRegion; 6796begin 6797 if not IsValidGDIObject(RGN) then 6798 Exit(Error); 6799 6800 GdkRGN := {%H-}PGdiObject(RGN)^.GDIRegionObject; 6801 gdk_region_offset(GdkRGN, nXOffset, nYOffset); 6802 Result := RegionType(GdkRGN); 6803end; 6804 6805{------------------------------------------------------------------------------ 6806 Method: PaintRgn 6807 Params: DC: HDC; RGN: HRGN 6808 Returns: if the function succeeds 6809 6810 Paints the specified region by using the brush currently selected into the 6811 device context. 6812 ------------------------------------------------------------------------------} 6813function TGtk2WidgetSet.PaintRgn(DC: HDC; RGN: HRGN): Boolean; 6814var 6815 DevCtx: TGtkDeviceContext absolute DC; 6816 CurGdiBrush: PGdiObject; 6817 CurHBrush: HBRUSH absolute CurGdiBrush; 6818begin 6819 CurGdiBrush := DevCtx.CurrentBrush; 6820 Result := IsValidDC(DC) and IsValidGDIObject(RGN) and IsValidGDIObject(CurHBrush); 6821 if Result then 6822 Result := FillRgn(DC, RGN, CurHBrush); 6823end; 6824 6825{------------------------------------------------------------------------------ 6826 Function: PeekMessage 6827 Params: lpMsg - Where it should put the message 6828 Handle - Handle of the window (thread) 6829 wMsgFilterMin- Lowest MSG to grab 6830 wMsgFilterMax- Highest MSG to grab 6831 wRemoveMsg - Should message be pulled out of the queue 6832 6833 Returns: Boolean if an event was there 6834 ------------------------------------------------------------------------------} 6835function TGtk2WidgetSet.PeekMessage(var lpMsg: TMsg; Handle : HWND; 6836 wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): Boolean; 6837var 6838 vlItem : TGtkMessageQueueItem; 6839begin 6840 //TODO Filtering 6841 fMessageQueue.Lock; 6842 try 6843 vlItem := fMessageQueue.FirstMessageItem; 6844 Result := vlItem <> nil; 6845 if Result then begin 6846 lpMsg := vlItem.Msg^; 6847 if (wRemoveMsg and PM_REMOVE) = PM_REMOVE then 6848 fMessageQueue.RemoveMessage(vlItem,FPMF_Internal,true); 6849 end; 6850 finally 6851 fMessageQueue.UnLock; 6852 end; 6853end; 6854 6855{------------------------------------------------------------------------------ 6856 Method: PolyBezier 6857 Params: DC, Points, NumPts, Filled, Continous 6858 Returns: Boolean 6859 6860 Use Polybezier to draw cubic Bézier curves. The first curve is drawn from the 6861 first point to the fourth point with the second and third points being the 6862 control points. If the Continuous flag is TRUE then each subsequent curve 6863 requires three more points, using the end-point of the previous Curve as its 6864 starting point, the first and second points being used as its control points, 6865 and the third point its end-point. If the continous flag is set to FALSE, 6866 then each subsequent Curve requires 4 additional points, which are used 6867 excatly as in the first curve. Any additonal points which do not add up to 6868 a full bezier(4 for Continuous, 3 otherwise) are ingored. There must be at 6869 least 4 points for an drawing to occur. If the Filled Flag is set to TRUE 6870 then the resulting Poly-Bézier will be drawn as a Polygon. 6871 6872 ------------------------------------------------------------------------------} 6873function TGtk2WidgetSet.PolyBezier(DC: HDC; Points: PPoint; NumPts: Integer; 6874 Filled, Continuous: boolean): boolean; 6875begin 6876 Result := inherited PolyBezier(DC, Points, NumPts, Filled, Continuous); 6877end; 6878 6879{------------------------------------------------------------------------------ 6880 Method: TGtk2WidgetSet.Polygon 6881 Params: DC: HDC; Points: ^TPoint; NumPts: integer; Winding: Boolean; 6882 Returns: Nothing 6883 6884 Use Polygon to draw a closed, many-sided shape on the canvas, using the value 6885 of Pen. After drawing the complete shape, Polygon fills the shape using the 6886 value of Brush. 6887 The Points parameter is an array of points that give the vertices of the 6888 polygon. 6889 Winding determines how the polygon is filled. When Winding is True, Polygon 6890 fills the shape using the Winding fill algorithm. When Winding is False, 6891 Polygon uses the even-odd (alternative) fill algorithm. 6892 NumPts indicates the number of points to use. 6893 The first point is always connected to the last point. 6894 To draw a polygon on the canvas, without filling it, use the Polyline method, 6895 specifying the first point a second time at the end. 6896} 6897function TGtk2WidgetSet.Polygon(DC: HDC; Points: PPoint; NumPts: Integer; 6898 Winding: boolean): boolean; 6899var 6900 DevCtx: TGtkDeviceContext absolute DC; 6901 i: integer; 6902 PointArray: PGDKPoint; 6903 Tmp, RGN : hRGN; 6904 ClipRect : TRect; 6905 DCOrigin: TPoint; 6906 OldNumPts: integer; 6907 ThePoints: array of types.TPoint; 6908 PThePoints: PPoint; 6909begin 6910 if not IsValidDC(DC) then Exit(False); 6911 6912 if NumPts <= 0 then Exit(True); 6913 6914 //Create a copy of the points so we can freely alter them 6915 SetLength(ThePoints{%H-}, NumPts); 6916 for i := 0 to NumPts - 1 do ThePoints[i] := Points[i]; 6917 PThePoints := @ThePoints[0]; 6918 6919 DCOrigin := DevCtx.Offset; 6920 OldNumPts := NumPts; 6921 6922 // create the PointsArray, which is a copy of Points moved by the DCOrigin 6923 // only if needed 6924 if DevCtx.IsNullPen and DevCtx.IsNullBrush then 6925 PointArray := nil 6926 else 6927 begin 6928 GetMem(PointArray, SizeOf(TGdkPoint) * (NumPts + 1)); // +1 for return line 6929 for i := 0 to NumPts - 1 do 6930 begin 6931 if DevCtx.HasTransf then 6932 ThePoints[I] := DevCtx.TransfPointIndirect(ThePoints[I]); 6933 PointArray[i].x := ThePoints[I].x + DCOrigin.X; 6934 PointArray[i].y := ThePoints[I].y + DCOrigin.Y; 6935 end; 6936 6937 if (Points[NumPts-1].X <> Points[0].X) or 6938 (Points[NumPts-1].Y <> Points[0].Y) then 6939 begin 6940 // add last point to return to first 6941 PointArray[NumPts].x := PointArray[0].x; 6942 PointArray[NumPts].y := PointArray[0].y; 6943 Inc(NumPts); 6944 end; 6945 end; 6946 6947 // first draw interior in brush color 6948 6949 {$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF} 6950 if not DevCtx.IsNullBrush then 6951 begin 6952 if Winding then 6953 begin 6954 // store old clipping 6955 Tmp := CreateEmptyRegion; 6956 GetClipRGN(DC, Tmp); 6957 // apply new clipping 6958 RGN := CreatePolygonRgn(PThePoints, OldNumPts, LCLType.Winding); 6959 ExtSelectClipRGN(DC, RGN, RGN_AND); 6960 DeleteObject(RGN); 6961 GetClipBox(DC, @ClipRect); 6962 6963 // draw polygon area 6964 DevCtx.FillRect(ClipRect, HBrush({%H-}PtrUInt(DevCtx.GetBrush)), False); 6965 // restore old clipping 6966 SelectClipRGN(DC, Tmp); 6967 DeleteObject(Tmp); 6968 end else 6969 begin 6970 DevCtx.SelectBrushProps; 6971 DevCtx.RemovePixbuf; 6972 gdk_draw_polygon(DevCtx.Drawable, DevCtx.GC, 1, PointArray, NumPts); 6973 end; 6974 end; 6975 6976 // draw outline 6977 if not DevCtx.IsNullPen 6978 then begin 6979 DevCtx.SelectPenProps; 6980 DevCtx.RemovePixbuf; 6981 gdk_draw_polygon(DevCtx.Drawable, DevCtx.GC, 0, PointArray, NumPts); 6982 end; 6983 6984 {$IFDEF DebugGDKTraps}EndGDKErrorTrap;{$ENDIF} 6985 6986 if PointArray <> nil then FreeMem(PointArray); 6987 SetLength(ThePoints,0); 6988 Result := True; 6989end; 6990 6991 6992function TGtk2WidgetSet.Polyline(DC: HDC; Points: PPoint; NumPts: Integer): boolean; 6993var 6994 DevCtx: TGtkDeviceContext absolute DC; 6995 6996 i: integer; 6997 PointArray: PGDKPoint; 6998 DCOrigin, P: TPoint; 6999begin 7000 if not IsValidDC(DC) then Exit(False); 7001 7002 if NumPts <= 0 then Exit(True); 7003 if DevCtx.IsNullPen then Exit(True); 7004 7005 DCOrigin := DevCtx.Offset; 7006 7007 GetMem(PointArray, SizeOf(TGdkPoint)*NumPts); 7008 for i:=0 to NumPts-1 do 7009 begin 7010 if DevCtx.HasTransf then 7011 P := DevCtx.TransfPointIndirect(Points[I]) 7012 else 7013 P := Points[i]; 7014 PointArray[i].x := P.x + DCOrigin.X; 7015 PointArray[i].y := P.y + DCOrigin.Y; 7016 end; 7017 7018 // draw line 7019 DevCtx.SelectPenProps; 7020 Result := dcfPenSelected in DevCtx.Flags; 7021 if Result and not DevCtx.IsNullPen 7022 then begin 7023 {$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF} 7024 DevCtx.RemovePixbuf; 7025 gdk_draw_lines(DevCtx.Drawable, DevCtx.GC, PointArray, NumPts); 7026 {$IFDEF DebugGDKTraps}EndGDKErrorTrap;{$ENDIF} 7027 end; 7028 7029 FreeMem(PointArray); 7030end; 7031 7032{------------------------------------------------------------------------------ 7033 Function: PostMessage 7034 Params: Handle: 7035 Msg: 7036 wParam: 7037 lParam: 7038 Returns: True if succesful 7039 7040 The PostMessage function places (posts) a message in the message queue and 7041 then returns without waiting. 7042 ------------------------------------------------------------------------------} 7043function TGtk2WidgetSet.PostMessage(Handle: HWND; Msg: Cardinal; wParam: WParam; 7044 lParam: LParam): Boolean; 7045 7046 function ParentPaintMessageInQueue: boolean; 7047 var 7048 Target: TControl; 7049 Parent: TWinControl; 7050 ParentHandle: hWnd; 7051 begin 7052 Result:=false; 7053 Target:=TControl(GetLCLObject({%H-}Pointer(Handle))); 7054 if not (Target is TControl) then exit; 7055 Parent:=Target.Parent; 7056 if (Target is TControl) then begin 7057 Parent:=Target.Parent; 7058 while Parent<>nil do begin 7059 ParentHandle:=Parent.Handle; 7060 if fMessageQueue.FindPaintMessage(ParentHandle)<>nil then begin 7061 Result:=true; 7062 end; 7063 Parent:=Parent.Parent; 7064 end; 7065 end; 7066 end; 7067 7068 procedure CombinePaintMessages(NewMsg:PMsg); 7069 // combine NewMsg and OldMsg paint message into NewMsg and free OldMsg 7070 var 7071 vlItem : TGtkMessageQueueItem; 7072 NewData: TLMGtkPaintData; 7073 OldData: TLMGtkPaintData; 7074 OldMsg : PMsg; 7075 begin 7076 vlItem := fMessageQueue.FindPaintMessage(NewMsg^.Hwnd); 7077 if vlItem = nil then exit; 7078 OldMsg := vlItem.Msg; 7079 if OldMsg = nil then exit; 7080 if (NewMsg^.Message = LM_PAINT) or (OldMsg^.Message = LM_PAINT) then 7081 begin 7082 // LM_PAINT means: repaint all 7083 // convert NewMsg into a LM_PAINT if not already done 7084 if NewMsg^.Message <> LM_PAINT then 7085 begin 7086 FinalizePaintTagMsg(NewMsg); 7087 NewMsg^.Message:=LM_PAINT; 7088 end; 7089 end 7090 else 7091 if (NewMsg^.Message <> LM_GTKPAINT) then 7092 RaiseGDBException('CombinePaintMessages A unknown paint message') 7093 else 7094 if (OldMsg^.Message<>LM_GtkPAINT) then 7095 RaiseGDBException('CombinePaintMessages B unknown paint message') 7096 else 7097 begin 7098 // combine the two LM_GtkPAINT messages 7099 NewData := TLMGtkPaintData(NewMsg^.WParam); 7100 OldData := TLMGtkPaintData(OldMsg^.WParam); 7101 NewData.RepaintAll := NewData.RepaintAll or OldData.RepaintAll; 7102 if not NewData.RepaintAll then 7103 begin 7104 NewData.Rect.Left := Min(NewData.Rect.Left, OldData.Rect.Left); 7105 NewData.Rect.Top := Min(NewData.Rect.Top, OldData.Rect.Top); 7106 NewData.Rect.Right := Max(NewData.Rect.Right, OldData.Rect.Right); 7107 NewData.Rect.Bottom := Max(NewData.Rect.Bottom, OldData.Rect.Bottom); 7108 end; 7109 end; 7110 fMessageQueue.RemoveMessage(vlItem, FPMF_All, True); 7111 end; 7112 7113var 7114 AMessage: PMsg; 7115begin 7116 Result := True; 7117 7118 //debugln(['TGtk2WidgetSet.PostMessage ',dbgsname(GetLCLObject(Pointer(Handle)))]); 7119 New(AMessage); 7120 FillByte(AMessage^,SizeOf(TMsg),0); 7121 AMessage^.HWnd := Handle; // this is normally the main gtk widget 7122 AMessage^.Message := Msg; 7123 AMessage^.WParam := WParam; 7124 AMessage^.LParam := LParam; 7125 7126 FMessageQueue.Lock; 7127 try 7128 if (AMessage^.Message = LM_PAINT) or (AMessage^.Message = LM_GTKPAINT) then 7129 begin 7130 { Obsolete, because InvalidateRectangle now works. 7131 7132 // paint messages are the most expensive messages in the LCL 7133 // A paint message to a control will also repaint all child controls. 7134 // -> check if there is already a paint message for one of its parents 7135 // if yes, then skip this message 7136 if ParentPaintMessageInQueue then begin 7137 FinalizePaintTagMsg(AMessage^); 7138 exit; 7139 end;} 7140 7141 // delete old paint message to this widget, 7142 // so that the widget repaints only once 7143 7144 CombinePaintMessages(AMessage); 7145 end; 7146 7147 FMessageQueue.AddMessage(AMessage); 7148 7149 {$IFDEF USE_GTK_MAIN_OLD_ITERATION} 7150 if GetCurrentThreadId <> MainThreadID then 7151 begin 7152 // awake gtk loop 7153 // when the main thread is currently processing messages it will process 7154 // fMessageQueue. 7155 // But when the main thread is waiting for the next gtk message it will 7156 // wait for the next external event before processing fMessageQueue. 7157 // A g_idle_add can only be used if glib multithreading has been enabled 7158 // ToDo: Find out what we loose when enabling multithreading 7159 // or find another way to wake up the gtk loop 7160 {$IFDEF EnabledGtkThreading} 7161 gdk_flush(); 7162 g_main_context_wakeup(nil); 7163 {$ELSE} 7164 DebugLn(['TGtk2WidgetSet.PostMessage ToDo: wake up gtk']); 7165 {$ENDIF} 7166 end; 7167 {$ENDIF} 7168 finally 7169 FMessageQueue.UnLock; 7170 end; 7171 7172 {$IFNDEF USE_GTK_MAIN_OLD_ITERATION} 7173 if GetCurrentThreadId <> MainThreadID then 7174 begin 7175 // old glib versions needs another way to wake up. 7176 if (glib_major_version = 2) and 7177 (glib_minor_version < 24) and (FMainPoll <> nil) then 7178 FMainPoll^.revents := 1; 7179 g_main_context_wakeup(g_main_context_default); 7180 end; 7181 {$ENDIF} 7182end; 7183 7184{------------------------------------------------------------------------------ 7185 Function: PtInRegion 7186 Params: RGN: HRGN; X, Y: Integer 7187 Returns: True if the specified point is in the region. 7188 7189 Determines whether the specified point is inside the specified region. 7190 ------------------------------------------------------------------------------} 7191function TGtk2WidgetSet.PtInRegion(RGN: HRGN; X, Y: Integer): Boolean; 7192begin 7193 Result := False; 7194 if not IsValidGDIObject(RGN) then 7195 exit; 7196 if ({%H-}PGdiObject(RGN)^.GDIBitmapObject <> nil) or 7197 ({%H-}PGdiObject(RGN)^.GDIPixbufObject <> nil) or 7198 ({%H-}PGdiObject(RGN)^.GDIPixmapObject.Image <> nil) then 7199 begin 7200 // issue #27080 7201 Result := False; 7202 end else 7203 Result := gdk_region_point_in({%H-}PGdiObject(RGN)^.GDIRegionObject, X, Y); 7204end; 7205 7206{------------------------------------------------------------------------------ 7207 Method: RadialArc 7208 Params: DC, left, top, right, bottom, sx, sy, ex, ey 7209 Returns: Nothing 7210 7211 Use RadialArc to draw an elliptically curved line with the current Pen. The 7212 values sx,sy, and ex,ey represent the starting and ending radial-points 7213 between which the Arc is drawn. 7214------------------------------------------------------------------------------} 7215function TGtk2WidgetSet.RadialArc(DC: HDC; left, top, right, bottom, 7216 sx, sy, ex, ey: Integer): Boolean; 7217begin 7218 Result := inherited RadialArc(DC, left, top, right, bottom, sx, sy, ex, ey); 7219end; 7220 7221{------------------------------------------------------------------------------ 7222 Method: RadialChord 7223 Params: DC, x1, y1, x2, y2, sx, sy, ex, ey 7224 Returns: Nothing 7225 7226 Use RadialChord to draw a filled Chord-shape on the canvas. The values sx,sy, 7227 and ex,ey represent the starting and ending radial-points between which 7228 the bounding-Arc is drawn. 7229------------------------------------------------------------------------------} 7230function TGtk2WidgetSet.RadialChord(DC: HDC; x1, y1, x2, y2, 7231 sx, sy, ex, ey: Integer): Boolean; 7232begin 7233 Result := inherited RadialChord(DC, x1, y1, x2, y2, sx, sy, ex, ey); 7234end; 7235 7236{------------------------------------------------------------------------------ 7237 Function: RealizePalette 7238 Params: DC: HDC 7239 Returns: Nothing 7240 ------------------------------------------------------------------------------} 7241function TGtk2WidgetSet.RealizePalette(DC: HDC): Cardinal; 7242begin 7243 Result := 0; 7244 if IsValidDC(DC) 7245 then with TGtkDeviceContext(DC) do 7246 begin 7247 7248 end; 7249end; 7250 7251{------------------------------------------------------------------------------ 7252 Function: Rectangle 7253 Params: DC: HDC; X1, Y1, X2, Y2: Integer 7254 Returns: Nothing 7255 ------------------------------------------------------------------------------} 7256function TGtk2WidgetSet.Rectangle(DC: HDC; X1, Y1, X2, Y2: Integer): Boolean; 7257var 7258 DevCtx: TGtkDeviceContext absolute DC; 7259 7260 Left, Top, Width, Height: Integer; 7261 DCOrigin: TPoint; 7262 Brush: PGdiObject; 7263 ClipArea: TGdkRectangle; 7264begin 7265 if not IsValidDC(DC) then Exit(False); 7266 7267 if DevCtx.HasTransf then 7268 DevCtx.TransfRect(X1, Y1, X2, Y2); 7269 7270 CalculateLeftTopWidthHeight(X1, Y1, X2, Y2, Left, Top, Width, Height); 7271 if (Width = 0) or (Height = 0) then Exit(True); 7272 // X2, Y2 is not part of the rectangle 7273 dec(Width); 7274 dec(Height); 7275 7276 // first draw interior in brush color 7277 DevCtx.SelectBrushProps; 7278 DCOrigin := DevCtx.Offset; 7279 7280 {$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF} 7281 7282 if not DevCtx.IsNullBrush then 7283 begin 7284 ClipArea := DevCtx.ClipRect; 7285 Brush := DevCtx.GetBrush; 7286 DevCtx.RemovePixbuf; 7287 if (Brush^.GDIBrushFill = GDK_SOLID) and 7288 (IsBackgroundColor(TColor(Brush^.GDIBrushColor.ColorRef))) 7289 then 7290 StyleFillRectangle(DevCtx.Drawable, DevCtx.GC, Brush^.GDIBrushColor.ColorRef, 7291 Left+DCOrigin.X, Top+DCOrigin.Y, Width, Height, @ClipArea) 7292 else 7293 gdk_draw_rectangle(DevCtx.Drawable, DevCtx.GC, 1, 7294 Left+DCOrigin.X, Top+DCOrigin.Y, Width, Height); 7295 end; 7296 7297 // Draw outline 7298 DevCtx.SelectPenProps; 7299 Result := dcfPenSelected in DevCtx.Flags; 7300 if Result and not DevCtx.IsNullPen 7301 then begin 7302 DevCtx.RemovePixbuf; 7303 gdk_draw_rectangle(DevCtx.Drawable, DevCtx.GC, 0, 7304 Left+DCOrigin.X, Top+DCOrigin.Y, Width, Height); 7305 end; 7306 7307 {$IFDEF DebugGDKTraps}EndGDKErrorTrap;{$ENDIF} 7308end; 7309 7310{------------------------------------------------------------------------------ 7311 Function: RectInRegion 7312 Params: RGN: HRGN; ARect: TRect 7313 Returns: True if any part of the specified rectangle lies within the 7314 boundaries of the region. 7315 7316 Determines whether any part of the specified rectangle is within the boundaries 7317 of a region. 7318 7319 ------------------------------------------------------------------------------} 7320function TGtk2WidgetSet.RectInRegion(RGN: HRGN; ARect: TRect): Boolean; 7321var 7322 AGdkRect: TGdkRectangle; 7323begin 7324 //todo: sanity checks for valid handle etc. 7325 AGdkRect := GdkRectFromRect(ARect); 7326 Result := gdk_region_rect_in({%H-}PGdiObject(RGN)^.GDIRegionObject, @AGdkRect) 7327 <> GDK_OVERLAP_RECTANGLE_OUT; 7328end; 7329 7330{------------------------------------------------------------------------------ 7331 Function: RectVisible 7332 Params: dc : hdc; ARect: TRect 7333 Returns: True if ARect is not completely clipped away. 7334 ------------------------------------------------------------------------------} 7335function TGtk2WidgetSet.RectVisible(dc: hdc; const ARect: TRect): Boolean; 7336begin 7337 Result := inherited RectVisible(dc,ARect); 7338end; 7339 7340{------------------------------------------------------------------------------ 7341 Function: RegroupMenuItem 7342 Params: hndMenu: HMENU; GroupIndex: integer 7343 Returns: Nothing 7344 7345 Move a menuitem into its group 7346 This function is called by the LCL, after some menuitems were regrouped to 7347 GroupIndex. The hndMenu is one of them. 7348 Update all radio groups. 7349 ------------------------------------------------------------------------------} 7350function TGtk2WidgetSet.RegroupMenuItem(hndMenu: HMENU; GroupIndex: integer 7351 ): Boolean; 7352 7353const 7354 GROUPIDX_DATANAME = 'GroupIndex'; 7355 7356 function GetGroup: PGSList; 7357 var 7358 Item, orgList: PGList; 7359 parent : PGTKWidget; 7360 begin 7361 Result := nil; 7362 parent := gtk_widget_get_parent({%H-}Pointer(hndMenu)); 7363 if parent = nil then Exit; 7364 7365 Item := gtk_container_get_children(PGTKContainer(parent)); 7366 orgList := Item; 7367 while Item <> nil do 7368 begin 7369 if (Item^.Data <> {%H-}Pointer(hndMenu)) // exclude ourself 7370 and gtk_is_radio_menu_item(Item^.Data) 7371 and (GroupIndex = Integer({%H-}PtrUInt(g_object_get_data(Item^.Data, GROUPIDX_DATANAME)))) 7372 then begin 7373 Result := gtk_radio_menu_item_get_group (PGtkRadioMenuItem(Item^.Data)); 7374 Exit; 7375 end; 7376 Item := Item^.Next; 7377 end; 7378 if Assigned(orgList) then 7379 g_list_free(orgList); 7380 end; 7381 7382var 7383 RadioGroup: PGSList; 7384 //CurrentGroupIndex: Integer; 7385begin 7386 Result := False; 7387 7388 if not gtk_is_radio_menu_item({%H-}Pointer(hndMenu)) 7389 then begin 7390 DebugLn('WARNING: TGtk2WidgetSet.RegroupMenuItem: handle is not a GTK_RADIO_MENU_ITEM'); 7391 Exit; 7392 end; 7393 7394 //CurrentGroupIndex := integer({%H-}PtrUInt(g_object_get_data({%H-}Pointer(hndMenu), GROUPIDX_DATANAME))); 7395 7396 // Update needed ? 7397 { if GroupIndex = CurrentGroupIndex 7398 then begin 7399 Result := True; 7400 Exit; 7401 end;} 7402 7403 // Remove current group 7404 gtk_radio_menu_item_set_group({%H-}PGtkRadioMenuItem(hndMenu), nil); 7405 g_object_set_data({%H-}Pointer(hndMenu), GROUPIDX_DATANAME, nil); 7406 7407 // Check remove only 7408 { if GroupIndex = 0 7409 then begin 7410 Result := True; 7411 Exit; 7412 end; } 7413 7414 // Try to find new group 7415 RadioGroup := GetGroup; 7416 7417 // Set new group 7418 g_object_set_data({%H-}Pointer(hndMenu), GROUPIDX_DATANAME, {%H-}Pointer(PtrInt(GroupIndex))); 7419 if RadioGroup = nil 7420 then begin 7421 // We're the only member, get a group 7422 RadioGroup := gtk_radio_menu_item_group({%H-}PGtkRadioMenuItem(hndMenu)) 7423 end 7424 else begin 7425 gtk_radio_menu_item_set_group({%H-}PGtkRadioMenuItem(hndMenu), RadioGroup); 7426 end; 7427 //radiogroup^.data 7428 //radiogroup^.next 7429 // Refetch newgroup list 7430 RadioGroup := gtk_radio_menu_item_group({%H-}PGtkRadioMenuItem(hndMenu)); 7431 // Update checks 7432 UpdateRadioGroupChecks(RadioGroup); 7433 Result := True; 7434end; 7435 7436 7437{------------------------------------------------------------------------------ 7438 Function: ReleaseCapture 7439 Params: none 7440 Returns: True if succesful 7441 7442 The ReleaseCapture function releases the mouse capture from a window 7443 and restores normal mouse input processing. 7444 ------------------------------------------------------------------------------} 7445function TGtk2WidgetSet.ReleaseCapture: Boolean; 7446begin 7447 SetCapture(0); 7448 Result := True; 7449end; 7450 7451function TGtk2WidgetSet.ReleaseDC(hWnd: HWND; DC: HDC): Integer; 7452var 7453 aDC, pSavedDC: TGtkDeviceContext; 7454 g: TGDIType; 7455 CurGDIObject: PGDIObject; 7456begin 7457 //DebugLn(['[TGtk2WidgetSet.ReleaseDC] ',DC,' ',FDeviceContexts.Count]); 7458 Result := 0; 7459 7460 if (DC <> 0) 7461 then begin 7462 if FDeviceContexts.Contains({%H-}Pointer(DC)) 7463 then begin 7464 aDC := TGtkDeviceContext(DC); 7465 7466 // clear references to all GDI objects 7467 for g:=Low(TGDIType) to high(TGDIType) do begin 7468 {if aDC.GDIObjects[g]<>nil then 7469 if FindDCWithGDIObject(aDC.GDIObjects[g])=nil then 7470 RaiseGDBException('');} 7471 aDC.GDIObjects[g]:=nil; // clear the reference, decrease DCCount 7472 end; 7473 7474 // Release all saved device contexts (the owned GDI objects will be freed) 7475 pSavedDC:=aDC.SavedContext; 7476 if pSavedDC<>nil then begin 7477 ReleaseDC(0,HDC(pSavedDC)); 7478 aDC.SavedContext:=nil; 7479 end; 7480 7481 //DebugLn(['TGtk2WidgetSet.ReleaseDC DC=',dbgs(TGtkDeviceContext(aDC)),' ClipRegion=',dbgs(aDC.ClipRegion)]); 7482 // free all owned GDI objects 7483 for g:=Low(TGDIType) to high(TGDIType) do begin 7484 CurGDIObject:=aDC.OwnedGDIObjects[g]; 7485 if CurGDIObject<>nil then begin 7486 if CurGDIObject^.Owner<>aDC then 7487 RaiseGDBException(''); 7488 DeleteObject(HGDIOBJ({%H-}PtrUInt(CurGDIObject))); 7489 if aDC.OwnedGDIObjects[g]<>nil then 7490 RaiseGDBException(''); 7491 end; 7492 end; 7493 7494 //DebugLn(['TGtk2WidgetSet.ReleaseDC DC=',dbghex(PtrInt(DC)),' Font=',dbghex(PtrInt(aDC.CurrentFont))]); 7495 7496 {FreeGDIColor(aDC.CurrentTextColor); 7497 FreeGDIColor(aDC.CurrentBackColor);} 7498 7499 try 7500 { On root window, we don't allocate a graphics context and so we do not free} 7501 if aDC.HasGC then 7502 begin 7503 gdk_gc_unref(aDC.GC); 7504 aDC.GC:=nil; 7505 end; 7506 except 7507 on E:Exception do begin 7508 // Nothing, just try to unref it 7509 // (it segfaults if the window doesnt exist anymore :-) 7510 DebugLn('TGtk2WidgetSet.ReleaseDC: ',E.Message); 7511 end; 7512 end; 7513 7514 DisposeDC(aDC); 7515 Result := 1; 7516 end; 7517 end; 7518end; 7519 7520{------------------------------------------------------------------------------ 7521 Function: RemoveProp 7522 Params: Handle: Handle of the object 7523 Str: Name of the property to remove 7524 Returns: The handle of the property (0=failure) 7525 7526 ------------------------------------------------------------------------------} 7527function TGtk2WidgetSet.RemoveProp(Handle: hwnd; Str: PChar): THandle; 7528begin 7529 g_object_set_data({%H-}PGObject(handle), Str, nil); 7530 Result := 1; 7531end; 7532 7533{------------------------------------------------------------------------------ 7534 Function: RestoreDC 7535 Params: none 7536 Returns: Nothing 7537 7538 7539-------------------------------------------------------------------------------} 7540function TGtk2WidgetSet.RestoreDC(DC: HDC; SavedDC: Integer): Boolean; 7541var 7542 DevCtx: TGtkDeviceContext absolute DC; 7543 SavedDevCtx: TGtkDeviceContext; 7544begin 7545 if not IsValidDC(DC) then Exit(False); 7546 if SavedDC <= 0 then Exit(False); 7547 repeat 7548 SavedDevCtx := DevCtx.SavedContext; 7549 Dec(SavedDC); 7550 7551 // TODO copy bitmap too 7552 // clear the GDIObjects in pSavedDC, so they are not freed by DeleteDC 7553 Result := DevCtx.CopyDataFrom(SavedDevCtx, True, True, True); 7554 DevCtx.SavedContext := SavedDevCtx.SavedContext; 7555 SavedDevCtx.SavedContext := nil; 7556 DevCtx.SelectRegion; 7557 7558 // free saved DC 7559 DeleteDC(HDC(SavedDevCtx)); 7560 until SavedDC <= 0; 7561end; 7562 7563{------------------------------------------------------------------------------ 7564 Method: RoundRect 7565 Params: X1, Y1, X2, Y2, RX, RY 7566 Returns: If succesfull 7567 7568 Draws a Rectangle with optional rounded corners. RY is the radial height 7569 of the corner arcs, RX is the radial width. If either is less than or equal to 7570 0, the routine simly calls to standard Rectangle. 7571 ------------------------------------------------------------------------------} 7572function TGtk2WidgetSet.RoundRect(DC : hDC; X1, Y1, X2, Y2: Integer; 7573 RX,RY : Integer): Boolean; 7574begin 7575 Result := inherited RoundRect(DC, X1, Y1, X2, Y2, RX, RY); 7576end; 7577 7578{------------------------------------------------------------------------------ 7579 Function: SaveDc 7580 Params: DC: a DC to save 7581 Returns: 0 if the functions fails otherwise a positive integer identifing 7582 the saved DC 7583 7584 The SaveDC function saves the current state of the specified device 7585 context (DC) by copying its elements to a context stack. 7586-------------------------------------------------------------------------------} 7587function TGtk2WidgetSet.SaveDC(DC: HDC): Integer; 7588var 7589 DevCtx: TGtkDeviceContext absolute DC; 7590 aSavedDC: TGtkDeviceContext; 7591begin 7592 Result := 0; 7593 if IsValidDC(DC) then 7594 begin 7595 aSavedDC := NewDC; 7596 aSavedDC.CopyDataFrom(DevCtx, False, True, False); 7597 aSavedDC.SavedContext := DevCtx.SavedContext; 7598 DevCtx.SavedContext:= aSavedDC; 7599 Result := 1; 7600 end; 7601end; 7602 7603{------------------------------------------------------------------------------ 7604 Function: ScreenToClient 7605 Params: Handle: 7606 P: 7607 Returns: 7608 7609 ------------------------------------------------------------------------------} 7610function TGtk2WidgetSet.ScreenToClient(Handle : HWND; var P : TPoint) : Integer; 7611var 7612 X, Y: Integer; 7613 Widget: PGTKWidget; 7614 Window: PGdkWindow; 7615Begin 7616 if Handle = 0 then 7617 begin 7618 X := 0; 7619 Y := 0; 7620 end else 7621 begin 7622 Widget := GetFixedWidget({%H-}pgtkwidget(Handle)); 7623 if Widget = nil then 7624 Widget := {%H-}pgtkwidget(Handle); 7625 if Widget = nil then 7626 begin 7627 X := 0; 7628 Y := 0; 7629 end else 7630 begin 7631 Window := GetControlWindow(Widget); 7632 {$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF} 7633 if Window <> nil then 7634 begin 7635 gdk_window_get_origin(Window, @X, @Y); 7636 // set pos to client coords. issue #21366 7637 if GTK_WIDGET_NO_WINDOW(Widget) and (gtk_widget_get_parent(Widget) <> nil) then 7638 begin 7639 P.X := P.X - X - Widget^.allocation.x; 7640 P.Y := P.Y - Y - Widget^.allocation.y; 7641 Result := -1; 7642 exit; 7643 end; 7644 7645 end else 7646 begin 7647 X:=0; 7648 Y:=0; 7649 end; 7650 {$IFDEF DebugGDKTraps}EndGDKErrorTrap;{$ENDIF} 7651 end; 7652 end; 7653 7654 //DebugLn('[TGtk2WidgetSet.ScreenToClient] ',x,',',y,' P=',P.X,',',P.Y); 7655 dec(P.X, X); 7656 dec(P.Y, Y); 7657 Result := -1; 7658end; 7659 7660{------------------------------------------------------------------------------ 7661 Function: ScrollWindowEx 7662 Params: hWnd: handle of window to scroll 7663 dx: horizontal amount to scroll 7664 dy: vertical amount to scroll 7665 prcScroll: pointer to scroll rectangle 7666 prcClip: pointer to clip rectangle 7667 hrgnUpdate: handle of update region 7668 prcUpdate: pointer to update rectangle 7669 flags: scrolling flags 7670 7671 Returns: True if succesfull; 7672 7673 The ScrollWindowEx function scrolls the content of the specified window's 7674 client area 7675 ------------------------------------------------------------------------------} 7676function TGtk2WidgetSet.ScrollWindowEx(hWnd: HWND; dx, dy: Integer; prcScroll, prcClip: PRect; hrgnUpdate: HRGN; prcUpdate: PRect; flags: UINT): Boolean; 7677var 7678 Widget: PGtkWidget; 7679 Window: PGdkWindow; 7680 {$ifdef GTK_2_8} 7681 Region: PGdkRegion; 7682 RClient, RFullSource, RUsableSource, RTarget, RUsableTarget: TRect; 7683 Rect1: TGdkRectangle; 7684 Rect2: TRect; // area to invalidate 7685 WidgetInfo: PWidgetInfo; 7686 {$ENDIF} 7687begin 7688 Result := False; 7689 if (dy = 0) and (dx = 0) then exit; 7690 {$IFDEF DisableGtk2ScrollWindow} 7691 exit; 7692 {$ENDIF} 7693 // prcScroll, prcClip are not supported under gdk yet 7694 if (hWnd = 0) then 7695 exit; 7696 // or (prcScroll <> nil) or (prcClip <> nil) then Exit; 7697 7698 Widget := {%H-}pgtkwidget(hWnd); 7699 Widget := GetFixedWidget(Widget); 7700 if Widget = nil then exit; 7701 Window:=GetControlWindow(Widget); 7702 if Window = nil then exit; 7703 7704 Result := true; 7705 7706 {$ifdef GTK_2_8} 7707 RClient.Left := 0;//Widget^.Allocation.Left; 7708 RClient.Top := 0; //Widget^.Allocation.Top; 7709 RClient.Right := Widget^.Allocation.width; 7710 RClient.Bottom := Widget^.Allocation.height; 7711 RFullSource := RClient; 7712 {$ifdef VerboseScrollWindowEx} 7713 DebugLn(['ScrollWindowEx A RClient=', dbgs(RClient),' dy=',dy, ' scroll=',dbgs(prcScroll^), ' clip=',dbgs(prcClip^)]); 7714 {$ENDIF} 7715 7716 // Any part of RFullSource, that is not targeted by the move must later be invalidated 7717 if PrcScroll <> nil then 7718 begin 7719 RFullSource.Left := Max(RClient.Left, PrcScroll^.Left); 7720 RFullSource.Top := Max(RClient.Top, PrcScroll^.Top); 7721 RFullSource.Right := Min(RClient.Right, PrcScroll^.Right); 7722 RFullSource.Bottom := Min(RClient.Bottom, PrcScroll^.Bottom); 7723 end; 7724 7725 // Target is expected to be completly filled with valid content by move, 7726 // any part that can not be filled must be invalidated 7727 RTarget.Left := Max(RClient.Left, RFullSource.Left + dx); 7728 RTarget.Top := Max(RClient.Top, RFullSource.Top + dy); 7729 RTarget.Right := Min(RClient.Right, RFullSource.Right + dx); 7730 RTarget.Bottom := Min(RClient.Bottom, RFullSource.Bottom + dy); 7731 if (PrcClip <> nil) then begin 7732 RTarget.Left := Max(RTarget.Left, prcClip^.Left); 7733 RTarget.Top := Max(RTarget.Top, prcClip^.Top); 7734 RTarget.Right := Min(RTarget.Right, prcClip^.Right); 7735 RTarget.Bottom := Min(RTarget.Bottom, prcClip^.Bottom); 7736 end; 7737 7738 // Only Source that will fit into target 7739 RUsableSource.Left := Max(RTarget.Left - dx, RFullSource.Left); 7740 RUsableSource.Top := Max(RTarget.Top - dy, RFullSource.Top); 7741 RUsableSource.Right := Min(RTarget.Right - dx, RFullSource.Right); 7742 RUsableSource.Bottom := Min(RTarget.Bottom - dy, RFullSource.Bottom); 7743 {$ifdef VerboseScrollWindowEx} 7744 DebugLn(['ScrollWindowEx B RFullSource=', dbgs(RFullSource), ' RUsableSource=', dbgs(RUsableSource)]); 7745 {$ENDIF} 7746 7747 // And also, only Source that is valid 7748 WidgetInfo := GetWidgetInfo(Widget); 7749 if WidgetInfo <> nil then begin 7750 {$ifdef VerboseScrollWindowEx} 7751 DebugLn(['ScrollWindowEx C ', dbgs(WidgetInfo^.UpdateRect)]); 7752 {$ENDIF} 7753 // exclude allready invalidated area 7754 // "UpdateRect.Bottom > 0" => there is an UpdateRect / Top is valid 7755 if (dy < 0) and (WidgetInfo^.UpdateRect.Bottom > 0) then 7756 RUsableSource.Bottom := Min(RUsableSource.Bottom, WidgetInfo^.UpdateRect.Top); 7757 if (dy > 0) and (RUsableSource.Top < WidgetInfo^.UpdateRect.Bottom) then 7758 RUsableSource.Top := WidgetInfo^.UpdateRect.Bottom; 7759 7760 if (dx < 0) and (WidgetInfo^.UpdateRect.Right > 0) then 7761 RUsableSource.Right := Min(RUsableSource.Right, WidgetInfo^.UpdateRect.Left); 7762 if (dx > 0) and (RUsableSource.Left < WidgetInfo^.UpdateRect.Right) then 7763 RUsableSource.Left := WidgetInfo^.UpdateRect.Right; 7764 end; 7765 {$ifdef VerboseScrollWindowEx} 7766 DebugLn(['ScrollWindowEx D RUsableSource=', dbgs(RUsableSource)]); 7767 {$ENDIF} 7768 7769 // TODO: content moved into currently invalidated space, may reduce the inval rect 7770 // All of RUsableTarget should be validated; 7771 RUsableTarget.Left := Max(RTarget.Left, RUsableSource.Left + dx); 7772 RUsableTarget.Top := Max(RTarget.Top, RUsableSource.Top + dy); 7773 RUsableTarget.Right := Min(RTarget.Right, RUsableSource.Right + dx); 7774 RUsableTarget.Bottom := Min(RTarget.Bottom, RUsableSource.Bottom + dy); 7775 {$ifdef VerboseScrollWindowEx} 7776 DebugLn(['ScrollWindowEx D RUsableTarget=', dbgs(RUsableTarget)]); 7777 {$ENDIF} 7778 7779 Rect1 := GdkRectFromRect(RUsableSource); 7780 7781 if (Rect1.height > 0) and (Rect1.width > 0) then begin 7782 Region := gdk_region_rectangle(@Rect1); 7783 gdk_window_move_region(Window, Region, dx, dy); 7784 gdk_region_destroy(Region); 7785 7786 if (flags and SW_INVALIDATE) <> 0 then begin 7787 //invalidate 7788 If RUsableTarget.Left > RFullSource.Left then begin 7789 Rect2 := RFullSource; 7790 Rect2.Right:= RUsableTarget.Left; 7791 {$ifdef VerboseScrollWindowEx}DebugLn(['ScrollWindowEx Invalidate Src Left', dbgs(Rect2)]);{$ENDIF} 7792 InvalidateRect(hWnd, @Rect2, false); 7793 if (prcUpdate <> nil) and (dx > 0) then prcUpdate^ := Rect2; 7794 end; 7795 7796 If RUsableTarget.Right < RFullSource.Right then begin 7797 Rect2 := RFullSource; 7798 Rect2.Left:= RUsableTarget.Right; 7799 {$ifdef VerboseScrollWindowEx}DebugLn(['ScrollWindowEx Invalidate Src Right', dbgs(Rect2)]);{$ENDIF} 7800 InvalidateRect(hWnd, @Rect2, false); 7801 if (prcUpdate <> nil) and (dx < 0) then prcUpdate^ := Rect2; 7802 end; 7803 7804 If RUsableTarget.Top > RFullSource.Top then begin 7805 Rect2 := RFullSource; 7806 Rect2.Bottom:= RUsableTarget.Top; 7807 {$ifdef VerboseScrollWindowEx}DebugLn(['ScrollWindowEx Invalidate Src Top', dbgs(Rect2)]);{$ENDIF} 7808 InvalidateRect(hWnd, @Rect2, false); 7809 if (prcUpdate <> nil) and (dy > 0) then prcUpdate^ := Rect2; 7810 end; 7811 7812 If RUsableTarget.Bottom < RFullSource.Bottom then begin 7813 Rect2 := RFullSource; 7814 Rect2.Top:= RUsableTarget.Bottom; 7815 {$ifdef VerboseScrollWindowEx}DebugLn(['ScrollWindowEx Invalidate Src Bottom', dbgs(Rect2)]);{$ENDIF} 7816 InvalidateRect(hWnd, @Rect2, false); 7817 if (prcUpdate <> nil) and (dy < 0) then prcUpdate^ := Rect2; 7818 end; 7819 7820 7821 If RUsableTarget.Left > RTarget.Left then begin 7822 Rect2 := RTarget; 7823 Rect2.Right:= RUsableTarget.Left; 7824 {$ifdef VerboseScrollWindowEx}DebugLn(['ScrollWindowEx Invalidate TARGET Left', dbgs(Rect2)]);{$ENDIF} 7825 InvalidateRect(hWnd, @Rect2, false); 7826 end; 7827 7828 If RUsableTarget.Right < RTarget.Right then begin 7829 Rect2 := RTarget; 7830 Rect2.Left:= RUsableTarget.Right; 7831 {$ifdef VerboseScrollWindowEx}DebugLn(['ScrollWindowEx Invalidate TARGET Right', dbgs(Rect2)]);{$ENDIF} 7832 InvalidateRect(hWnd, @Rect2, false); 7833 end; 7834 7835 If RUsableTarget.Top > RTarget.Top then begin 7836 Rect2 := RTarget; 7837 Rect2.Bottom:= RUsableTarget.Top; 7838 {$ifdef VerboseScrollWindowEx}DebugLn(['ScrollWindowEx Invalidate TARGET Top', dbgs(Rect2)]);{$ENDIF} 7839 InvalidateRect(hWnd, @Rect2, false); 7840 end; 7841 7842 If RUsableTarget.Bottom < RTarget.Bottom then begin 7843 Rect2 := RTarget; 7844 Rect2.Top:= RUsableTarget.Bottom; 7845 {$ifdef VerboseScrollWindowEx}DebugLn(['ScrollWindowEx Invalidate TARGET Bottom', dbgs(Rect2)]);{$ENDIF} 7846 InvalidateRect(hWnd, @Rect2, false); 7847 end; 7848 end; 7849 end 7850 else begin 7851 if (flags and SW_INVALIDATE) <> 0 then begin 7852 // invalidate, nothing to scroll 7853 {$ifdef VerboseScrollWindowEx}DebugLn(['ScrollWindowEx Invalidate all', dbgs(RUsableSource)]);{$ENDIF} 7854 InvalidateRect(hWnd, @RFullSource, false); 7855 InvalidateRect(hWnd, @RTarget, false); 7856 end 7857 else 7858 Result := False; 7859 end; 7860 {$ELSE} 7861 gdk_window_scroll(Window, dx, dy); 7862 Result := true; 7863 {$ENDIF} 7864end; 7865 7866 7867{------------------------------------------------------------------------------ 7868 Function: SelectClipRGN 7869 Params: DC, RGN 7870 Returns: longint 7871 7872 Sets the DeviceContext's ClipRegion. The Return value 7873 is the new clip regions type, or ERROR. 7874 7875 The result can be one of the following constants 7876 Error 7877 NullRegion 7878 SimpleRegion 7879 ComplexRegion 7880 7881 ------------------------------------------------------------------------------} 7882function TGtk2WidgetSet.SelectClipRGN(DC: hDC; RGN: HRGN): Longint; 7883var 7884 DevCtx: TGtkDeviceContext absolute DC; 7885 7886 RegObj: PGdkRegion; 7887 DCOrigin: TPoint; 7888 OldClipRegion: PGDIObject; 7889begin 7890 if not IsValidDC(DC) then Exit(ERROR); 7891 7892 // clear old clipregion 7893 if Assigned(DevCtx.ClipRegion) then 7894 begin 7895 OldClipRegion := DevCtx.ClipRegion; 7896 DevCtx.ClipRegion := nil;// decrease DCCount 7897 if OldClipRegion = DevCtx.OwnedGDIObjects[gdiRegion] then 7898 DeleteObject(HGDIOBJ({%H-}PtrUInt(OldClipRegion))); 7899 end; 7900 7901 if RGN = 0 then 7902 begin 7903 DevCtx.SelectRegion; 7904 Exit(NULLREGION); 7905 end; 7906 7907 if IsValidGDIObject(RGN) then 7908 begin 7909 DevCtx.ClipRegion := {%H-}PGdiObject(CreateRegionCopy(RGN)); 7910 DevCtx.OwnedGDIObjects[gdiRegion] := DevCtx.ClipRegion; 7911 RegObj := DevCtx.ClipRegion^.GDIRegionObject; 7912 DCOrigin := DevCtx.Offset; 7913 7914 gdk_region_offset(RegObj, DCOrigin.x, DCOrigin.Y); 7915 DevCtx.SelectRegion; 7916 7917 Exit(RegionType(RegObj)); 7918 end; 7919 7920 // error handling 7921 Result := ERROR; 7922 DebugLn('WARNING: [TGtk2WidgetSet.SelectClipRGN] Invalid RGN'); 7923 {$ifdef TraceGdiCalls} 7924 DebugLn(); 7925 DebugLn('TraceCall for invalid object: '); 7926 DumpBackTrace(PgdiObject(RGN)^.StackAddrs); 7927 DebugLn(); 7928 {$endif} 7929end; 7930 7931{------------------------------------------------------------------------------ 7932 Function: SelectObject 7933 Params: none 7934 Returns: Nothing 7935 7936 7937 ------------------------------------------------------------------------------} 7938function TGtk2WidgetSet.SelectObject(DC: HDC; GDIObj: HGDIOBJ): HGDIOBJ; 7939 7940var 7941 DevCtx: TGtkDeviceContext absolute DC; 7942 GDIObject: PGdiObject absolute GDIObj; 7943 ResultObj: PGdiObject absolute Result; 7944 7945 7946 procedure RaiseInvalidGDIType; 7947 begin 7948 RaiseGDBException('TGtk2WidgetSet.SelectObject Invalid GDIType '+IntToStr(ord({%H-}PGdiObject(GDIObj)^.GDIType))); 7949 end; 7950 7951 {$ifdef DebugLCLComponents} 7952 procedure DebugInvalidDC; 7953 begin 7954 DebugLn(['TGtk2WidgetSet.SelectObject DC=',dbghex(DC),' IsValidDC(DC)=',IsValidDC(DC),' GDIObj=',dbghex(GDIObj)]); 7955 DumpStack; 7956 DebugLn(['DebugInvalidGDIObject DC:']); 7957 Debugln(DebugDeviceContexts.GetInfo(Pointer(DC),true)); 7958 end; 7959 7960 procedure DebugInvalidGDIObject; 7961 begin 7962 DebugLn(['TGtk2WidgetSet.SelectObject DC=',dbghex(DC),' GDIObj=',dbghex(GDIObj),' IsValidGDIObject(GDIObj)=',IsValidGDIObject(GDIObj)]); 7963 DumpStack; 7964 DebugLn(['DebugInvalidGDIObject GDIObj:']); 7965 Debugln(DebugGdiObjects.GetInfo(Pointer(GDIObj),true)); 7966 end; 7967 {$endif} 7968 7969begin 7970 Result := 0; 7971 7972 if not IsValidDC(DC) 7973 then begin 7974 {$ifdef DebugLCLComponents} 7975 DebugInvalidDC; 7976 {$endif} 7977 Exit; 7978 end; 7979 7980 if not IsValidGDIObject(GDIObj) 7981 then begin 7982 {$ifdef DebugLCLComponents} 7983 DebugInvalidGDIObject; 7984 {$endif} 7985 Exit; 7986 end; 7987 case GDIObject^.GDIType of 7988 gdiPen, 7989 gdiBitmap: 7990 ResultObj := DevCtx.SelectObject(GDIObject); 7991 7992 gdiBrush: begin 7993 ResultObj := DevCtx.GetBrush;// always create, because a valid GDIObject is needed to restore 7994 if DevCtx.CurrentBrush = GDIObject then Exit; 7995 7996 DevCtx.CurrentBrush := GDIObject; 7997 DevCtx.SelectedColors := dcscCustom; 7998 end; 7999 8000 gdiFont: begin 8001 ResultObj := DevCtx.GetFont;// always create, because a valid GDIObject is needed to restore 8002 if (DevCtx.CurrentFont = GDIObject) and not DevCtx.HasTransf then Exit; 8003 8004 DevCtx.CurrentFont := GDIObject; 8005 8006 DevCtx.SetTextMetricsValid(False); 8007 DevCtx.SelectedColors := dcscCustom; 8008 end; 8009 8010 gdiRegion: begin 8011 ResultObj := DevCtx.ClipRegion; 8012 if DevCtx.GC <> nil 8013 then SelectClipRGN(DC, GDIObj) 8014 else DevCtx.ClipRegion := nil; 8015 end; 8016 8017 else 8018 RaiseInvalidGDIType; 8019 end; 8020end; 8021 8022{------------------------------------------------------------------------------ 8023 Function: SelectPalette 8024 Params: none 8025 Returns: Nothing 8026 8027 8028 ------------------------------------------------------------------------------} 8029function TGtk2WidgetSet.SelectPalette(DC: HDC; Palette: HPALETTE; ForceBackground: Boolean): HPALETTE; 8030begin 8031 //TODO: Implement this; 8032 Result := 0; 8033end; 8034 8035{------------------------------------------------------------------------------ 8036 Function: SendMessage 8037 Params: hWnd: 8038 Msg: 8039 wParam: 8040 lParam: 8041 Returns: 8042 8043 The SendMessage function sends the specified message to a window or windows. 8044 The function calls the window procedure for the specified window and does 8045 not return until the window procedure has processed the message. 8046 ------------------------------------------------------------------------------} 8047function TGtk2WidgetSet.SendMessage(HandleWnd: HWND; Msg: Cardinal; wParam: WParam; 8048 lParam: LParam): LResult; 8049var 8050 OldMsg: Cardinal; 8051 8052 procedure PreparePaintMessage({%H-}TargetObject: TObject; var AMessage: TLMessage); 8053 var 8054 GtkPaintData: TLMGtkPaintData; 8055 OldGtkPaintMsg: TLMGtkPaint; 8056 begin 8057 (* MG: old trick. Not used anymore, but it might be, that someday there 8058 will be component, that works better with this, so it is kept. 8059 { The LCL repaints controls in a top-down hierachy. But the gtk sends 8060 gtkdraw events bottom-up. So, controls at the bottom are repainted 8061 many times. To avoid this the queue is checked for LM_PAINT messages 8062 for the parent control. If there is a parent LM_PAINT, this message 8063 is ignored.} 8064 if (Target is TControl) then begin 8065 ParentControl:=TControl(Target).Parent; 8066 while ParentControl<>nil do begin 8067 ParentHandle:=TWinControl(ParentControl).Handle; 8068 if FindPaintMessage(ParentHandle)<>nil then begin 8069 {$IFDEF VerboseDsgnPaintMsg} 8070 if (csDesigning in TComponent(Target).ComponentState) then begin 8071 DebugLn('TGtk2WidgetSet.SendMessage A ', 8072 TComponent(Target).Name,':',Target.ClassName, 8073 ' Parent Message found: ',ParentControl.Name,':',ParentControl.ClassName 8074 ); 8075 end; 8076 {$ENDIF} 8077 if Msg=LM_PAINT then 8078 ReleaseDC(0,AMessage.WParam); 8079 //exit; 8080 end; 8081 ParentControl:=ParentControl.Parent; 8082 end; 8083 end; *) 8084 {$IFDEF VerboseDsgnPaintMsg} 8085 if (csDesigning in TComponent(TargetObject).ComponentState) then begin 8086 write('TGtk2WidgetSet.SendMessage B ', 8087 TComponent(TargetObject).Name,':',TargetObject.ClassName, 8088 ' GtkPaint=',AMessage.Msg=LM_GtkPAINT); 8089 if AMessage.Msg=LM_GtkPAINT then begin 8090 if AMessage.wParam<>0 then begin 8091 with TLMGtkPaintData(AMessage.wParam) do begin 8092 write(' GtkPaintData(', 8093 ' Widget=',DbgS(Widget),'=',GetWidgetClassName(Widget), 8094 ' State=',State, 8095 ' Rect=',Rect.Left,',',Rect.Top,',',Rect.Right,',',Rect.Bottom, 8096 ' RepaintAll=',RepaintAll, 8097 ')'); 8098 end; 8099 end else begin 8100 write(' GtkPaintData=nil'); 8101 end; 8102 end; 8103 DebugLn(''); 8104 end; 8105 {$ENDIF} 8106 8107 if AMessage.Msg = LM_GTKPAINT 8108 then begin 8109 OldGtkPaintMsg := TLMGtkPaint(AMessage); 8110 GtkPaintData := OldGtkPaintMsg.Data; 8111 // convert LM_GTKPAINT to LM_PAINT 8112 AMessage := TLMessage(GtkPaintMessageToPaintMessage( 8113 TLMGtkPaint(AMessage), False)); 8114 GtkPaintData.Free; 8115 end; 8116 end; 8117 8118 procedure DisposePaintMessage({%H-}TargetObject: TObject; var AMessage: TLMessage); 8119 begin 8120 if OldMsg = LM_GTKPAINT then 8121 begin 8122 FinalizePaintMessage(@AMessage); 8123 end 8124 else 8125 if (AMessage.Msg = LM_PAINT) and (AMessage.WParam <> 0) then 8126 begin 8127 // free DC 8128 ReleaseDC(0, AMessage.WParam); 8129 AMessage.WParam := 0; 8130 end; 8131 end; 8132 8133var 8134 AMessage: TLMessage; 8135 Target: TObject; 8136begin 8137 OldMsg := Msg; 8138 8139 AMessage.Msg := Msg; 8140 AMessage.WParam := WParam; 8141 AMessage.LParam := LParam; 8142 AMessage.Result := 0; 8143 8144 Target := GetLCLObject({%H-}Pointer(HandleWnd)); 8145 8146 if Target <> nil then 8147 begin 8148 if (Msg = LM_PAINT) or (Msg = LM_GTKPAINT) then 8149 begin 8150 PreparePaintMessage(Target,AMessage); 8151 Result := DoDeliverPaintMessage(Target, TLMPaint(AMessage)); 8152 end 8153 else 8154 Result := DeliverMessage(Target, AMessage); // deliver it 8155 8156 if (Msg = LM_PAINT) or (Msg = LM_GTKPAINT) then 8157 DisposePaintMessage(Target, AMessage); 8158 end; 8159end; 8160 8161{------------------------------------------------------------------------------ 8162 function SetActiveWindow(Handle: HWND): HWND; 8163 8164 8165------------------------------------------------------------------------------} 8166function TGtk2WidgetSet.SetActiveWindow(Handle: HWND): HWND; 8167begin 8168 // ToDo 8169 Result := GetActiveWindow; 8170 if (Handle <> 0) and GtkWidgetIsA({%H-}PGtkWidget(Handle),GTK_TYPE_WINDOW) then 8171 begin 8172 if GTK_WIDGET_VISIBLE({%H-}PGtkWidget(Handle)) then 8173 gtk_window_present({%H-}PGtkWindow(Handle)); 8174 end else 8175 Result := 0; // if not active window return error 8176end; 8177 8178{------------------------------------------------------------------------------ 8179 Function: SetBkColor pbd 8180 Params: DC: Device context to change the text background color 8181 Color: RGB Tuple 8182 Returns: Old Background color 8183 8184 8185 ------------------------------------------------------------------------------} 8186function TGtk2WidgetSet.SetBkColor(DC: HDC; Color: TColorRef): TColorRef; 8187begin 8188 Result := CLR_INVALID; 8189 if IsValidDC(DC) 8190 then begin 8191 with TGtkDeviceContext(DC) do 8192 begin 8193 Result := CurrentBackColor.ColorRef; 8194 SetGDIColorRef(CurrentBackColor,Color); 8195 end; 8196 end; 8197end; 8198 8199{------------------------------------------------------------------------------ 8200 Function: SetBkMode 8201 Params: DC: 8202 bkMode: 8203 Returns: 8204 8205 ------------------------------------------------------------------------------} 8206function TGtk2WidgetSet.SetBkMode(DC: HDC; bkMode: Integer) : Integer; 8207var 8208 DevCtx: TGtkDeviceContext absolute DC; 8209begin 8210 // Your code here 8211 Result := DevCtx.BkMode; 8212 DevCtx.BkMode := bkMode; 8213end; 8214 8215{------------------------------------------------------------------------------ 8216 Function: SetCapture 8217 Params: Value: Handle of window to capture 8218 Returns: Nothing 8219 8220 8221 ------------------------------------------------------------------------------} 8222function TGtk2WidgetSet.SetCapture(AHandle: HWND): HWND; 8223var 8224 Widget: PGtkWidget; 8225 CaptureWidget: PGtkWidget; 8226 {$IfDef VerboseMouseCapture} 8227 toplevel: PGtkWidget; 8228 WndGroup: PGtkWindowGroup; 8229 DefWndGroup: PGtkWindowGroup; 8230 {$EndIf} 8231begin 8232 Widget := {%H-}PGtkWidget(AHandle); 8233 {$IfDef VerboseMouseCapture} 8234 DebugLn('TGtk2WidgetSet.SetCapture Widget=[',GetWidgetDebugReport(Widget),'] gtk=[',GetWidgetDebugReport(gtk_grab_get_current),'] MouseCaptureWidget=[',GetWidgetDebugReport(MouseCaptureWidget),']'); 8235 {$EndIf} 8236 8237 // return old capture handle 8238 Result := GetCapture; 8239 8240 if (Result <> 0) then begin 8241 {$IfDef VerboseMouseCapture} 8242 DebugLn('TGtk2WidgetSet.SetCapture gtk_grab_remove=[',GetWidgetDebugReport(gtk_grab_get_current),']'); 8243 {$EndIf} 8244 gtk_grab_remove(gtk_grab_get_current); 8245 end; 8246 if (MouseCaptureWidget<>nil) and (gtk_grab_get_current=nil) 8247 and (GTK_WIDGET_HAS_GRAB(MouseCaptureWidget)) 8248 then begin 8249 {$IfDef VerboseMouseCapture} 8250 DebugLn('TGtk2WidgetSet.SetCapture gtk_grab_get_current=nil, but GTK_WIDGET_HAS_GRAB(MouseCaptureWidget)=true => gtk_grab_remove=[',GetWidgetDebugReport(MouseCaptureWidget),']'); 8251 {$EndIf} 8252 gtk_grab_remove(MouseCaptureWidget); 8253 end; 8254 8255 MouseCaptureWidget := nil; 8256 8257 if Widget = nil then 8258 exit; 8259 8260 CaptureWidget := GetDefaultMouseCaptureWidget(Widget); 8261 if CaptureWidget = nil then begin 8262 {$IfDef VerboseMouseCapture} 8263 DebugLn('TGtk2WidgetSet.SetCapture GetDefaultMouseCaptureWidget failed for widget=[',GetWidgetDebugReport(Widget),']'); 8264 {$EndIf} 8265 exit; 8266 end; 8267 {$IfDef VerboseMouseCapture} 8268 // ubuntu liboverlay intercepts gtk_grab_add for LCLWinapiClient 8269 // ToDo: find out how to grab LCLWinapiClient with ubuntu liboverlay 8270 if GtkWidgetIsA(Widget,GTK_TYPE_SCROLLED_WINDOW) then 8271 begin 8272 debugln(['TGtk2WidgetSet.SetCapture is api widget ', 8273 ' widget=',GetWidgetClassName(Widget), 8274 ' container.container.focus_child=',GetWidgetClassName(PGtkScrolledWindow(Widget)^.container.container.focus_child), 8275 ' container.child=',GetWidgetClassName(PGtkScrolledWindow(Widget)^.container.child), 8276 '']); 8277 //CaptureWidget:=PGtkScrolledWindow(Widget)^.container; 8278 end; 8279 {$EndIf} 8280 8281 {$IfDef VerboseMouseCapture} 8282 DebugLn(['TGtk2WidgetSet.SetCapture gtk_grab_add=[',GetWidgetDebugReport(CaptureWidget),'] has_grab=',gtk_widget_has_grab(CaptureWidget),' is_sensitive=',gtk_widget_is_sensitive(CaptureWidget)]); 8283 toplevel := gtk_widget_get_toplevel(CaptureWidget); 8284 if (toplevel<>nil) 8285 and (ord(gdk_window_get_window_type (toplevel^.window)) = GDK_WINDOW_OFFSCREEN_lcl) 8286 then begin 8287 debugln(['WARNING: TGtk2WidgetSet.SetCapture capturewidget is offscreen']); 8288 end; 8289 WndGroup := GetGtkWindowGroup(CaptureWidget); 8290 DefWndGroup:=GetGtkWindowGroup(CaptureWidget); 8291 debugln(['TGtk2WidgetSet.SetCapture WndGroup=',dbgs(WndGroup),' DefWndGroup=',dbgs(DefWndGroup),' same=',WndGroup=DefWndGroup]); 8292 // Note: liboverlay: gtk_grab_add sets gtk_widget_has_grab, but gtk_grab_get_current returns nil 8293 // ToDo: check window group 8294 {$EndIf} 8295 MouseCaptureWidget := CaptureWidget; 8296 gtk_grab_add(CaptureWidget); 8297 if gtk_grab_get_current=CaptureWidget then 8298 begin 8299 {$IfDef VerboseMouseCapture} 8300 DebugLn('TGtk2WidgetSet.SetCapture gtk_grab_add success: gtk_grab_get_current=[',GetWidgetDebugReport(gtk_grab_get_current),']') 8301 {$EndIf} 8302 end 8303 else begin 8304 {$IfDef VerboseMouseCapture} 8305 if gtk_widget_has_grab(CaptureWidget) then 8306 DebugLn('WARNING: TGtk2WidgetSet.SetCapture gtk_grab_add failed (partial success): gtk_grab_get_current=[',GetWidgetDebugReport(gtk_grab_get_current),'] has_grab=true') 8307 else 8308 DebugLn('WARNING: TGtk2WidgetSet.SetCapture gtk_grab_add failed (complete): gtk_grab_get_current=[',GetWidgetDebugReport(gtk_grab_get_current),'] has_grab=false'); 8309 {$EndIf} 8310 end; 8311 8312 if MouseCaptureWidget<>nil then 8313 SendMessage(HWnd({%H-}PtrUInt(MouseCaptureWidget)), LM_CAPTURECHANGED, 0, Result); 8314end; 8315 8316{------------------------------------------------------------------------------ 8317 Function: SetCaretPos 8318 Params: new position x, y 8319 Returns: true on success 8320 8321 ------------------------------------------------------------------------------} 8322function TGtk2WidgetSet.SetCaretPos(X, Y: Integer): Boolean; 8323var 8324 FocusObject: PGTKObject; 8325begin 8326 FocusObject := {%H-}PGTKObject(GetFocus); 8327 Result:=SetCaretPosEx({%H-}PtrUInt(FocusObject),X,Y); 8328end; 8329 8330{------------------------------------------------------------------------------ 8331 Function: SetCaretPos 8332 Params: new position x, y 8333 Returns: true on success 8334 8335 ------------------------------------------------------------------------------} 8336function TGtk2WidgetSet.SetCaretPosEx(Handle: HWnd; X, Y: Integer): Boolean; 8337var 8338 GtkObject: PGTKObject; 8339begin 8340 GtkObject := {%H-}PGTKObject(Handle); 8341 Result := GtkObject <> nil; 8342 8343 if Result then begin 8344 if gtk_type_is_a(g_object_type(GtkObject), GTKAPIWidget_GetType) 8345 then begin 8346 GTKAPIWidget_SetCaretPos(PGTKAPIWidget(GtkObject), X, Y); 8347 end 8348// else if // TODO: other widgettypes 8349 else begin 8350 Result := False; 8351 end; 8352 end; 8353end; 8354 8355{------------------------------------------------------------------------------ 8356 Function: SetCaretRespondToFocus 8357 Params: handle : Handle of a TWinControl 8358 ShowHideOnFocus: true = caret is hidden on focus lost 8359 Returns: true on success 8360 8361 ------------------------------------------------------------------------------} 8362function TGtk2WidgetSet.SetCaretRespondToFocus(handle: HWND; 8363 ShowHideOnFocus: boolean): Boolean; 8364begin 8365 if handle<>0 then begin 8366 if gtk_type_is_a(g_object_type({%H-}PGTKObject(handle)), GTKAPIWidget_GetType) 8367 then begin 8368 GTKAPIWidget_SetCaretRespondToFocus({%H-}PGTKAPIWidget(handle), 8369 ShowHideOnFocus); 8370 Result:=true; 8371 end 8372 else begin 8373 Result := False; 8374 end; 8375 end else 8376 Result:=false; 8377end; 8378 8379{------------------------------------------------------------------------------ 8380 Function: SetCursor 8381 Params : hCursor - cursor handle 8382 Returns : current cursor 8383 ------------------------------------------------------------------------------} 8384function TGtk2WidgetSet.SetCursor(ACursor: HCURSOR): HCURSOR; 8385begin 8386 // set global gtk cursor 8387 Result := FGlobalCursor; 8388 if ACursor = FGlobalCursor then Exit; 8389 if ACursor = Screen.Cursors[crDefault] 8390 then SetGlobalCursor(0) 8391 else SetGlobalCursor(ACursor); 8392 FGlobalCursor := ACursor; 8393end; 8394 8395{------------------------------------------------------------------------------ 8396 Function: SetCursorPos 8397 Params: X: 8398 Y: 8399 Returns: 8400 8401 ------------------------------------------------------------------------------} 8402function TGtk2WidgetSet.SetCursorPos(X, Y: Integer): Boolean; 8403{$ifdef GTK_2_8} 8404begin 8405 gdk_display_warp_pointer(gdk_display_get_default(), gdk_screen_get_default(), X, Y); 8406 Result := True; 8407end; 8408{$else GTK_2_8} 8409{$IFDEF HasX} 8410var 8411 dpy: PDisplay; 8412begin 8413 Result := False; 8414 {$IFDEF DebugGDKTraps} 8415 BeginGDKErrorTrap; 8416 {$ENDIF} 8417 try 8418 dpy := gdk_display; 8419 XWarpPointer(dpy, 0, RootWindow(dpy, DefaultScreen(dpy)), 0, 0, 0, 0, X, Y); 8420 Result := True; 8421 XFlush(dpy); 8422 finally 8423 {$IFDEF DebugGDKTraps}EndGDKErrorTrap;{$ENDIF} 8424 end; 8425end; 8426{$ELSE HasX} 8427begin 8428 Result := False; 8429 DebugLn('TGtk2WidgetSet.SetCursorPos not implemented for this platform'); 8430 // Can this call TWin32WidgetSet.SetCursorPos? 8431end; 8432{$ENDIF HasX} 8433{$endif GTK_2_8} 8434 8435{------------------------------------------------------------------------------ 8436 Function: SetFocus 8437 Params: hWnd: Handle of new focus window 8438 Returns: The old focus window 8439 8440 The SetFocus function sets the keyboard focus to the specified window 8441 ------------------------------------------------------------------------------} 8442function TGtk2WidgetSet.SetFocus(hWnd: HWND): HWND; 8443{off $DEFINE VerboseFocus} 8444var 8445 Widget, TopLevel, NewFocusWidget: PGtkWidget; 8446 Info: PWidgetInfo; 8447 {$IfDef VerboseFocus} 8448 AWinControl: TWinControl; 8449 {$EndIf} 8450 NewTopLevelWidget: PGtkWidget; 8451 NewTopLevelObject: TObject; 8452 NewForm: TCustomForm; 8453begin 8454 if hwnd = 0 then 8455 begin 8456 Result:=0; 8457 exit; 8458 end; 8459 Widget:={%H-}PGtkWidget(hWnd); 8460 {$IfDef VerboseFocus} 8461 DebugLn(''); 8462 DebuglnEnter('TGtk2WidgetSet.SetFocus INIT'); 8463 DebugLn('A hWnd=',GetWidgetDebugReport(Widget)); 8464 //DebugLn(getStackTrace(true)); 8465 //if GtkWidgetIsA(Widget,GTK_TYPE_NOTEBOOK) then DumpStack; 8466 {$EndIf} 8467 8468 // return the old focus handle 8469 Result := GetFocus; 8470 NewFocusWidget := nil; 8471 8472 TopLevel := gtk_widget_get_toplevel(Widget); 8473 {$IfDef VerboseFocus} 8474 Debugln('B TopLevel=',DbgS(TopLevel),' OldFocus=',GetWidgetDebugReport(PGtkWidget(Result))); 8475 if not GTK_WIDGET_VISIBLE(Widget) then begin 8476 DebugLnExit('TGtk2WidgetSet.SetFocus EXIT: Widget is not visible'); 8477 raise Exception.Create('TGtk2WidgetSet.SetFocus: Widget is not visible'); 8478 end; 8479 {$EndIf} 8480 8481 if Result=hWnd then begin 8482 {$IfDef VerboseFocus} 8483 DebugLnExit('TGtk2WidgetSet.SetFocus EXIT: focusing same control'); 8484 {$EndIf} 8485 exit; 8486 end; 8487 8488 if GtkWidgetIsA(TopLevel, gtk_window_get_type) then 8489 begin 8490 // TopLevel is a gtkwindow 8491 {$IfDef VerboseFocus} 8492 AWinControl:=TWinControl(GetNearestLCLObject(PGtkWindow(TopLevel)^.focus_widget)); 8493 DbgOut('C TopLevel is a gtkwindow '); 8494 DbgOut(' focus_widget=',DbgS(PGtkWindow(TopLevel)^.focus_widget)); 8495 DebugLn(' LCLParent=',dbgsName(AWinControl)); 8496 {$EndIf} 8497 8498 NewTopLevelObject:=GetNearestLCLObject(TopLevel); 8499 if (NewTopLevelObject is TCustomForm) then 8500 begin 8501 NewForm := TCustomForm(NewTopLevelObject); 8502 if Screen.GetCurrentModalFormZIndex > Screen.CustomFormZIndex(NewForm) then 8503 begin 8504 // there is a modal form above -> focus forbidden 8505 {$IfDef VerboseFocus} 8506 DebugLn(' there is a modal form above -> focus forbidden'); 8507 {$EndIf} 8508 exit; 8509 end; 8510 end; 8511 8512 NewFocusWidget := FindFocusWidget(Widget); 8513 8514 {$IfDef VerboseFocus} 8515 DbgOut('G NewFocusWidget=',DbgS(NewFocusWidget),' ',DbgSName(GetNearestLCLObject(NewFocusWidget))); 8516 DbgOut([' WidVisible=',GTK_WIDGET_VISIBLE(PGtkWidget(NewFocusWidget))]); 8517 DbgOut([' WidRealized=',GTK_WIDGET_REALIZED(PGtkWidget(NewFocusWidget))]); 8518 DbgOut([' WidMapped=',GTK_WIDGET_MAPPED(PGtkWidget(NewFocusWidget))]); 8519 DbgOut([' WidCanfocus=',GTK_WIDGET_CAN_FOCUS(PGtkWidget(NewFocusWidget))]); 8520 DbgOut([' TopLvlVisible=',GTK_WIDGET_VISIBLE(PGtkWidget(TopLevel))]); 8521 DebugLn(''); 8522 {$EndIf} 8523 if (NewFocusWidget<>nil) and GTK_WIDGET_CAN_FOCUS(NewFocusWidget) then 8524 begin 8525 if (PGtkWindow(TopLevel)^.Focus_Widget<>NewFocusWidget) then 8526 begin 8527 {$IfDef VerboseFocus} 8528 DebugLn('H SETTING NewFocusWidget=',dbgs(NewFocusWidget),' ',DbgSName(GetNearestLCLObject(NewFocusWidget))); 8529 //DebugLn('TGtk2WidgetSet.SetFocus TopLevel[',DebugGtkWidgets.GetInfo(TopLevel,false),'] NewFocusWidget=[',DebugGtkWidgets.GetInfo(NewFocusWidget,false),']'); 8530 DebugLnEnter('Recursive focus INIT'); 8531 {$EndIf} 8532 gtk_window_set_focus(PGtkWindow(TopLevel), NewFocusWidget); 8533 {$IfDef VerboseFocus} 8534 DebugLnExit('Recursive focus DONE'); 8535 DebugLn('I NewTopLevel FocusWidget=',DbgS(PGtkWindow(TopLevel)^.Focus_Widget),' Success=',dbgs(PGtkWindow(TopLevel)^.Focus_Widget=NewFocusWidget)); 8536 {$EndIf} 8537 end; 8538 end; 8539 end 8540 else begin 8541 NewFocusWidget:=Widget; 8542 end; 8543 8544 if (NewFocusWidget <> nil) and not gtk_widget_has_focus(NewFocusWidget) then 8545 begin 8546 // grab the focus to the parent window 8547 NewTopLevelWidget := gtk_widget_get_toplevel(NewFocusWidget); 8548 NewTopLevelObject := GetNearestLCLObject(NewTopLevelWidget); 8549 if (Screen<>nil) and (Screen.GetCurrentModalForm<>nil) and (NewTopLevelObject <>Screen.GetCurrentModalForm) then 8550 begin 8551 {$IFDEF VerboseFocus} 8552 DebugLn('There is a modal form -> not grabbing'); 8553 {$ENDIF} 8554 end 8555 else 8556 begin 8557 {$IfDef VerboseFocus} 8558 DebugLn('J Grabbing focus ',GetWidgetDebugReport(NewFocusWidget)); 8559 {$EndIf} 8560 if NewTopLevelObject is TCustomForm then 8561 begin 8562 Info := GetWidgetInfo(NewTopLevelWidget); 8563 if (Info <> nil) and not (wwiActivating in Info^.Flags) then 8564 SetForegroundWindow(TCustomForm(NewTopLevelObject).Handle); 8565 end; 8566 gtk_widget_grab_focus(NewFocusWidget); 8567 end; 8568 end; 8569 8570 {$IfDef VerboseFocus} 8571 AWinControl:=TWinControl(GetNearestLCLObject(NewFocusWidget)); 8572 NewFocusWidget:=PGtkWidget(GetFocus); 8573 DebugLnExit('TGtk2WidgetSet.SetFocus END hWnd=',DbgS(hWnd), 8574 ' NewFocus=',DbgS(NewFocusWidget), 8575 ' NewLCLParent=',dbgsName(AWinControl)); 8576 {$EndIf} 8577end; 8578 8579{------------------------------------------------------------------------------ 8580 Function: SetForegroundWindow 8581 Params: hWnd: 8582 Returns: 8583 8584 ------------------------------------------------------------------------------} 8585function TGtk2WidgetSet.SetForegroundWindow(hWnd : HWND): boolean; 8586var 8587 {$IFDEF VerboseFocus} 8588 LCLObject: TControl; 8589 {$ENDIF} 8590 GdkWindow: PGdkWindow; 8591 AForm: TCustomForm; 8592begin 8593 {$IFDEF VerboseFocus} 8594 DbgOut('TGtk2WidgetSet.SetForegroundWindow hWnd=',DbgS(hWnd)); 8595 LCLObject:=TControl(GetLCLObject(Pointer(hWnd))); 8596 if LCLObject<>nil then 8597 DebugLn(' LCLObject=',LCLObject.Name,':',LCLObject.ClassName) 8598 else 8599 DebugLn(' LCLObject=nil'); 8600 {$ENDIF} 8601 Result := GtkWidgetIsA({%H-}PGtkWidget(hWnd),GTK_TYPE_WINDOW); 8602 if Result then 8603 begin 8604 GdkWindow := GetControlWindow({%H-}PgtkWidget(hwnd)); 8605 if GdkWindow <> nil then 8606 begin 8607 if not gdk_window_is_visible(GdkWindow) then 8608 begin 8609 Result := False; 8610 Exit; 8611 end; 8612 AForm := TCustomForm(GetLCLObject({%H-}PgtkWidget(hwnd))); 8613 if (AForm is TCustomForm) and (AForm.Parent=nil) then 8614 begin 8615 if Screen.CustomFormZIndex(AForm) < Screen.GetCurrentModalFormZIndex then 8616 begin 8617 debugln('TGtk2WidgetSet.SetForegroundWindow Form=',DbgSName(AForm), 8618 ' can not be raised, because ', 8619 DbgSName(Screen.GetCurrentModalForm), 8620 ' is modal and above.'); 8621 Result := False; 8622 exit; 8623 end; 8624 Screen.MoveFormToZFront(AForm); 8625 end; 8626 {$IFDEF DebugGDKTraps} 8627 BeginGDKErrorTrap; 8628 {$ENDIF} 8629 gdk_window_show(GdkWindow); 8630 gdk_window_raise(GdkWindow); 8631 gdk_window_focus(GdkWindow, gtk_get_current_event_time); 8632 {$IFDEF DebugGDKTraps} 8633 EndGDKErrorTrap; 8634 {$ENDIF} 8635 // this currently will bring the window to the current desktop and focus it 8636 gtk_window_present({%H-}PGtkWindow(hWnd)); 8637 end; 8638 end; 8639end; 8640 8641function TGtk2WidgetSet.SetMapMode(DC: HDC; fnMapMode : Integer): Integer; 8642var 8643 DevCtx: TGtkDeviceContext absolute DC; 8644begin 8645 Result := Integer(False); 8646 if not IsValidDC(DC) then Exit(0); 8647 DevCtx.MapMode := fnMapMode; 8648 Result := Integer(True); 8649end; 8650 8651function TGtk2WidgetSet.SetParent(hWndChild: HWND; hWndParent: HWND): HWND; 8652var 8653 Fixed: PGtkWidget; 8654 LCLObject: TObject; 8655begin 8656 Result := GetParent(hWndChild); 8657 8658 if Result = hWndParent then 8659 Exit; 8660 8661 // for window we need to move it content to HBox 8662 if GTK_IS_WINDOW({%H-}PGtkWidget(hWndChild)) then 8663 begin 8664 LCLObject := GetLCLObject({%H-}PGtkWidget(hWndChild)); 8665 if LCLObject <> nil then 8666 Controls.RecreateWnd(TWinControl(LCLObject)); 8667 Exit; 8668 end; 8669 8670 if Result <> 0 then 8671 begin 8672 // unparent first 8673 gtk_widget_ref({%H-}PGtkWidget(hWndChild)); 8674 if GTK_IS_CONTAINER({%H-}Pointer(Result)) then 8675 gtk_container_remove({%H-}PGtkContainer(Result), {%H-}PGtkWidget(hWndChild)) 8676 else 8677 gtk_widget_unparent({%H-}PGtkWidget(hWndChild)); 8678 end; 8679 8680 Fixed := GetFixedWidget({%H-}PGtkWidget(hWndParent)); 8681 if Fixed <> nil then 8682 begin 8683 FixedPutControl(Fixed, {%H-}PGtkWidget(hWndChild), {%H-}PGtkWidget(hWndChild)^.allocation.x, {%H-}PGtkWidget(hWndChild)^.allocation.y); 8684 RegroupAccelerator({%H-}PGtkWidget(hWndChild)); 8685 end 8686 else 8687 gtk_widget_set_parent({%H-}PGtkWidget(hWndChild), {%H-}PGtkWidget(hWndParent)); 8688 8689 if Result <> 0 then 8690 gtk_widget_unref({%H-}PGtkWidget(hWndChild)); 8691end; 8692 8693{------------------------------------------------------------------------------ 8694 function TGtk2WidgetSet.SetProp(Handle: hwnd; Str : PChar; 8695 Data : Pointer) : Boolean; 8696 ------------------------------------------------------------------------------} 8697function TGtk2WidgetSet.SetProp(Handle: hwnd; Str : PChar; Data : Pointer) : Boolean; 8698begin 8699 g_object_set_data({%H-}pGObject(handle),Str,data); 8700 Result:=true; 8701end; 8702 8703{------------------------------------------------------------------------------ 8704 Method: SetRectRgn 8705 Params: aRGN: HRGN; X1, Y1, X2, Y2 : Integer 8706 Returns: True if the function succeeds 8707 8708 Converts a region into a rectangular region with the specified coordinates. 8709 ------------------------------------------------------------------------------} 8710function TGtk2WidgetSet.SetRectRgn(aRGN: HRGN; X1, Y1, X2, Y2 : Integer): Boolean; 8711 8712 procedure Swap(var A, B: Integer); 8713 var 8714 Tmp: Integer; 8715 begin 8716 Tmp := A; 8717 A := B; 8718 B := Tmp; 8719 end; 8720 8721var 8722 AGdiObject: PGdiObject absolute aRGN; 8723begin 8724 Result := IsValidGDIObject(aRGN); 8725 if Result then begin 8726 if (X1 > X2) then swap(X1, X2); 8727 if (Y1 > Y2) then swap(Y1, Y2); 8728 AGdiObject^.GDIRegionObject := CreateRectGDKRegion(Rect(X1,Y1,X2,Y2)); 8729 Result := True; 8730 end; 8731end; 8732 8733{------------------------------------------------------------------------------ 8734 function TGtk2WidgetSet.SetROPMode(Handle: hwnd; Str : PChar; 8735 Data : Pointer) : Boolean; 8736 ------------------------------------------------------------------------------} 8737function TGtk2WidgetSet.SetROP2(DC: HDC; Mode: Integer) : Integer; 8738var 8739 DevCtx: TGtkDeviceContext absolute DC; 8740begin 8741 if not IsValidDC(DC) then Exit(0); 8742 8743 Result := DevCtx.ROP2; 8744 DevCtx.ROP2 := Mode; 8745end; 8746 8747{------------------------------------------------------------------------------ 8748 Function: SetScrollInfo 8749 Params: none 8750 Returns: The new position value 8751 8752 nPage >= 0 8753 nPage <= nMax-nMin+1 8754 nPos >= nMin 8755 nPos <= nMax - Max(nPage-1,0) 8756 ------------------------------------------------------------------------------} 8757function TGtk2WidgetSet.SetScrollInfo(Handle : HWND; SBStyle : Integer; 8758 ScrollInfo: TScrollInfo; bRedraw : Boolean): Integer; 8759var 8760 HasChanged: boolean; 8761 8762 procedure SetRangeUpdatePolicy(Range: PGtkRange); 8763 var 8764 UpdPolicy: TGTKUpdateType; 8765 begin 8766 case ScrollInfo.nTrackPos of 8767 SB_POLICY_DISCONTINUOUS: UpdPolicy := GTK_UPDATE_DISCONTINUOUS; 8768 SB_POLICY_DELAYED: UpdPolicy := GTK_UPDATE_DELAYED; 8769 else UpdPolicy := GTK_UPDATE_CONTINUOUS; 8770 end; 8771 if gtk_range_get_update_policy(Range)=UpdPolicy then exit; 8772 gtk_range_set_update_policy(Range, UpdPolicy); 8773 HasChanged:=true; 8774 end; 8775 8776 procedure SetScrolledWindowUpdatePolicy(ScrolledWindow:PGTKScrolledWindow); 8777 var 8778 Range: PGtkRange; 8779 begin 8780 case SBStyle of 8781 SB_VERT: Range := PGtkRange(ScrolledWindow^.vscrollbar); 8782 SB_HORZ: Range := PGtkRange(ScrolledWindow^.hscrollbar); 8783 else exit; 8784 end; 8785 SetRangeUpdatePolicy(Range); 8786 end; 8787 8788 procedure SetLayoutSize(layout:PGtkLayout; width:guint; height:guint); 8789 var 8790 OldWidth: guint; 8791 OldHeight: guint; 8792 begin 8793 gtk_layout_get_size(layout,@OldWidth,@OldHeight); 8794 if (OldWidth=width) and (OldHeight=height) then exit; 8795 HasChanged:=true; 8796 gtk_layout_set_size(layout,width,height); 8797 end; 8798 8799 procedure SetGDouble(var v: gdouble; NewValue: gdouble); 8800 begin 8801 if v=NewValue then exit; 8802 v:=NewValue; 8803 HasChanged:=true; 8804 end; 8805 8806const 8807 POLICY: array[BOOLEAN] of TGTKPolicyType = (GTK_POLICY_NEVER, GTK_POLICY_ALWAYS); 8808var 8809 Layout: PgtkLayout; 8810 Scroll: PGTKWidget; 8811 IsScrollWindow: Boolean; 8812 IsScrollbarVis: boolean; 8813 Adjustment: PGtkAdjustment; 8814begin 8815 Result := 0; 8816 if (Handle = 0) then exit; 8817 HasChanged:=false; 8818 8819 {DebugLn(['TGtk2WidgetSet.SetScrollInfo A Widget=',GetWidgetDebugReport(PGtkWidget(Handle)),' SBStyle=',SBStyle, 8820 ' ScrollInfo=[', 8821 'cbSize=',ScrollInfo.cbSize, 8822 ',fMask=',ScrollInfo.fMask, 8823 ',nMin=',ScrollInfo.nMin, 8824 ',nMax=',ScrollInfo.nMax, 8825 ',nPage=',ScrollInfo.nPage, 8826 ',nPos=',ScrollInfo.nPos, 8827 ',nTrackPos=',ScrollInfo.nTrackPos, 8828 ']']);} 8829 8830 Scroll := g_object_get_data({%H-}PGObject(Handle), odnScrollArea); 8831 if GtkWidgetIsA(Scroll, gtk_scrolled_window_get_type) 8832 then begin 8833 IsScrollWindow := True; 8834 end 8835 else begin 8836 Scroll := {%H-}PGTKWidget(Handle); 8837 IsScrollWindow := GtkWidgetIsA(Scroll, gtk_scrolled_window_get_type); 8838 end; 8839 8840 if IsScrollWindow 8841 then begin 8842 Layout := GetFixedWidget({%H-}PGTKObject(Handle)); 8843 if not GtkWidgetIsA(PGtkWidget(Layout), gtk_layout_get_type) 8844 then Layout := nil; 8845 end 8846 else begin 8847 Layout := nil; 8848 end; 8849 8850 8851 // scrollbar update policy 8852 if (Scrollinfo.fmask and SIF_UPDATEPOLICY <> 0) then begin 8853 if IsScrollWindow then 8854 SetScrolledWindowUpdatePolicy(PGTKScrolledWindow(Scroll)) 8855 else if GtkWidgetIsA(PgtkWidget(Scroll), gtk_clist_get_type) then 8856 SetScrolledWindowUpdatePolicy(PGTKScrolledWindow(@PgtkCList(Scroll)^.container)) 8857 else if GtkWidgetIsA(PGtkWidget(Scroll),gtk_hscrollbar_get_type) then 8858 SetRangeUpdatePolicy(PgtkRange(Scroll)) 8859 else if GtkWidgetIsA(PGtkWidget(Scroll),gtk_vscrollbar_get_type) then 8860 SetRangeUpdatePolicy(PgtkRange(Scroll)) 8861 else if GtkWidgetIsA(PGtkWidget(Scroll), gtk_range_get_type) then 8862 SetRangeUpdatePolicy(PGTKRange(Scroll)); 8863 end; 8864 8865 8866 Adjustment:=nil; 8867 case SBStyle of 8868 SB_HORZ: 8869 if IsScrollWindow 8870 then begin 8871 Adjustment := gtk_scrolled_window_get_hadjustment(PGTKScrolledWindow(Scroll)); 8872 if Layout <> nil 8873 then begin 8874 if (ScrollInfo.fMask and SIF_RANGE) <> 0 then 8875 SetLayoutSize(Layout, ScrollInfo.nMax - ScrollInfo.nMin, Layout^.height); 8876 Result := round(Layout^.hadjustment^.value); 8877 end; 8878 end 8879 // obsolete stuff 8880 else if GtkWidgetIsA(PGtkWidget(Scroll),gtk_hscrollbar_get_type) 8881 then begin 8882 // this one shouldn't be possible, scrollbar messages are sent to the CTL 8883 DebugLN('!!! direct SB_HORZ set call to scrollbar'); 8884 Adjustment := PgtkhScrollBar(Scroll)^.Scrollbar.Range.Adjustment 8885 end 8886 else if GtkWidgetIsA(PGtkWidget(Scroll),gtk_clist_get_type) 8887 then begin 8888 //clist 8889 //TODO: check if this is needed for listviews 8890 DebugLn('[SetScrollInfo] Possible obsolete set use of CList (Listview ?)'); 8891 Adjustment := gtk_clist_get_hadjustment(PgtkCList(Scroll)); 8892 end; 8893 8894 SB_VERT: 8895 if IsScrollWindow 8896 then begin 8897 Adjustment := gtk_scrolled_window_get_vadjustment(PGTKScrolledWindow(Scroll)); 8898 if Layout <> nil 8899 then begin 8900 if (ScrollInfo.fMask and SIF_RANGE) <> 0 then 8901 SetLayoutSize(Layout, Layout^.Width, ScrollInfo.nMax - ScrollInfo.nMin); 8902 Result := round(Layout^.vadjustment^.value); 8903 end; 8904 end 8905 // obsolete stuff 8906 else if GtkWidgetIsA(PGtkWidget(Scroll),gtk_vscrollbar_get_type) 8907 then begin 8908 // this one shouldn't be possible, scrollbar messages are sent to the CTL 8909 DebugLN('!!! direct SB_VERT call to scrollbar'); 8910 Adjustment := PgtkvScrollBar(Scroll)^.Scrollbar.Range.Adjustment; 8911 end 8912 else if GtkWidgetIsA(PGtkWidget(Scroll), gtk_clist_get_type) 8913 then begin 8914 //TODO: check is this is needed for listviews 8915 DebugLn('[SetScrollInfo] Possible obsolete set use of CList (Listview ?)'); 8916 Adjustment := gtk_clist_get_vadjustment(PgtkCList(Scroll)); 8917 end; 8918 8919 SB_CTL: 8920 if GtkWidgetIsA(PGtkWidget(Scroll),gtk_vscrollbar_get_type) then 8921 Adjustment := PgtkvScrollBar(Scroll)^.Scrollbar.Range.Adjustment 8922 else 8923 if GtkWidgetIsA(PGtkWidget(Scroll),gtk_hscrollbar_get_type) then 8924 Adjustment := PgtkhScrollBar(Scroll)^.Scrollbar.Range.Adjustment 8925 else 8926 if GtkWidgetIsA(PGtkWidget(Scroll), gtk_range_get_type) then 8927 Adjustment := gtk_range_get_adjustment(PGTKRange(Scroll)); 8928 SB_BOTH: 8929 DebugLn('[SetScrollInfo] Got SB_BOTH ???'); 8930 end; 8931 8932 8933 if Adjustment = nil then 8934 exit; 8935 8936 if (ScrollInfo.fMask and SIF_RANGE) <> 0 8937 then begin 8938 SetGDouble(Adjustment^.lower,ScrollInfo.nMin); 8939 SetGDouble(Adjustment^.upper,ScrollInfo.nMax); 8940 end; 8941 if (ScrollInfo.fMask and SIF_PAGE) <> 0 8942 then begin 8943 // 0 <= nPage <= nMax-nMin+1 8944 SetGDouble(Adjustment^.page_size, ScrollInfo.nPage); 8945 SetGDouble(Adjustment^.page_size, Min(Max(Adjustment^.page_size,0), 8946 Adjustment^.upper-Adjustment^.lower+1)); 8947 SetGDouble(Adjustment^.page_increment, (Adjustment^.page_size/6)+1); 8948 end; 8949 if (ScrollInfo.fMask and SIF_POS) <> 0 8950 then begin 8951 // nMin <= nPos <= nMax - Max(nPage-1,0) 8952 SetGDouble(Adjustment^.value, ScrollInfo.nPos); 8953 SetGDouble(Adjustment^.value, Max(Adjustment^.value,Adjustment^.lower)); 8954 SetGDouble(Adjustment^.value, Min(Adjustment^.value, 8955 Adjustment^.upper-Max(Adjustment^.page_size-1,0))); 8956 end; 8957 8958 // check if scrollbar should be hidden 8959 IsScrollbarVis := true; 8960 if ((ScrollInfo.fMask and (SIF_RANGE or SIF_PAGE)) <> 0) and 8961 ((SBStyle=SB_HORZ) or (SBStyle=SB_VERT)) 8962 then begin 8963 if (Adjustment^.lower >= (Adjustment^.upper-Max(adjustment^.page_size-1,0))) 8964 then begin 8965 if (ScrollInfo.fMask and SIF_DISABLENOSCROLL) = 0 then 8966 IsScrollbarVis := false 8967 else 8968 ;// scrollbar should look disabled (no thumbbar and grayed appearance) 8969 // maybe not possible in gtk 8970 end; 8971 end; 8972 8973 Result := Round(Adjustment^.value); 8974 8975 if not HasChanged then exit; 8976 8977 {DebugLn(''); 8978 DebugLn('[TGtk2WidgetSet.SetScrollInfo] Result=',Result, 8979 ' Lower=',RoundToInt(Lower), 8980 ' Upper=',RoundToInt(Upper), 8981 ' Page_Size=',RoundToInt(Page_Size), 8982 ' Page_Increment=',RoundToInt(Page_Increment), 8983 ' bRedraw=',bRedraw, 8984 ' Handle=',DbgS(Handle));} 8985 8986 // do we have to set this always ? 8987 // ??? what is this for code ???? 8988 // why not change adjustment if we don't do a redraw ??? 8989 if bRedraw then 8990 begin 8991 // immediate draw 8992 8993 if IsScrollWindow 8994 then begin 8995 case SBStyle of 8996 SB_HORZ: 8997 g_object_set(PGTKObject(Scroll),'hscrollbar_policy',[POLICY[IsScrollbarVis],nil]); 8998 SB_VERT: 8999 g_object_set(PGTKObject(Scroll),'vscrollbar_policy',[POLICY[IsScrollbarVis],nil]); 9000 end; 9001 end 9002 else 9003 gtk_widget_queue_draw(PGTKWidget(Scroll)); 9004 9005(* 9006 DebugLn('TGtk2WidgetSet.SetScrollInfo:' + 9007 ' lower=%d/%d upper=%d/%d value=%d/%d' + 9008 ' step_increment=%d/1 page_increment=%d/%d page_size=%d/%d', [ 9009 Round(lower),nMin, Round(upper),nMax, Round(value),nPos, 9010 Round(step_increment), Round(page_increment),nPage, Round(page_size),nPage] 9011 ); 9012*) 9013 gtk_adjustment_changed(Adjustment); 9014 end; 9015end; 9016 9017{------------------------------------------------------------------------------ 9018 Function: SetSysColors 9019 Params: cElements: the number of elements 9020 lpaElements: array with element numbers 9021 lpaRgbValues: array with colors 9022 Returns: 0 if unsuccesful 9023 9024 The SetSysColors function sets the colors for one or more display elements. 9025 ------------------------------------------------------------------------------} 9026function TGtk2WidgetSet.SetSysColors(cElements: Integer; const lpaElements; 9027 const lpaRgbValues): Boolean; 9028var 9029 n: Integer; 9030 Element: LongInt; 9031begin 9032 Result := False; 9033 if cElements > MAX_SYS_COLORS then Exit; 9034 9035 for n := 0 to cElements - 1 do 9036 begin 9037 Element := PInteger(lpaElements)[n]; 9038 if (Element > MAX_SYS_COLORS) or (Element < 0) then 9039 Exit; 9040 SysColorMap[Element] := PDword(@lpaRgbValues)[n]; 9041 //DebugLn(Format('Trace:[TGtk2WidgetSet.SetSysColor] Index %d (%8x) --> %8x', [PLongArray(lpaElements)^[n], SysColorMap[PLongArray(lpaElements)^[n]], PLongArray(lpaRgbValues)^[n]])); 9042 end; 9043 9044 //TODO send WM_SYSCOLORCHANGE 9045 Result := True; 9046end; 9047 9048{------------------------------------------------------------------------------ 9049 Function: SetTextCharacterExtra 9050 Params: _hdc: 9051 nCharExtra: 9052 Returns: 9053 9054 ------------------------------------------------------------------------------} 9055function TGtk2WidgetSet.SetTextCharacterExtra(DC : hdc; nCharExtra : Integer):Integer; 9056begin 9057 // Your code here 9058 Result:=0; 9059end; 9060 9061{------------------------------------------------------------------------------ 9062 Function: SetTextColor 9063 Params: hdc: Identifies the device context. 9064 Color: Specifies the color of the text. 9065 Returns: The previous color if succesful, CLR_INVALID otherwise 9066 9067 The SetTextColor function sets the text color for the specified device 9068 context to the specified color. 9069 ------------------------------------------------------------------------------} 9070function TGtk2WidgetSet.SetTextColor(DC: HDC; Color: TColorRef): TColorRef; 9071begin 9072 Result := CLR_INVALID; 9073 if IsValidDC(DC) 9074 then begin 9075 with TGtkDeviceContext(DC) do 9076 begin 9077 Result := CurrentTextColor.ColorRef; 9078 SetGDIColorRef(CurrentTextColor,Color); 9079 if Result<>Color then 9080 SelectedColors := dcscCustom; // force SelectGDKTextProps to ensure text color 9081 end; 9082 end; 9083end; 9084 9085function TGtk2WidgetSet.SetViewPortExtEx(DC: HDC; XExtent, YExtent : Integer; OldSize: PSize): Boolean; 9086var 9087 DevCtx: TGtkDeviceContext absolute DC; 9088begin 9089 Result := False; 9090 if not IsValidDC(DC) then Exit; 9091 if OldSize <> nil then 9092 begin 9093 OldSize^.cx := DevCtx.ViewPortExt.x; 9094 OldSize^.cy := DevCtx.ViewPortExt.y; 9095 end; 9096 if (XExtent <> DevCtx.ViewPortExt.x) or (YExtent <> DevCtx.ViewPortExt.y) then 9097 begin 9098 case DevCtx.MapMode of 9099 MM_ANISOTROPIC, MM_ISOTROPIC: 9100 begin 9101 DevCtx.ViewPortExt := Point(XExtent, YExtent); 9102 Result := True; 9103 end; 9104 end; 9105 end; 9106end; 9107 9108function TGtk2WidgetSet.SetViewPortOrgEx(DC: HDC; NewX, NewY: Integer; OldPoint: PPoint): Boolean; 9109var 9110 DevCtx: TGtkDeviceContext absolute DC; 9111begin 9112 Result := False; 9113 if not IsValidDC(DC) then Exit; 9114 if OldPoint <> nil then 9115 begin 9116 OldPoint^.x := DevCtx.ViewPortOrg.x; 9117 OldPoint^.y := DevCtx.ViewPortOrg.y; 9118 end; 9119 if (NewX <> DevCtx.ViewPortOrg.x) or (NewY <> DevCtx.ViewPortOrg.y) then 9120 begin 9121 DevCtx.ViewPortOrg := Point(NewX, NewY); 9122 Result := True; 9123 end; 9124end; 9125 9126function TGtk2WidgetSet.SetWindowExtEx(DC: HDC; XExtent, YExtent: Integer; OldSize: PSize): Boolean; 9127var 9128 DevCtx: TGtkDeviceContext absolute DC; 9129begin 9130 Result := False; 9131 if not IsValidDC(DC) then Exit; 9132 if OldSize <> nil then 9133 begin 9134 OldSize^.cx := DevCtx.WindowExt.x; 9135 OldSize^.cy := DevCtx.WindowExt.y; 9136 end; 9137 if (XExtent <> DevCtx.WindowExt.x) or (YExtent <> DevCtx.WindowExt.y) then 9138 begin 9139 case DevCtx.MapMode of 9140 MM_ANISOTROPIC, MM_ISOTROPIC: 9141 begin 9142 DevCtx.WindowExt := Point(XExtent, YExtent); 9143 Result := True; 9144 end; 9145 end; 9146 end; 9147 Result := True; 9148end; 9149 9150{------------------------------------------------------------------------------ 9151 Function: TextOut 9152 Params: DC: 9153 X: 9154 Y: 9155 Str: 9156 Count: 9157 Returns: 9158 9159 ------------------------------------------------------------------------------} 9160function TGtk2WidgetSet.SetWindowLong(Handle: HWND; Idx: Integer; 9161 NewLong: PtrInt): PtrInt; 9162var 9163 Data: Pointer; 9164 WidgetInfo: PWidgetInfo; 9165begin 9166 //TODO: Finish this; 9167 Result:=0; 9168 Data := {%H-}Pointer(NewLong); 9169 9170 case idx of 9171 GWL_WNDPROC : 9172 begin 9173 WidgetInfo := GetWidgetInfo({%H-}Pointer(Handle)); 9174 if WidgetInfo <> nil then 9175 WidgetInfo^.WndProc := NewLong; 9176 end; 9177 GWL_HINSTANCE : 9178 begin 9179 g_object_set_data({%H-}pgobject(Handle),'HINSTANCE',Data); 9180 end; 9181 GWL_HWNDPARENT : 9182 begin 9183 g_object_set_data({%H-}pgobject(Handle),'HWNDPARENT',Data); 9184 end; 9185 GWL_STYLE : 9186 begin 9187 WidgetInfo := GetWidgetInfo({%H-}Pointer(Handle)); 9188 if WidgetInfo <> nil then 9189 WidgetInfo^.Style := NewLong; 9190 end; 9191 GWL_EXSTYLE : 9192 begin 9193 WidgetInfo := GetWidgetInfo({%H-}Pointer(Handle)); 9194 if WidgetInfo <> nil then 9195 WidgetInfo^.ExStyle := NewLong; 9196 end; 9197 GWL_USERDATA : 9198 begin 9199 g_object_set_data({%H-}pgobject(Handle),'Userdata',Data); 9200 end; 9201 GWL_ID : 9202 begin 9203 g_object_set_data({%H-}pgobject(Handle),'ID',Data); 9204 end; 9205 end; //case 9206end; 9207 9208{------------------------------------------------------------------------------ 9209 function TGtk2WidgetSet.SetWindowOrgEx(DC : HDC; NewX, NewY : Integer; 9210 OldPoint: PPoint) : Boolean; 9211 9212 Sets the DC offset for the specified device context. 9213 ------------------------------------------------------------------------------} 9214function TGtk2WidgetSet.SetWindowOrgEx(dc: hdc; NewX, NewY: Integer; 9215 OldPoint: PPoint): Boolean; 9216var 9217 DevCtx: TGtkDeviceContext absolute DC; 9218begin 9219 if Assigned(OldPoint) then 9220 GetWindowOrgEx(DC, OldPoint); 9221 9222 if not IsValidDC(DC) then exit(False); 9223 9224 DevCtx.WindowOrg := Point(NewX, NewY); 9225 Result := True; 9226end; 9227 9228{------------------------------------------------------------------------------ 9229 function TGtk2WidgetSet.SetWindowPos(hWnd: HWND; hWndInsertAfter: HWND; 9230 X, Y, cx, cy: Integer; uFlags: UINT): Boolean; 9231 9232 hWnd: Widget to move 9233 hWndInsertAfter: 9234 HWND_BOTTOM to move bottommost 9235 HWND_TOP to move topmost 9236 the Widget, that should lie just on top of hWnd 9237 uFlags: 9238 SWP_NOMOVE: ignore X, Y 9239 SWP_NOSIZE: ignore cx, cy 9240 SWP_NOZORDER: ignore hWndInsertAfter 9241 SWP_NOREDRAW: skip instant redraw 9242 SWP_NOACTIVATE: skip switching focus 9243 9244 ------------------------------------------------------------------------------} 9245function TGtk2WidgetSet.SetWindowPos(hWnd: HWND; hWndInsertAfter: HWND; 9246 X, Y, cx, cy: Integer; uFlags: UINT): Boolean; 9247 9248 procedure SetZOrderOnFixedWidget(Widget, FixedWidget: PGtkWidget); 9249 var 9250 OldListItem: PGList; 9251 AfterWidget: PGtkWidget; 9252 AfterListItem: PGList; 9253 begin 9254 OldListItem:=FindFixedChildListItem(PGtkFixed(FixedWidget),Widget); 9255 if OldListItem=nil then begin 9256 DebugLn('TGtk2WidgetSet.SetWindowPos.SetZOrderOnFixedWidget WARNING: Widget not on parents fixed widget'); 9257 exit; 9258 end; 9259 AfterWidget:=nil; 9260 AfterListItem:=nil; 9261 if hWndInsertAfter=HWND_BOTTOM then begin 9262 //debugln('HWND_BOTTOM'); 9263 // HWND_BOTTOM 9264 end else if hWndInsertAfter=HWND_TOP then begin 9265 //debugln('HWND_TOP'); 9266 // HWND_TOP 9267 AfterListItem:=FindFixedLastChildListItem(PGtkFixed(FixedWidget)); 9268 end else if hWndInsertAfter=0 then begin 9269 DebugLn('TGtk2WidgetSet.SetWindowPos.SetZOrderOnFixedWidget WARNING: hWndInsertAfter=0'); 9270 exit; 9271 end else begin 9272 // hWndInsertAfter 9273 AfterWidget:={%H-}PGtkWidget(hWndInsertAfter); 9274 AfterListItem:=FindFixedChildListItem(PGtkFixed(FixedWidget),AfterWidget); 9275 //debugln('AfterWidget=',GetWidgetDebugReport(AfterWidget)); 9276 end; 9277 if (AfterListItem=nil) and (AfterWidget<>nil) then begin 9278 DebugLn('TGtk2WidgetSet.SetWindowPos.SetZOrderOnFixedWidget WARNING: AfterWidget not on parents fixed widget'); 9279 exit; 9280 end; 9281 if (OldListItem=AfterListItem) or (OldListItem^.next=AfterListItem) then 9282 begin 9283 {$IFDEF EnableGtkZReordering} 9284 DebugLn('TGtk2WidgetSet.SetWindowPos.SetZOrderOnFixedWidget Hint: Already there'); 9285 {$ENDIF} 9286 exit; 9287 end; 9288 //DebugLn('TGtk2WidgetSet.SetWindowPos Moving GList entry'); 9289 9290 // reorder 9291 {$IFDEF EnableGtkZReordering} 9292 // MG: This trick does not work properly 9293 debugln('SetZOrderOnFixedWidget FixedWidget=['+GetWidgetDebugReport(FixedWidget)+']', 9294 ' Widget=['+GetWidgetDebugReport(Widget)+']', 9295 ' AfterWidget=['+GetWidgetDebugReport(AfterWidget)+']'); 9296 MoveGListLinkBehind(PGtkFixed(FixedWidget)^.children, 9297 OldListItem,AfterListItem); 9298 if GTK_WIDGET_VISIBLE(FixedWidget) and GTK_WIDGET_VISIBLE(Widget) 9299 and GTK_WIDGET_MAPPED(Widget) then begin 9300 DebugLn('TGtk2WidgetSet.SetWindowPos.SetZOrderOnFixedWidget resize ..'); 9301 gtk_widget_queue_resize(FixedWidget); 9302 AfterListItem:=PGtkFixed(FixedWidget)^.children; 9303 while AfterListItem<>nil do begin 9304 AfterWidget:=GetFixedChildListWidget(AfterListItem); 9305 DebugLn('TGtk2WidgetSet.SetWindowPos.SetZOrderOnFixedWidget A ',GetWidgetDebugReport(AfterWidget)); 9306 AfterListItem:=AfterListItem^.next; 9307 end; 9308 end; 9309 {$ENDIF} 9310 end; 9311 9312 procedure SetZOrderOnLayoutWidget({%H-}Widget, {%H-}LayoutWidget: PGtkWidget); 9313 begin 9314 //DebugLn('TGtk2WidgetSet.SetWindowPos.SetZOrderOnLayoutWidget Not implemented: ZOrdering .. on ',GetWidgetDebugReport(LayoutWidget)); 9315 end; 9316 9317var 9318 Widget: PGTKWidget; 9319 FixedWidget: PGtkWidget; 9320 Allocation: TGTKAllocation; 9321begin 9322 Result:=false; 9323 Widget:={%H-}PGtkWidget(hWnd); 9324 {DebugLn('[TGtk2WidgetSet.SetWindowPos] ',GetWidgetDebugReport(Widget), 9325 ' Top=',hWndInsertAfter=HWND_TOP, 9326 ' SWP_NOZORDER=',(SWP_NOZORDER and uFlags)<>0, 9327 ' SWP_NOSIZE=',(SWP_NOSIZE and uFlags)<>0, 9328 ' SWP_NOMOVE=',(SWP_NOMOVE and uFlags)<>0, 9329 '');} 9330 if GtkWidgetIsA(Widget,GTK_TYPE_WINDOW) then 9331 begin 9332 Result := True; 9333 exit; 9334 { case hWndInsertAfter of 9335 HWND_BOTTOM: ; //gdk_window_lower(Widget^.Window); 9336 HWND_TOP: gtk_window_set_position(PGtkWindow(hWnd),GTK_WIN_POS_CENTER); 9337 //gdk_window_raise(Widget^.Window); 9338 end; 9339 } 9340 end; 9341 9342 if (SWP_NOMOVE and uFlags = 0) and (SWP_NOSIZE and uFlags = 0) then 9343 begin 9344 // optimize if pos & size needed, so we allocate in one shot. 9345 Allocation.X := X; 9346 Allocation.Y := Y; 9347 Allocation.Width := cx; 9348 Allocation.Height := cy; 9349 gtk_widget_size_allocate(Widget, @Allocation); 9350 end else 9351 begin 9352 if (SWP_NOMOVE and uFlags = 0) then 9353 begin 9354 Allocation.X := X; 9355 Allocation.Y := Y; 9356 Allocation.Width := Widget^.Allocation.Width; 9357 Allocation.Height := Widget^.Allocation.Height; 9358 gtk_widget_size_allocate(Widget, @Allocation); 9359 end; 9360 9361 if (SWP_NOSIZE and uFlags = 0) then 9362 begin 9363 Allocation.X := Widget^.Allocation.x; 9364 Allocation.Y := Widget^.Allocation.y; 9365 Allocation.Width := cx; 9366 Allocation.Height := cy; 9367 gtk_widget_size_allocate(Widget, @Allocation); 9368 end; 9369 end; 9370 9371 if (SWP_NOZORDER and uFlags)=0 then 9372 begin 9373 FixedWidget:=Widget^.Parent; 9374 if FixedWidget=nil then exit; 9375 9376 //DebugLn('TGtk2WidgetSet.SetWindowPos ZOrdering .. on ',GetWidgetDebugReport(FixedWidget)); 9377 if GtkWidgetIsA(FixedWidget,GTK_Fixed_Get_Type) then begin 9378 // parent's client area is a gtk_fixed widget 9379 SetZOrderOnFixedWidget(Widget,FixedWidget); 9380 end else if GtkWidgetIsA(FixedWidget,GTK_Layout_Get_Type) then begin 9381 // parent's client area is a gtk_layout widget 9382 SetZOrderOnLayoutWidget(Widget,FixedWidget); 9383 end else begin 9384 //DebugLn('TGtk2WidgetSet.SetWindowPos Not implemented: ZOrdering .. on ',GetWidgetDebugReport(FixedWidget)); 9385 exit; 9386 end; 9387 end; 9388 Result:=true; 9389end; 9390 9391{------------------------------------------------------------------------------ 9392 Function SetWindowRgn 9393 Params: hWnd: HWND; hRgn: HRGN; bRedraw: Boolean 9394 Returns: 0 - fails, in other case success 9395------------------------------------------------------------------------------} 9396function TGtk2WidgetSet.SetWindowRgn(hWnd: HWND; hRgn: HRGN; bRedraw: Boolean): longint; 9397var 9398 Widget: PGtkWidget; 9399 Window: PGdkWindow; 9400 ShapeRegion: PGdkRegion; 9401 LCLObject: TObject; 9402begin 9403 // For normal widgets we should use GetFixedWidget, 9404 // but for TForm we should apply the region in the raw hWnd 9405 LCLObject := GetLCLObject({%H-}PGtkWidget(hWnd)); 9406 if LCLObject is TCustomForm then 9407 begin 9408 Widget := {%H-}PGtkWidget(hWnd); 9409 end 9410 else 9411 begin 9412 Widget := GetFixedWidget({%H-}PGtkWidget(hWnd)); 9413 if Widget = nil then 9414 Widget := {%H-}PGtkWidget(hWnd); 9415 end; 9416 if Widget = nil then 9417 Exit(0); 9418 if GtkWidgetIsA(gtk_widget_get_toplevel(Widget), gtk_window_get_type) 9419 and not gtk_widget_realized(Widget) then 9420 gtk_widget_realize(Widget); // associate with window 9421 Window := GetControlWindow(Widget); 9422 if Window = nil then 9423 Exit(0); 9424 if hRgn = 0 then 9425 ShapeRegion := nil 9426 else 9427 ShapeRegion := {%H-}PGDIObject(hRgn)^.GDIRegionObject; 9428 gdk_window_shape_combine_region(Window, ShapeRegion, 0, 0); 9429 if bRedraw then 9430 gdk_window_invalidate_region(Window, ShapeRegion, True); 9431 Result := 1; 9432end; 9433 9434{------------------------------------------------------------------------------ 9435 Function: ShowCaret 9436 Params: none 9437 Returns: Nothing 9438 9439 9440 ------------------------------------------------------------------------------} 9441function TGtk2WidgetSet.ShowCaret(hWnd: HWND): Boolean; 9442var 9443 GTKObject: PGTKObject; 9444begin 9445 GTKObject := {%H-}PGTKObject(HWND); 9446 Result := GTKObject <> nil; 9447 9448 if Result 9449 then begin 9450 if gtk_type_is_a(g_object_type(GTKObject), GTKAPIWidget_GetType) 9451 then begin 9452 GTKAPIWidget_ShowCaret(PGTKAPIWidget(GTKObject)); 9453 end 9454 else begin 9455 Result := False; 9456 end; 9457 end 9458 else DebugLn('WARNING: [TGtk2WidgetSet.ShowCaret] Got null HWND'); 9459end; 9460 9461{------------------------------------------------------------------------------ 9462 Function: ShowScrollBar 9463 Params: Wnd, wBar, bShow 9464 Returns: Nothing 9465 9466 9467 ------------------------------------------------------------------------------} 9468function TGtk2WidgetSet.ShowScrollBar(Handle: HWND; wBar: Integer; 9469 bShow: Boolean): Boolean; 9470var 9471 NewPolicy: Integer; 9472 Scroll: PGtkWidget; 9473 IsScrollWindow: Boolean; 9474begin 9475 Result := (Handle <> 0); 9476 if not Result then exit; 9477 9478 Scroll := PGtkWidget(g_object_get_data({%H-}PGObject(Handle), odnScrollArea)); 9479 if GtkWidgetIsA(Scroll, gtk_scrolled_window_get_type) 9480 then begin 9481 IsScrollWindow := True; 9482 end 9483 else begin 9484 Scroll := {%H-}PGTKWidget(Handle); 9485 IsScrollWindow := GtkWidgetIsA(Scroll, gtk_scrolled_window_get_type); 9486 end; 9487 9488 //DebugLn(['TGtk2WidgetSet.ShowScrollBar ',GetWidgetDebugReport(Scroll),' wBar=',wBar,' bShow=',bShow]); 9489 if IsScrollWindow then begin 9490 if wBar in [SB_BOTH, SB_HORZ] then begin 9491 //DebugLn(['TGtk2WidgetSet.ShowScrollBar ',GetWidgetDebugReport(Widget),' bShow=',bShow]); 9492 if bShow then 9493 NewPolicy:=GTK_POLICY_ALWAYS 9494 else 9495 NewPolicy:=GTK_POLICY_NEVER; 9496 g_object_set(PGTKObject(Scroll), 'hscrollbar_policy', [NewPolicy,nil]); 9497 end; 9498 if wBar in [SB_BOTH, SB_VERT] then begin 9499 if bShow then 9500 NewPolicy:=GTK_POLICY_ALWAYS 9501 else 9502 NewPolicy:=GTK_POLICY_NEVER; 9503 g_object_set(PGTKObject(Scroll), 'vscrollbar_policy', [NewPolicy,nil]); 9504 end; 9505 end 9506 else begin 9507 if (wBar = SB_CTL) 9508 and gtk_type_is_a(g_object_type({%H-}PGTKObject(Handle)),gtk_widget_get_type) 9509 then begin 9510 if bShow 9511 then gtk_widget_show(Scroll) 9512 else gtk_widget_hide(Scroll); 9513 end; 9514 end; 9515end; 9516 9517{------------------------------------------------------------------------------ 9518 function ShowWindow(hWnd: HWND; nCmdShow: Integer): Boolean; 9519 9520 nCmdShow: 9521 SW_SHOWNORMAL, SW_MINIMIZE, SW_SHOWMAXIMIZED 9522------------------------------------------------------------------------------} 9523function TGtk2WidgetSet.ShowWindow(hWnd: HWND; nCmdShow: Integer): Boolean; 9524var 9525 GtkWindow: PGtkWindow; 9526 B: Boolean; 9527 Widget: PGtkWidget; 9528 AFlags: TGdkWindowState; 9529 AWindow: PGdkWindow; 9530begin 9531 Result := False; 9532 9533 Widget := {%H-}PGtkWidget(HWND); 9534 9535 if Widget = nil then 9536 RaiseGDBException('TGtk2WidgetSet.ShowWindow hWnd is nil'); 9537 9538 if GTK_IS_WINDOW(Widget) then 9539 GtkWindow := {%H-}PGtkWindow(hWnd) 9540 else 9541 begin 9542 // we are pure gtkwidget so only SW_SHOW AND SW_HIDE CAN GO 9543 case nCmdShow of 9544 SW_SHOWNORMAL, 9545 SW_SHOW: gtk_widget_show(Widget); 9546 SW_HIDE: gtk_widget_hide(Widget); 9547 end; 9548 Result := nCmdShow in [SW_SHOW, SW_HIDE]; 9549 exit; 9550 end; 9551 9552 9553 B := (PGtkWidget(GtkWindow)^.parent <> nil) and 9554 (PGtkWidget(GtkWindow)^.parent^.window <> nil) and 9555 (PGtkWidget(GtkWindow)^.parent^.window = PGtkWidget(GtkWindow)^.window); 9556 9557 if not B and not GTK_IS_WINDOW(PGtkWidget(GtkWindow)) then 9558 begin 9559 DebugLn(['TGtk2WidgetSet.ShowWindow ',GetWidgetDebugReport(PGTKWidget(GtkWindow))]); 9560 RaiseGDBException('TGtk2WidgetSet.ShowWindow hWnd is not a gtkwindow'); 9561 end; 9562 9563 //debugln('TGtk2WidgetSet.ShowWindow A ',GetWidgetDebugReport(PGtkWidget(GtkWindow)),' nCmdShow=',dbgs(nCmdShow),' SW_MINIMIZE=',dbgs(SW_MINIMIZE=nCmdShow)); 9564 9565 case nCmdShow of 9566 9567 SW_SHOWNORMAL: 9568 begin 9569 if B then 9570 gtk_widget_show(PGtkWidget(GtkWindow)) 9571 else 9572 begin 9573 if not GTK_WIDGET_VISIBLE(PGtkWidget(GtkWindow)) then 9574 gtk_widget_show(PGtkWidget(GtkWindow)); 9575 AWindow := PGtkWidget(GtkWindow)^.window; 9576 if GDK_IS_WINDOW(AWindow) then 9577 begin 9578 AFlags := gdk_window_get_state(AWindow); 9579 if AFlags and GDK_WINDOW_STATE_ICONIFIED <> 0 then 9580 gtk_window_deiconify(GtkWindow); 9581 if AFlags and GDK_WINDOW_STATE_MAXIMIZED <> 0 then 9582 gtk_window_unmaximize(GtkWindow); 9583 if AFlags and GDK_WINDOW_STATE_FULLSCREEN <> 0 then 9584 gtk_window_unfullscreen(GtkWindow); 9585 end; 9586 end; 9587 end; 9588 9589 SW_HIDE: 9590 gtk_widget_hide(PGtkWidget(GtkWindow)); 9591 9592 SW_MINIMIZE: 9593 if not B then 9594 gtk_window_iconify(GtkWindow); 9595 9596 SW_SHOWMAXIMIZED: 9597 if B then 9598 gtk_widget_show(PGtkWidget(GtkWindow)) 9599 else 9600 begin 9601 AWindow := PGtkWidget(GtkWindow)^.window; 9602 if GDK_IS_WINDOW(AWindow) then 9603 begin 9604 AFlags := gdk_window_get_state(AWindow); 9605 if AFlags and GDK_WINDOW_STATE_ICONIFIED <> 0 then 9606 gtk_window_deiconify(GtkWindow); 9607 if AFlags and GDK_WINDOW_STATE_FULLSCREEN <> 0 then 9608 gtk_window_unfullscreen(GtkWindow); 9609 gtk_window_maximize(GtkWindow); 9610 end; 9611 end; 9612 9613 SW_SHOWFULLSCREEN: 9614 if B then 9615 gtk_widget_show(PGtkWidget(GtkWindow)) 9616 else 9617 gtk_window_fullscreen(GtkWindow); 9618 9619 SW_RESTORE: 9620 begin 9621 AWindow := PGtkWidget(GtkWindow)^.window; 9622 if GDK_IS_WINDOW(AWindow) then 9623 begin 9624 AFlags := gdk_window_get_state(AWindow); 9625 if AFlags and GDK_WINDOW_STATE_ICONIFIED <> 0 then 9626 gtk_window_deiconify(GtkWindow); 9627 if AFlags and GDK_WINDOW_STATE_MAXIMIZED <> 0 then 9628 gtk_window_unmaximize(GtkWindow); 9629 if AFlags and GDK_WINDOW_STATE_FULLSCREEN <> 0 then 9630 gtk_window_unfullscreen(GtkWindow); 9631 end; 9632 end; 9633 end; 9634 9635 Result := True; 9636end; 9637 9638{------------------------------------------------------------------------------ 9639 Function: StretchBlt 9640 Params: DestDC: The destination devicecontext 9641 X, Y: The left/top corner of the destination rectangle 9642 Width, Height: The size of the destination rectangle 9643 SrcDC: The source devicecontext 9644 XSrc, YSrc: The left/top corner of the source rectangle 9645 SrcWidth, SrcHeight: The size of the source rectangle 9646 ROp: The raster operation to be performed 9647 Returns: True if succesful 9648 9649 The StretchBlt function copies a bitmap from a source rectangle into a 9650 destination rectangle using the specified raster operation. If needed it 9651 resizes the bitmap to fit the dimensions of the destination rectangle. 9652 Sizing is done according to the stretching mode currently set in the 9653 destination device context. 9654 If SrcDC contains a mask the pixmap will be copied with this transparency. 9655 9656 ToDo: Mirroring, extended NonDrawable support (Image, Bitmap, etc) 9657 ------------------------------------------------------------------------------} 9658function TGtk2WidgetSet.StretchBlt(DestDC: HDC; X, Y, Width, Height: Integer; 9659 SrcDC: HDC; XSrc, YSrc, SrcWidth, SrcHeight: Integer; ROp: Cardinal): Boolean; 9660begin 9661 Result:=StretchCopyArea(DestDC,X,Y,Width,Height, 9662 SrcDC,XSrc,YSrc,SrcWidth,SrcHeight, 9663 0,0,0, 9664 ROp); 9665end; 9666 9667{------------------------------------------------------------------------------ 9668 Function: StretchMaskBlt 9669 Params: DestDC: The destination devicecontext 9670 X, Y: The left/top corner of the destination rectangle 9671 Width, Height: The size of the destination rectangle 9672 SrcDC: The source devicecontext 9673 XSrc, YSrc: The left/top corner of the source rectangle 9674 SrcWidth, SrcHeight: The size of the source rectangle 9675 Mask: The handle of a monochrome bitmap 9676 XMask, YMask: The left/top corner of the mask rectangle 9677 ROp: The raster operation to be performed 9678 Returns: True if succesful 9679 9680 The StretchMaskBlt function copies a bitmap from a source rectangle into a 9681 destination rectangle using the specified mask and raster operation. If needed 9682 it resizes the bitmap to fit the dimensions of the destination rectangle. 9683 Sizing is done according to the stretching mode currently set in the 9684 destination device context. 9685 ------------------------------------------------------------------------------} 9686function TGtk2WidgetSet.StretchMaskBlt(DestDC: HDC; X, Y, Width, Height: Integer; 9687 SrcDC: HDC; XSrc, YSrc, SrcWidth, SrcHeight: Integer; Mask: HBITMAP; 9688 XMask, YMask: Integer; Rop: DWORD): Boolean; 9689begin 9690 Result:=StretchCopyArea(DestDC,X,Y,Width,Height, 9691 SrcDC,XSrc,YSrc,SrcWidth,SrcHeight, 9692 Mask,XMask,YMask, 9693 Rop); 9694end; 9695 9696function TGtk2WidgetSet.SystemParametersInfo(uiAction: DWord; uiParam: DWord; 9697 pvParam: Pointer; fWinIni: DWord): LongBool; 9698{$IFDEF HASX} 9699var 9700 ax, ay, awidth, aheight: gint; 9701{$ENDIF} 9702begin 9703 Result:=True; 9704 Case uiAction of 9705 SPI_GETWHEELSCROLLLINES: PDword(pvParam)^ := 3; 9706 SPI_GETWORKAREA: 9707 begin 9708 {$IFDEF HASX} 9709 if XGetWorkarea(ax, ay, awidth, aheight) <> -1 then 9710 TRect(pvParam^) := Bounds(ax, ay, awidth, aheight) 9711 else 9712 {$ENDIF} 9713 TRect(pvParam^):=Bounds(GetSystemMetrics(SM_XVIRTUALSCREEN), 9714 GetSystemMetrics(SM_YVIRTUALSCREEN), 9715 GetSystemMetrics(SM_CXVIRTUALSCREEN), 9716 GetSystemMetrics(SM_CYVIRTUALSCREEN)); 9717 end; 9718 else 9719 Result:=False; 9720 end; 9721end; 9722 9723{------------------------------------------------------------------------------ 9724 Function: TextOut 9725 Params: DC: 9726 X: 9727 Y: 9728 Str: 9729 Count: 9730 Returns: 9731 9732 ------------------------------------------------------------------------------} 9733function TGtk2WidgetSet.TextOut(DC: HDC; X, Y: Integer; Str: Pchar; 9734 Count: Integer) : Boolean; 9735var 9736 DevCtx: TGtkDeviceContext absolute DC; 9737 DCOrigin: TPoint; 9738 yOffset: integer; 9739 BackGroundColor: PGdkColor; 9740begin 9741 Result := IsValidDC(DC); 9742 if not Result then Exit; 9743 if Count <= 0 then Exit; 9744 9745 if DevCtx.HasTransf then 9746 DevCtx.TransfPoint(X, Y); 9747 9748 UpdateDCTextMetric(DevCtx); 9749 DCOrigin := DevCtx.Offset; 9750 9751 with DevCtx.DCTextMetric.TextMetric do 9752 yOffset := tmHeight-tmDescent-tmAscent; 9753 if yOffset < 0 then 9754 yOffset := 0; 9755 9756 DevCtx.SelectedColors := dcscCustom; 9757 EnsureGCColor(DC, dccCurrentTextColor, True, False); 9758 9759 BackGroundColor := nil; 9760 if DevCtx.BkMode = OPAQUE then 9761 begin 9762 AllocGDIColor(DC, @DevCtx.CurrentBackColor); 9763 BackGroundColor := @DevCtx.CurrentBackColor.Color; 9764 end; 9765 9766 DevCtx.DrawTextWithColors(Str, Count, 9767 X + DCOrigin.X, Y + DCOrigin.Y + yOffset, 9768 nil, BackGroundColor); 9769end; 9770 9771function TGtk2WidgetSet.UpdateWindow(Handle: HWND): Boolean; 9772var 9773 CurWidget: PGtkWidget; 9774begin 9775 CurWidget:={%H-}PGTKWidget(Handle); 9776 //DebugLn(['TGtk2WidgetSet.UpdateWindow ',GetWidgetDebugReport(CurWidget)]); 9777 if GTK_WIDGET_DRAWABLE(CurWidget) then begin 9778 //DebugLn(['TGtk2WidgetSet.UpdateWindow DRAWING']); 9779 gtk_widget_queue_draw(CurWidget); 9780 if GDK_IS_WINDOW(CurWidget^.Window) then 9781 gdk_window_process_updates(CurWidget^.window,TRUE); 9782 Result:=true; 9783 end else 9784 Result:=false; 9785end; 9786 9787 9788{------------------------------------------------------------------------------ 9789 Function: WindowFromPoint 9790 Params: Point: Specifies the x and y Coords 9791 Returns: The handle of the gtkwidget. If none exist, then NULL is returned. 9792 9793 ------------------------------------------------------------------------------} 9794function TGtk2WidgetSet.WindowFromPoint(APoint: TPoint): HWND; 9795var 9796 ev: TgdkEvent; 9797 Window: PgdkWindow; 9798 Widget: PgtkWidget; 9799 p: TPoint; 9800 WidgetInfo: PWidgetInfo; 9801begin 9802 // return cached value to prevent heavy gdk_display_get_window_at_pointer call 9803 if (APoint = LastWFPMousePos) and GTK_IS_OBJECT({%H-}Pointer(LastWFPResult)) and 9804 GTK_WIDGET_VISIBLE({%H-}PGtkWidget(LastWFPResult)) and 9805 GTK_WIDGET_IS_SENSITIVE({%H-}PGtkWidget(LastWFPResult)) then 9806 Exit(LastWFPResult); 9807 Result := 0; 9808 9809 WidgetInfo := nil; 9810 // we are using gdk_display_get_window_at_pointer instead of 9811 // gdk_window_at_pointer because of multihead support. 9812 // !! changes the coordinates !! -> using local variable p 9813 p := APoint; 9814 Window := gdk_display_get_window_at_pointer(gdk_display_get_default, 9815 @p.x, @p.y); 9816 if window <> nil then 9817 begin 9818 FillChar(ev{%H-}, SizeOf(ev), 0); 9819 ev.any.window := Window; 9820 Widget := gtk_get_event_widget(@ev); 9821 Result := {%H-}PtrUInt(Widget); 9822 if Result <> 0 then 9823 begin 9824 WidgetInfo := GetWidgetInfo(Widget); 9825 if WidgetInfo = nil then 9826 begin 9827 // complex controls eg. ScrollBar of TTreeView 9828 WidgetInfo := GetWidgetInfo(Widget^.parent); 9829 if WidgetInfo <> nil then 9830 Result := {%H-}PtrUInt(Widget^.parent); 9831 end; 9832 end; 9833 end; 9834 // disconnect old handler 9835 if GTK_IS_OBJECT({%H-}Pointer(LastWFPResult)) then 9836 begin 9837 g_signal_handlers_disconnect_by_func({%H-}GPointer(LastWFPResult), 9838 TGTKSignalFunc(@DestroyWindowFromPointCB), nil); 9839 end; 9840 9841 // see issue #17389 9842 if (WidgetInfo <> nil) and (WidgetInfo^.LCLObject <> nil) 9843 and (WidgetInfo^.LCLObject is TWinControl) then 9844 Result := TWinControl(WidgetInfo^.LCLObject).Handle; 9845 9846 // now we must check if we are visible and enabled 9847 if Result <> 0 then 9848 begin 9849 if not GTK_WIDGET_VISIBLE({%H-}PGtkWidget(Result)) or 9850 not GTK_WIDGET_IS_SENSITIVE({%H-}PGtkWidget(Result)) then 9851 Result := 0; 9852 end; 9853 9854 LastWFPMousePos := APoint; 9855 LastWFPResult := Result; 9856 // connect handler 9857 if LastWFPResult <> 0 then 9858 begin 9859 g_signal_connect({%H-}GPointer(LastWFPResult), 'destroy', 9860 TGTKSignalFunc(@DestroyWindowFromPointCB), nil); 9861 end; 9862end; 9863 9864//##apiwiz##eps## // Do not remove 9865 9866// Placed CriticalSectionSupport outside the API wizard bounds 9867// so it won't affect sorting etc. 9868 9869{$IfNDef DisableCriticalSections} 9870 9871 {$IfDef Unix} 9872 9873 {$Define pthread} 9874 9875 {Type 9876 _pthread_fastlock = packed record 9877 __status: Longint; 9878 __spinlock: Integer; 9879 end; 9880 9881 pthread_mutex_t = packed record 9882 __m_reserved: Integer; 9883 __m_count: Integer; 9884 __m_owner: Pointer; 9885 __m_kind: Integer; 9886 __m_lock: _pthread_fastlock; 9887 end; 9888 ppthread_mutex_t = ^pthread_mutex_t; 9889 9890 pthread_mutexattr_t = packed record 9891 __mutexkind: Integer; 9892 end;} 9893 9894 {$linklib pthread} 9895 9896 {function pthread_mutex_init(var Mutex: pthread_mutex_t; 9897 var Attr: pthread_mutexattr_t): Integer; cdecl;external; 9898 function pthread_mutexattr_settype(var Attr: pthread_mutexattr_t; 9899 Kind: Integer): Integer; cdecl;external; 9900 function pthread_mutex_lock(var Mutex: pthread_mutex_t): 9901 Integer; cdecl; external; 9902 function pthread_mutex_unlock(var Mutex: pthread_mutex_t): 9903 Integer; cdecl; external; 9904 function pthread_mutex_destroy(var Mutex: pthread_mutex_t): 9905 Integer; cdecl; external;} 9906 {$EndIf} 9907 9908{$EndIf} 9909 9910procedure TGtk2WidgetSet.InitializeCriticalSection(var CritSection: TCriticalSection); 9911{$IfDef pthread} 9912var 9913 ACritSec: System.PRTLCriticalSection; 9914begin 9915 New(ACritSec); 9916 System.InitCriticalSection(ACritSec^); 9917 CritSection:={%H-}TCriticalSection(ACritSec); 9918end; 9919{var 9920 Crit : ppthread_mutex_t; 9921 Attribute: pthread_mutexattr_t; 9922begin 9923 if pthread_mutexattr_settype(Attribute, 1) <> 0 then 9924 Exit; 9925 If CritSection <> 0 then 9926 Try 9927 Crit := ppthread_mutex_t(CritSection); 9928 Dispose(Crit); 9929 except 9930 CritSection := 0; 9931 end; 9932 New(Crit); 9933 pthread_mutex_init(Crit^, Attribute); 9934 CritSection := Longint(Crit); 9935end;} 9936{$Else} 9937begin 9938end; 9939{$EndIf} 9940 9941procedure TGtk2WidgetSet.EnterCriticalSection(var CritSection: TCriticalSection); 9942{$IfDef pthread} 9943var 9944 ACritSec: System.PRTLCriticalSection; 9945begin 9946 ACritSec:={%H-}System.PRTLCriticalSection(CritSection); 9947 System.EnterCriticalsection(ACritSec^); 9948end; 9949{$Else} 9950begin 9951end; 9952{$EndIf} 9953 9954procedure TGtk2WidgetSet.LeaveCriticalSection(var CritSection: TCriticalSection); 9955{$IfDef pthread} 9956var 9957 ACritSec: System.PRTLCriticalSection; 9958begin 9959 ACritSec:={%H-}System.PRTLCriticalSection(CritSection); 9960 System.LeaveCriticalsection(ACritSec^); 9961end; 9962{$Else} 9963begin 9964end; 9965{$EndIf} 9966 9967procedure TGtk2WidgetSet.DeleteCriticalSection(var CritSection: TCriticalSection); 9968{$IfDef pthread} 9969var 9970 ACritSec: System.PRTLCriticalSection; 9971begin 9972 ACritSec:={%H-}System.PRTLCriticalSection(CritSection); 9973 System.DoneCriticalsection(ACritSec^); 9974 Dispose(ACritSec); 9975 CritSection:=0; 9976end; 9977{$Else} 9978begin 9979end; 9980{$EndIf} 9981 9982{$IfDef ASSERT_IS_ON} 9983 {$UNDEF ASSERT_IS_ON} 9984 {$C-} 9985{$EndIf} 9986 9987 9988 9989