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