1{%MainUnit gtk2int.pas} 2{****************************************************************************** 3 TGtk2WidgetSet 4 ****************************************************************************** 5 6 ***************************************************************************** 7 This file is part of the Lazarus Component Library (LCL) 8 9 See the file COPYING.modifiedLGPL.txt, included in this distribution, 10 for details about the license. 11 ***************************************************************************** 12} 13 14{$IFOPT C-} 15// Uncomment for local trace 16// {$C+} 17// {$DEFINE ASSERT_IS_ON} 18{$ENDIF} 19 20{$IFNDEF USE_GTK_MAIN_OLD_ITERATION} 21var 22 Gtk2MPF: TGPollFunc; 23 24function Gtk2PollFunction(ufds:PGPollFD; nfsd:guint; timeout:gint):gint;cdecl; 25begin 26 Result := nfsd; 27 if TimeOut = -1 then 28 Gtk2WidgetSet.FMainPoll := ufds 29 else 30 Gtk2WidgetSet.FMainPoll := nil; 31 if Gtk2MPF <> nil then 32 begin 33 if (glib_major_version = 2) and (glib_minor_version < 24) and 34 (Gtk2WidgetSet.FMainPoll <> nil) then 35 begin 36 while (Gtk2WidgetSet.FMainPoll <> nil) and 37 (Gtk2WidgetSet.FMainPoll^.revents = 0) do 38 begin 39 if (Gtk2MPF(ufds, nfsd, 1) = 1) or 40 (Gtk2WidgetSet.FMessageQueue.Count > 0) then 41 break; 42 end; 43 end else 44 Gtk2MPF(ufds, nfsd, timeout); 45 end; 46end; 47{$ENDIF} 48 49function GTK2FocusCB( widget: PGtkWidget; event:PGdkEventFocus; 50 data: gPointer) : GBoolean; cdecl; 51var 52 Status : gBoolean; 53begin 54 Status := GTKFocusCB(Widget, Event, Data); 55 56 if GtkWidgetIsA(Widget,GTK_APIWIDGETCLIENT_TYPE) then 57 Result := Status 58 else 59 Result := False; 60end; 61 62function gtk2HideCB( widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; 63var 64 Status : GBoolean; 65begin 66 Status := gtkHideCB(Widget, Data); 67 68 if GtkWidgetIsA(Widget,GTK_APIWIDGETCLIENT_TYPE) then 69 Result := Status 70 else 71 Result := False; 72end; 73 74function GTK2KillFocusCB(widget: PGtkWidget; event:PGdkEventFocus; 75 data: gPointer) : GBoolean; cdecl; 76var 77 Status : gBoolean; 78begin 79 Status := GTKKillFocusCB(Widget, Event, Data); 80 81 if GtkWidgetIsA(Widget,GTK_APIWIDGETCLIENT_TYPE) then 82 Result := Status 83 else 84 Result := False; 85end; 86 87function GTK2KillFocusCBAfter(widget: PGtkWidget; event:PGdkEventFocus; 88 data: gPointer) : GBoolean; cdecl; 89var 90 Status : gBoolean; 91begin 92 Status := GTKKillFocusCBAfter(Widget, Event, Data); 93 94 if GtkWidgetIsA(Widget,GTK_APIWIDGETCLIENT_TYPE) then 95 Result := Status 96 else 97 Result := False; 98end; 99 100function gtk2PopupMenuCB(Widget: PGtkWidget; data: gPointer): gboolean; cdecl; 101var 102 Msg: TLMContextMenu; 103begin 104 FillChar(Msg{%H-}, SizeOf(Msg), #0); 105 106 Msg.Msg := LM_CONTEXTMENU; 107 Msg.hWnd := {%H-}HWND(Widget); // todo: true keystate 108 109 // keyboard popup menu must have -1, -1 coords 110 Msg.XPos := -1; 111 Msg.YPos := -1; 112 113 Result := DeliverMessage(TComponent(data), Msg) <> 0; 114end; 115 116function gtk2showCB( widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; 117var 118 Status : GBoolean; 119begin 120 Status := gtkshowCB(Widget, Data); 121 122 if GtkWidgetIsA(Widget,GTK_APIWIDGETCLIENT_TYPE) then 123 Result := Status 124 else 125 Result := False; 126end; 127 128function gtk2ShowHelpCB(widget: PGtkWidget; arg1: TGtkWidgetHelpType; {%H-}data: gpointer): gboolean; cdecl; 129var 130 Info: THelpInfo; 131begin 132 if arg1 = GTK_WIDGET_HELP_WHATS_THIS then 133 begin 134 Info.cbSize := SizeOf(Info); 135 Info.iContextType := HELPINFO_WINDOW; 136 Info.iCtrlId := 0; 137 Info.hItemHandle := {%H-}THandle(widget); 138 Info.dwContextId := 0; 139 gdk_display_get_pointer(gdk_display_get_default(), nil, @Info.MousePos.X, @Info.MousePos.Y, nil); 140 Application.HelpCommand(0, {%H-}PtrInt(@Info)); 141 end; 142 Result := True; 143end; 144 145function gtk2GrabNotify({%H-}widget: PGtkWidget; grabbed: GBoolean; {%H-}data: GPointer): GBoolean; cdecl; 146// called for all widgets on every gtk_grab_add and gtk_grab_remove 147// grabbed = true if called by gtk_grab_remove 148// grabbed = false if called by gtk_grab_add 149var 150 CurCaptureWidget: PGtkWidget; 151begin 152 {$IFDEF VerboseMouseCapture} 153 //debugln(['gtk2GrabNotify ',GetWidgetDebugReport(widget),' grabbed=',grabbed,' MouseCaptureWidget=',dbgs(MouseCaptureWidget)]); 154 {$ENDIF} 155 Result := CallBackDefaultReturn; 156 if Grabbed then 157 begin 158 // grab release 159 CurCaptureWidget := gtk_grab_get_current; 160 if (MouseCaptureWidget<>nil) 161 and ((CurCaptureWidget=nil) or (CurCaptureWidget = MouseCaptureWidget)) then 162 begin 163 {$IFDEF VerboseMouseCapture} 164 debugln(['gtk2GrabNotify ungrab ',GetWidgetDebugReport(widget),' grabbed=',grabbed,' MouseCaptureWidget=',dbgs(MouseCaptureWidget)]); 165 {$ENDIF} 166 //Result := True; 167 ReleaseCaptureWidget(MouseCaptureWidget); 168 end; 169 end; 170end; 171 172 173procedure gtk_clb_toggle({%H-}cellrenderertoggle : PGtkCellRendererToggle; arg1 : PGChar; 174 WinControl: TWinControl); cdecl; 175var 176 aWidget : PGTKWidget; 177 aTreeModel : PGtkTreeModel; 178 aTreeIter : TGtkTreeIter; 179 value : pgValue; 180begin 181 aWidget := GetWidgetInfo({%H-}Pointer(WinControl.Handle), True)^.CoreWidget; 182 aTreeModel := gtk_tree_view_get_model (GTK_TREE_VIEW(aWidget)); 183 if (gtk_tree_model_get_iter_from_string (aTreeModel, @aTreeIter, arg1)) then begin 184 aTreeIter.stamp := GTK_LIST_STORE (aTreeModel)^.stamp; //strange hack 185 value := g_new0(SizeOf(TgValue), 1); 186 gtk_tree_model_get_value(aTreeModel, @aTreeIter, 0, value); 187 188 g_value_set_boolean(value, not g_value_get_boolean(value)); 189 190 gtk_list_store_set_value (GTK_LIST_STORE (aTreeModel), @aTreeIter, 0, value); 191 g_value_unset(value); 192 g_free(value); 193 end; 194end; 195 196procedure gtk_clb_toggle_row_activated(treeview : PGtkTreeView; arg1 : PGtkTreePath; 197 {%H-}arg2 : PGtkTreeViewColumn; {%H-}data : gpointer); cdecl; 198var 199 aTreeModel : PGtkTreeModel; 200 aTreeIter : TGtkTreeIter; 201 value : PGValue; 202begin 203 aTreeModel := gtk_tree_view_get_model (treeview); 204 if (gtk_tree_model_get_iter (aTreeModel, @aTreeIter, arg1)) then begin 205 aTreeIter.stamp := GTK_LIST_STORE (aTreeModel)^.stamp; //strange hack 206 value := g_new0(SizeOf(TgValue), 1); 207 gtk_tree_model_get_value(aTreeModel, @aTreeIter, 0, value); 208 209 g_value_set_boolean(value, not g_value_get_boolean(value)); 210 211 gtk_list_store_set_value (GTK_LIST_STORE (aTreeModel), @aTreeIter, 0, value); 212 g_value_unset(value); 213 g_free(value); 214 end; 215end; 216 217procedure gtk_commit_cb ({%H-}context: PGtkIMContext; const Str: Pgchar; 218 {%H-}Data: Pointer); cdecl; 219begin 220 //DebugLn(['gtk_commit_cb ',dbgstr(Str),'="',Str,'"']); 221 im_context_string:=Str; 222end; 223 224{------------------------------------------------------------------------------ 225 Function: TGtk2WidgetSet._SetCallbackEx 226 227 // originally TGtkWidgetSet.SetCallbackEx 228 229 Params: AMsg - message for which to set a callback 230 AGTKObject - object to which callback will be send 231 ALCLObject - for compatebility reasons provided, will be used when 232 AGTKObject = nil 233 Direct - true: connect the signal to the AGTKObject 234 false: choose smart what gtkobject to use 235 Returns: nothing 236 237 Applies a Message to the sender 238 ------------------------------------------------------------------------------} 239//TODO: remove ALCLObject when creation splitup is finished 240procedure TGtk2WidgetSet._SetCallbackEx(const AMsg: LongInt; 241 const AGTKObject: PGTKObject; const ALCLObject: TObject; Direct: Boolean); 242 243 procedure ConnectSenderSignal(const AnObject:PGTKObject; const ASignal: PChar; 244 const ACallBackProc: Pointer); 245 begin 246 ConnectSignal(AnObject,ASignal,ACallBackProc,ALCLObject); 247 end; 248 249 procedure ConnectSenderSignalAfter(const AnObject:PGTKObject; 250 const ASignal: PChar; const ACallBackProc: Pointer); 251 begin 252 ConnectSignalAfter(AnObject,ASignal,ACallBackProc,ALCLObject); 253 end; 254 255 procedure ConnectSenderSignal(const AnObject:PGTKObject; const ASignal: PChar; 256 const ACallBackProc: Pointer; const AReqSignalMask: TGdkEventMask); 257 begin 258 ConnectSignal(AnObject,ASignal,ACallBackProc,ALCLObject, AReqSignalMask); 259 end; 260 261 procedure ConnectSenderSignalAfter(const AnObject:PGTKObject; 262 const ASignal: PChar; const ACallBackProc: Pointer; 263 const AReqSignalMask: TGdkEventMask); 264 begin 265 ConnectSignalAfter(AnObject,ASignal,ACallBackProc,ALCLObject, 266 AReqSignalMask); 267 end; 268 269 procedure ConnectFocusEvents(const AnObject: PGTKObject); 270 begin 271 ConnectSenderSignal(AnObject, 'focus-in-event', @gtkFocusCB); 272 ConnectSenderSignal(AnObject, 'focus-out-event', @gtkKillFocusCB); 273 ConnectSenderSignalAfter(AnObject, 'focus-out-event', @gtkKillFocusCBAfter); 274 end; 275 276 procedure ConnectKeyPressReleaseEvents(const AnObject: PGTKObject); 277 begin 278 //debugln('ConnectKeyPressReleaseEvents A ALCLObject=',DbgSName(ALCLObject)); 279 ConnectSenderSignal(AnObject, 280 'key-press-event', @GTKKeyPress, GDK_KEY_PRESS_MASK); 281 ConnectSenderSignalAfter(AnObject, 282 'key-press-event', @GTKKeyPressAfter, GDK_KEY_PRESS_MASK); 283 ConnectSenderSignal(AnObject, 284 'key-release-event', @GTKKeyRelease, GDK_KEY_RELEASE_MASK); 285 ConnectSenderSignalAfter(AnObject, 286 'key-release-event', @GTKKeyReleaseAfter, GDK_KEY_RELEASE_MASK); 287 end; 288 289 function GetAdjustment(const gObject: PGTKObject; vertical: boolean):PGtkObject; 290 var 291 Scroll: PGtkObject; 292 begin 293 if Vertical then begin 294 if ALCLObject is TScrollBar then 295 result := PGtkObject(PgtkhScrollBar(gObject)^.Scrollbar.Range.Adjustment) 296 else if (ALCLObject is TScrollBox) 297 or (ALCLObject is TCustomForm) 298 or (ALCLObject is TCustomFrame) 299 then begin 300 Scroll := g_object_get_data(PGObject(gObject), odnScrollArea); 301 Result := PGtkObject(gtk_scrolled_window_get_vadjustment( 302 PGTKScrolledWindow(Scroll))); 303 end 304 else if GtkWidgetIsA(PGtkWidget(gObject),gtk_scrolled_window_get_type) then 305 begin 306 Result := PGtkObject(gtk_scrolled_window_get_vadjustment( 307 PGTKScrolledWindow(gObject))) 308 end else 309 DebugLn(['TGtkWidgetSet.SetCallbackEx.GetAdjustment WARNING: invalid widget: ',GetWidgetDebugReport(PGtkWidget(gObject))]); 310 311 end else begin 312 if ALCLObject is TScrollBar then 313 Result := PgtkObject(PgtkhScrollBar(gObject)^.Scrollbar.Range.Adjustment) 314 else if (ALCLObject is TScrollBox) 315 or (ALCLObject is TCustomForm) 316 or (ALCLObject is TCustomFrame) 317 then begin 318 Scroll := g_object_get_data(PGObject(gObject), odnScrollArea); 319 Result := PgtkObject(gtk_scrolled_window_get_hadjustment( 320 PGTKScrolledWindow(Scroll))); 321 end 322 else if GtkWidgetIsA(PGtkWidget(gObject),gtk_scrolled_window_get_type) then 323 begin 324 //DebugLn(['GetAdjustment ',GetWidgetDebugReport(PGtkWidget(gObject))]); 325 Result := PgtkObject(gtk_scrolled_window_get_hadjustment( 326 PGTKScrolledWindow(gObject))); 327 end else 328 DebugLn(['TGtkWidgetSet.SetCallbackEx.GetAdjustment WARNING: invalid widget: ',GetWidgetDebugReport(PGtkWidget(gObject))]); 329 end; 330 end; 331 332var 333 gObject, gFixed, gCore, Adjustment: PGTKObject; 334 gTemp: PGTKObject; 335 Info: PWidgetInfo; 336 gMain: PGtkObject; 337 gMouse: PGtkObject; 338begin 339 //debugln('TGtkWidgetSet.SetCallback A ALCLObject=',DbgSName(ALCLObject),' AMsg=',dbgs(AMsg)); 340 if Direct then 341 begin 342 gMain := AGTKObject; 343 gCore := AGTKObject; 344 gFixed := AGTKObject; 345 gMouse := AGTKObject; 346 gObject := AGTKObject; 347 end 348 else 349 begin 350 // gObject 351 if AGTKObject = nil then gObject := ObjectToGTKObject(ALCLObject) 352 else gObject := AGTKObject; 353 if gObject = nil then Exit; 354 355 Info:=GetWidgetInfo(gObject, True); 356 357 // gFixed is the widget with the client area (e.g. TGroupBox, TCustomForm have this) 358 gFixed := PGTKObject(GetFixedWidget(gObject)); 359 if gFixed = nil then 360 gFixed := gObject; 361 362 // gCore is the working widget (e.g. TListBox has a scrolling widget (=main widget) and a tree widget (=core widget)) 363 gCore:=PGtkObject(Info^.CoreWidget); 364 gMain:=GetMainWidget(gObject); 365 if (gMain<>gObject) then 366 DebugLn(['TGtkWidgetSet.SetCallback WARNING: gObject<>MainWidget ',DbgSName(ALCLObject)]); 367 368 if (gFixed <> gMain) then 369 gMouse := gFixed 370 else 371 gMouse := gCore; 372 373 if gMouse=nil then 374 DebugLn(['TGtkWidgetSet.SetCallback WARNING: gMouseWidget=nil ',DbgSName(ALCLObject)]); 375 376 if GTK_IS_FIXED(gMouse) and GTK_WIDGET_NO_WINDOW(gMouse) then 377 begin 378 gTemp := PGtkObject(gtk_widget_get_parent(PGtkWidget(gMouse))); 379 //DebugLn(gtk_type_name(g_object_type(gMouse)) + ' => ' + gtk_type_name(g_object_type(gTemp))); 380 if GTK_IS_EVENT_BOX(gTemp) then 381 gMouse := gTemp; 382 end; 383 end; 384 //DebugLn(['TGtkWidgetSet.SetCallbackSmart MouseWidget=',GetWidgetDebugReport(PGtkWidget(gMouse))]); 385 386 case AMsg of 387 LM_SHOWWINDOW : 388 begin 389 ConnectSenderSignal(gObject, 'show', @gtkshowCB); 390 ConnectSenderSignal(gObject, 'hide', @gtkhideCB); 391 end; 392 393 LM_DESTROY : 394 begin 395 //DebugLn(['TGtkWidgetSet.SetCallback ',DbgSName(ALCLObject)]); 396 ConnectSenderSignal(gObject, 'destroy', @gtkdestroyCB); 397 end; 398 399 LM_CLOSEQUERY : 400 begin 401 ConnectSenderSignal(gObject, 'delete-event', @gtkdeleteCB); 402 end; 403 404 LM_ACTIVATE : 405 begin 406 if (ALCLObject is TCustomForm) and (TCustomForm(ALCLObject).Parent=nil) 407 then begin 408 ConnectSenderSignal(gObject, 'focus-in-event', @gtkfrmactivateAfter); 409 ConnectSenderSignal(gObject, 'focus-out-event', @gtkfrmdeactivateAfter); 410 end else if ALCLObject is TCustomMemo then 411 ConnectSenderSignal(gCore, 'activate', @gtkactivateCB) 412 else 413 ConnectSenderSignal(gObject, 'activate', @gtkactivateCB); 414 end; 415 416 LM_ACTIVATEITEM : 417 begin 418 ConnectSenderSignal(gObject, 'activate-item', @gtkactivateCB); 419 end; 420 421 LM_CHANGED : 422 begin 423 if ALCLObject is TCustomTrackBar then 424 begin 425 ConnectSenderSignal(gtk_Object( 426 gtk_range_get_adjustment(GTK_RANGE(gObject))) , 427 'value_changed', @gtkvaluechanged); 428 end 429 else 430 if ALCLObject is TCustomMemo then 431 ConnectSenderSignal(gCore, 'changed', @gtkchanged_editbox) 432 else if ALCLObject is TCustomCheckbox then 433 begin 434 ConnectSenderSignal(gObject, 'toggled', @gtktoggledCB) 435 end else 436 begin 437 if GTK_IS_ENTRY(gObject) then 438 begin 439 ConnectSenderSignal(gObject,'delete-text', @gtkchanged_editbox_delete_text); 440 ConnectSenderSignal(gObject,'insert-text', @gtkchanged_editbox_insert_text); 441 ConnectSenderSignal(gObject,'delete-from-cursor', @gtkchanged_editbox_delete); 442 end; 443 ConnectSenderSignal(gObject, 'changed', @gtkchanged_editbox); 444 end; 445 end; 446 447 LM_CLICKED: 448 begin 449 ConnectSenderSignal(gObject, 'clicked', @gtkclickedCB); 450 end; 451 452 LM_CONFIGUREEVENT : 453 begin 454 ConnectSenderSignal(gObject, 'configure-event', @gtkconfigureevent); 455 end; 456 457 LM_DAYCHANGED : //calendar 458 Begin 459 ConnectSenderSignal(gCore, 'day-selected', @gtkdaychanged); 460 ConnectSenderSignal(gCore, 'day-selected-double-click', @gtkdaychanged); 461 end; 462 463 LM_PAINT : 464 begin 465 //DebugLn(['TGtkWidgetSet.SetCallback ',DbgSName(ALCLObject),' ',GetWidgetDebugReport(PGtkWIdget(gfixed))]); 466 ConnectSenderSignal(gFixed,'expose-event', @GTKExposeEvent); 467 ConnectSenderSignalAfter(gFixed,'expose-event', @GTKExposeEventAfter); 468 {$IFDEF EventTrace} 469 ConnectSenderSignal(gFixed,'style-set', @GTKStyleChanged); 470 ConnectSenderSignalAfter(gFixed,'style-set', @GTKStyleChangedAfter); 471 {$ENDIF} 472 end; 473 474 475 LM_MONTHCHANGED: //calendar 476 Begin 477 ConnectSenderSignal(gCore, 'month-changed', @gtkmonthchanged); 478 ConnectSenderSignal(gCore, 'prev-month', @gtkmonthchanged); 479 ConnectSenderSignal(gCore, 'next-month', @gtkmonthchanged); 480 end; 481 482 LM_MOUSEMOVE: 483 begin 484 ConnectSenderSignal(gMouse, 'motion-notify-event', @GTKMotionNotify, 485 GDK_POINTER_MOTION_HINT_MASK or GDK_POINTER_MOTION_MASK); 486 ConnectSenderSignalAfter(gMouse, 'motion-notify-event', 487 @GTKMotionNotifyAfter, 488 GDK_POINTER_MOTION_HINT_MASK or GDK_POINTER_MOTION_MASK); 489 end; 490 491 LM_LBUTTONDOWN, 492 LM_RBUTTONDOWN, 493 LM_MBUTTONDOWN, 494 LM_MOUSEWHEEL, 495 LM_MOUSEHWHEEL: 496 begin 497 ConnectSenderSignal(gMouse, 'button-press-event', @gtkMouseBtnPress, 498 GDK_BUTTON_PRESS_MASK); 499 ConnectSenderSignalAfter(gMouse, 'button-press-event', 500 @gtkMouseBtnPressAfter, GDK_BUTTON_PRESS_MASK); 501 ConnectSenderSignal(gMouse, 'scroll-event', @gtkMouseWheelCB, 502 GDK_BUTTON_PRESS_MASK); 503 end; 504 505 LM_LBUTTONUP, 506 LM_RBUTTONUP, 507 LM_MBUTTONUP: 508 begin 509 ConnectSenderSignal(gMouse, 'button-release-event', @gtkMouseBtnRelease, 510 GDK_BUTTON_RELEASE_MASK); 511 ConnectSenderSignalAfter(gMouse, 'button-release-event', 512 @gtkMouseBtnReleaseAfter,GDK_BUTTON_RELEASE_MASK); 513 end; 514 515 LM_ENTER : 516 begin 517 if ALCLObject is TCustomButton then 518 ConnectSenderSignal(gObject, 'enter', @gtkenterCB) 519 else 520 ConnectSenderSignal(gObject, 'focus-in-event', @gtkFocusInNotifyCB); //TODO: check this focus in is mapped to focus 521 end; 522 523 LM_EXIT : 524 begin 525 if ALCLObject is TCustomButton then 526 ConnectSenderSignal(gObject, 'leave', @gtkleaveCB) 527 else 528 ConnectSenderSignal(gObject, 'focus-out-event', @gtkFocusOutNotifyCB); 529 end; 530 531 LM_LEAVE : 532 begin 533 ConnectSenderSignal(gObject, 'leave', @gtkleaveCB); 534 end; 535 536 LM_WINDOWPOSCHANGED: //LM_SIZEALLOCATE, LM_RESIZE : 537 begin 538 ConnectSenderSignal(gObject, 'size-allocate', @gtksize_allocateCB); 539 if gObject<>gFixed then 540 begin 541 ConnectSenderSignal(gFixed, 'size-allocate', @gtksize_allocate_client); 542 end; 543 end; 544 545 LM_CHECKRESIZE : 546 begin 547 ConnectSenderSignal(gObject, 'check-resize', @gtkresizeCB); 548 end; 549 550 LM_SETEDITABLE : 551 begin 552 ConnectSenderSignal(gObject, 'set-editable', @gtkseteditable); 553 end; 554 555 LM_MOVEWORD : 556 begin 557 ConnectSenderSignal(gObject, 'move-word', @gtkmoveword); 558 end; 559 560 LM_MOVEPAGE : 561 begin 562 ConnectSenderSignal(gObject, 'move-page', @gtkmovepage); 563 end; 564 565 LM_MOVETOROW : 566 begin 567 ConnectSenderSignal(gObject, 'move-to-row', @gtkmovetorow); 568 end; 569 570 LM_MOVETOCOLUMN : 571 begin 572 ConnectSenderSignal(gObject, 'move-to-column', @gtkmovetocolumn); 573 end; 574 575 LM_MOUSEENTER: 576 begin 577 if gCore<>nil then 578 ConnectSenderSignal(gCore, 'enter', @gtkEnterCB) 579 end; 580 581 LM_MOUSELEAVE: 582 begin 583 if gCore<>nil then 584 ConnectSenderSignal(gCore, 'leave', @gtkLeaveCB) 585 end; 586 587 LM_KILLCHAR : 588 begin 589 ConnectSenderSignal(gObject, 'kill-char', @gtkkillchar); 590 end; 591 592 LM_KILLWORD : 593 begin 594 ConnectSenderSignal(gObject, 'kill-word', @gtkkillword); 595 end; 596 597 LM_KILLLINE : 598 begin 599 ConnectSenderSignal(gObject, 'kill-line', @gtkkillline); 600 end; 601 602 LM_CUT: 603 begin 604 if (ALCLObject is TCustomMemo) then 605 ConnectSenderSignal(gCore, 'cut-clipboard', @gtkcuttoclip) 606 else 607 ConnectSenderSignal(gObject, 'cut-clipboard', @gtkcuttoclip); 608 end; 609 610 LM_COPY: 611 begin 612 if (ALCLObject is TCustomMemo) then 613 ConnectSenderSignal(gCore, 'copy-clipboard', @gtkcopytoclip) 614 else 615 ConnectSenderSignal(gObject, 'copy-clipboard', @gtkcopytoclip); 616 end; 617 618 LM_PASTE: 619 begin 620 if (ALCLObject is TCustomMemo) then 621 ConnectSenderSignal(gCore, 'paste-clipboard', @gtkpastefromclip) 622 else 623 ConnectSenderSignal(gObject, 'paste-clipboard', @gtkpastefromclip); 624 end; 625 626 LM_HSCROLL: 627 begin 628 Adjustment := GetAdjustment(gObject, False); 629 if Adjustment <> nil then 630 ConnectSenderSignal(Adjustment, 'value-changed', @GTKHScrollCB); 631 end; 632 633 LM_VSCROLL: 634 begin 635 Adjustment := GetAdjustment(gObject, True); 636 if Adjustment <> nil then 637 ConnectSenderSignal(Adjustment, 'value-changed', @GTKVScrollCB); 638 end; 639 640 LM_YEARCHANGED : //calendar 641 Begin 642 ConnectSenderSignal(gCore, 'prev-year', @gtkyearchanged); 643 ConnectSenderSignal(gCore, 'next-year', @gtkyearchanged); 644 end; 645 646 // Listview & Header control 647 LM_COMMAND: 648 begin 649 if ALCLObject is TCustomComboBox then begin 650 ConnectSenderSignalAfter(PgtkObject(PgtkCombo(gObject)^.popwin), 651 'show', @gtkComboBoxShowAfter); 652 ConnectSenderSignalAfter(PgtkObject(PgtkCombo(gObject)^.popwin), 653 'hide', @gtkComboBoxHideAfter); 654 end; 655 end; 656 657 LM_SelChange: 658 begin 659 if ALCLObject is TCustomListBox then 660 ConnectSenderSignalAfter(PgtkObject(gCore), 661 'selection_changed', @gtkListBoxSelectionChangedAfter); 662 end; 663 664 LM_DROPFILES: 665 ConnectSenderSignal(gCore, 'drag_data_received', @GtkDragDataReceived); 666 667(* 668 LM_WINDOWPOSCHANGED: 669 begin 670 ConnectSenderSignal(gObject, 'size-allocate', @gtkSizeAllocateCB); 671// ConnectSenderSignal(gObject, 'move_resize', @gtkmoveresize); 672 end; 673*) 674 else 675 //DebugLn(Format('Trace:ERROR: Signal %d not found!', [AMsg])); 676 end; 677end; 678 679{------------------------------------------------------------------------------ 680 Function: TGtk2WidgetSet.SetCallbackEx 681 Params: Msg - message for which to set a callback 682 sender - object to which callback will be send 683 Returns: nothing 684 685 Applies a Message to the sender 686 ------------------------------------------------------------------------------} 687procedure TGtk2WidgetSet.SetCallbackEx(const AMsg: LongInt; 688 const AGTKObject: PGTKObject; const ALCLObject: TObject; Direct: Boolean); 689 690 procedure ConnectSenderSignal(const AnObject:PGTKObject; const ASignal: PChar; 691 const ACallBackProc: Pointer); 692 begin 693 ConnectSignal(AnObject, ASignal, ACallBackProc, ALCLObject); 694 end; 695 696 procedure ConnectSenderSignalAfter(const AnObject:PGTKObject; 697 const ASignal: PChar; const ACallBackProc: Pointer); 698 begin 699 ConnectSignalAfter(AnObject, ASignal, ACallBackProc, ALCLObject); 700 end; 701 702 procedure ConnectSenderSignal(const AnObject:PGTKObject; const ASignal: PChar; 703 const ACallBackProc: Pointer; const ReqSignalMask: TGdkEventMask); 704 begin 705 ConnectSignal(AnObject, ASignal, ACallBackProc, ALCLObject, 706 ReqSignalMask); 707 end; 708 709 procedure ConnectSenderSignalAfter(const AnObject:PGTKObject; 710 const ASignal: PChar; const ACallBackProc: Pointer; 711 const ReqSignalMask: TGdkEventMask); 712 begin 713 ConnectSignalAfter(AnObject, ASignal, ACallBackProc, ALCLObject, 714 ReqSignalMask); 715 end; 716 717 procedure ConnectFocusEvents(const AnObject: PGTKObject); 718 begin 719 //DebugLn(['ConnectFocusEvents ',GetWidgetDebugReport(PGtkWidget(AnObject))]); 720 ConnectSenderSignal(AnObject, 'focus-in-event', @gtk2FocusCB); 721 ConnectSenderSignal(AnObject, 'focus-out-event', @gtk2KillFocusCB); 722 ConnectSenderSignalAfter(AnObject, 'focus-out-event', @gtk2KillFocusCBAfter); 723 end; 724 725 procedure ConnectKeyPressReleaseEvents(const AnObject: PGTKObject); 726 begin 727 //debugln('gtk2object ConnectKeyPressReleaseEvents A ALCLObject=',DbgSName(ALCLObject)); 728 ConnectSenderSignal(AnObject, 729 'key-press-event', @GTKKeyPress, GDK_KEY_PRESS_MASK); 730 ConnectSenderSignalAfter(AnObject, 731 'key-press-event', @GTKKeyPressAfter, GDK_KEY_PRESS_MASK); 732 ConnectSenderSignal(AnObject, 733 'key-release-event', @GTKKeyRelease, GDK_KEY_RELEASE_MASK); 734 ConnectSenderSignalAfter(AnObject, 735 'key-release-event', @GTKKeyReleaseAfter, GDK_KEY_RELEASE_MASK); 736 end; 737 738var 739 gObject, gFixed, gCore: PGTKObject; 740begin 741 //debugln('gtk2object.inc TGtk2WidgetSet.SetCallback A ALCLObject=',DbgSName(ALCLObject),' AMsg=',dbgs(AMsg)); 742 if Direct then 743 begin 744 gObject := AGTKObject; 745 gFixed := AGTKObject; 746 gCore := AGTKObject; 747 end 748 else 749 begin 750 // gObject 751 if AGTKObject = nil then gObject := ObjectToGTKObject(ALCLObject) 752 else gObject := AGTKObject; 753 754 if gObject = nil then Exit; 755 756 // gFixed is the widget with the client area (e.g. TGroupBox, TForm have this) 757 gFixed := PGTKObject(GetFixedWidget(gObject)); 758 if gFixed = nil then gFixed := gObject; 759 760 // gCore is the main widget (e.g. TListView has this) 761 gCore:= PGtkObject(GetWidgetInfo(gObject, True)^.CoreWidget); 762 end; 763 764 case AMsg of 765 LM_FOCUS : 766 begin 767 ConnectFocusEvents(gCore); 768 end; 769 770 LM_GRABFOCUS: 771 begin 772 ConnectSenderSignal(gObject, 'grab_focus', @gtkActivateCB); 773 end; 774 775 LM_CHAR, 776 LM_KEYDOWN, 777 LM_KEYUP, 778 LM_SYSCHAR, 779 LM_SYSKEYDOWN, 780 LM_SYSKEYUP: 781 begin 782 if ((ALCLObject is TCustomComboBox) and gtk_is_combo_box_entry(gObject)) 783 or (ALCLObject is TCustomForm) then 784 ConnectKeyPressReleaseEvents(gObject); 785 786 ConnectKeyPressReleaseEvents(gCore); 787 end; 788 789 LM_SHOWWINDOW : 790 begin 791 ConnectSenderSignal(gObject, 'show', @gtk2showCB); 792 ConnectSenderSignal(gObject, 'hide', @gtk2hideCB); 793 end; 794 795 LM_CONTEXTMENU: 796 ConnectSenderSignal(gObject, 'popup-menu', @gtk2PopupMenuCB); // TCustomControl needs gObject, not gCore nor gFixed 797 798 else 799 _SetCallbackEx(AMsg, AGTKObject, ALCLObject, Direct); 800 end; 801end; 802 803procedure TGtk2WidgetSet.SetCommonCallbacks(const AGTKObject: PGTKObject; 804 const ALCLObject: TObject); 805var 806 Widget: PGtkWidget; 807begin 808 if GTK_IS_SCROLLED_WINDOW(AGtkObject) then 809 begin 810 Widget := PGtkWidget(AGTKObject); 811 g_signal_connect_after(GTK_SCROLLED_WINDOW(Widget)^.vscrollbar, 'button-press-event', 812 TGCallback(@gtk2ScrollBarMouseBtnPress), ALCLObject); 813 g_signal_connect_after(GTK_SCROLLED_WINDOW(Widget)^.vscrollbar, 'button-release-event', 814 TGCallback(@gtk2ScrollBarMouseBtnRelease), ALCLObject); 815 816 g_signal_connect_after(GTK_SCROLLED_WINDOW(Widget)^.hscrollbar, 'button-press-event', 817 TGCallback(@gtk2ScrollBarMouseBtnPress), ALCLObject); 818 g_signal_connect_after(GTK_SCROLLED_WINDOW(Widget)^.hscrollbar, 'button-release-event', 819 TGCallback(@gtk2ScrollBarMouseBtnRelease), ALCLObject); 820 end; 821 822 SetCallback(LM_SHOWWINDOW, AGTKObject, ALCLObject); 823 SetCallback(LM_DESTROY, AGTKObject, ALCLObject); 824 SetCallback(LM_FOCUS, AGTKObject, ALCLObject); 825 SetCallback(LM_WINDOWPOSCHANGED, AGTKObject, ALCLObject); 826 SetCallback(LM_PAINT, AGTKObject, ALCLObject); 827 SetCallback(LM_KEYDOWN, AGTKObject, ALCLObject); 828 SetCallback(LM_KEYUP, AGTKObject, ALCLObject); 829 SetCallback(LM_CHAR, AGTKObject, ALCLObject); 830 SetCallback(LM_MOUSEMOVE, AGTKObject, ALCLObject); 831 SetCallback(LM_LBUTTONDOWN, AGTKObject, ALCLObject); 832 SetCallback(LM_LBUTTONUP, AGTKObject, ALCLObject); 833 SetCallback(LM_RBUTTONDOWN, AGTKObject, ALCLObject); 834 SetCallback(LM_RBUTTONUP, AGTKObject, ALCLObject); 835 SetCallback(LM_MBUTTONDOWN, AGTKObject, ALCLObject); 836 SetCallback(LM_MBUTTONUP, AGTKObject, ALCLObject); 837 SetCallback(LM_MOUSEWHEEL, AGTKObject, ALCLObject); 838 SetCallback(LM_MOUSEHWHEEL, AGTKObject, ALCLObject); 839 SetCallback(LM_DROPFILES, AGTKObject, ALCLObject); 840 SetCallback(LM_CONTEXTMENU, AGtkObject, ALCLObject); 841 842 // set gtk2 only callbacks 843 ConnectSignal(AGTKObject, 'show-help', @gtk2ShowHelpCB, ALCLObject); 844 ConnectSignal(AGTKObject,'grab-notify',@gtk2GrabNotify, ALCLObject); 845end; 846 847procedure TGtk2WidgetSet.SetLabelCaption(const ALabel: PGtkLabel; 848 const ACaption: String); 849var 850 s: String; 851 i: Integer; 852begin 853 s := ''; 854 i := 1; 855 while i <= Length(ACaption) do 856 begin 857 case ACaption[i] of 858 '_': s := s + '__'; 859 '&': 860 if (i < Length(ACaption)) and (ACaption[i + 1] = '&') then 861 begin 862 s := s + '&'; 863 inc(i); 864 end 865 else 866 s := s + '_'; 867 else 868 s := s + ACaption[i]; 869 end; 870 inc(i); 871 end; 872 gtk_label_set_text_with_mnemonic(ALabel, PChar(s)); 873end; 874 875{------------------------------------------------------------------------------ 876 procedure TGtk2WidgetSet.SetSelectionMode(Sender: TObject; Widget: PGtkWidget; 877 MultiSelect, ExtendedSelect: boolean); 878------------------------------------------------------------------------------} 879procedure TGtk2WidgetSet.SetSelectionMode(Sender: TObject; Widget: PGtkWidget; 880 MultiSelect, ExtendedSelect: Boolean); 881var 882 AControl: TWinControl; 883 SelectionMode: TGtkSelectionMode; 884 Selection : PGtkTreeSelection; 885begin 886 AControl:=TWinControl(Sender); 887 if (AControl is TWinControl) and 888 (AControl.fCompStyle in [csListBox, csCheckListBox]) then 889 begin 890 if MultiSelect then 891 SelectionMode:= GTK_SELECTION_MULTIPLE 892 else 893 SelectionMode:= GTK_SELECTION_SINGLE; 894 895 Selection := gtk_tree_view_get_selection(GTK_TREE_VIEW( 896 GetWidgetInfo(Widget, True)^.CoreWidget)); 897 gtk_tree_selection_set_mode(Selection, SelectionMode); 898 end; 899end; 900 901procedure TGtk2WidgetSet.SetWidgetFont(const AWidget: PGtkWidget; 902 const AFont: TFont); 903var 904 FontDesc: PPangoFontDescription; 905 UseFont: PPangoLayout; 906begin 907 if GtkWidgetIsA(AWidget,GTKAPIWidget_GetType) then begin 908 // the GTKAPIWidget is self drawn, so no use to change the widget style. 909 exit; 910 end; 911 912 UseFont := {%H-}PGdiObject(AFont.Reference.Handle)^.GDIFontObject; 913 FontDesc := pango_layout_get_font_description(UseFont); 914 gtk_widget_modify_font(AWidget, FontDesc); 915end; 916 917function TGtk2WidgetSet.CreateThemeServices: TThemeServices; 918begin 919 Result := TGtk2ThemeServices.Create; 920end; 921 922constructor TGtk2WidgetSet.Create; 923{$IFDEF HASX} 924const 925 WMNoTransient: array[0..1] of String = ( 926 'kwin', 927 'awesome' 928 ); 929 930 function IsNoTransientWM: Boolean; 931 var 932 wmname: String; 933 i: Integer; 934 begin 935 wmname := GetWindowManager; 936 //DebugLn('Window Manager identifier: ', wmname); 937 Result := False; 938 for i := Low(WMNoTransient) to High(WMNoTransient) do 939 if wmname = WMNoTransient[i] then 940 Exit(True); 941 end; 942 943{$ENDIF} 944begin 945 inherited Create; 946 FCachedTitleBarHeight := -1; 947 FCachedBorderSize := 4; 948 Gtk2Create; 949 {$IFNDEF USE_GTK_MAIN_OLD_ITERATION} 950 FMainPoll := nil; 951 if not FIsLibraryInstance then 952 begin 953 Gtk2MPF := g_main_context_get_poll_func(g_main_context_default); 954 g_main_context_set_poll_func(g_main_context_default, @Gtk2PollFunction); 955 end else 956 Gtk2MPF := nil; 957 {$ENDIF} 958 StayOnTopList := nil; 959 im_context:=gtk_im_multicontext_new; 960 g_signal_connect (G_OBJECT (im_context), 'commit', 961 G_CALLBACK (@gtk_commit_cb), nil); 962 {$IFDEF HASX} 963 if IsNoTransientWM then 964 begin 965 //some window managers do their own transient settings 966 UseTransientForModalWindows := False; 967 FDesktopWidget := gtk_window_new(GTK_WINDOW_TOPLEVEL); 968 gtk_widget_set_parent_window(FDesktopWidget, gdk_get_default_root_window); 969 gtk_widget_set_uposition(FDesktopWidget, 0, 0); 970 gtk_widget_set_usize(FDesktopWidget, 1, 1); 971 //we must show it, so X11 maps this widget 972 gtk_widget_show(FDesktopWidget); 973 //hide it imediatelly, so it is really invisible widget 974 gtk_widget_hide(FDesktopWidget); 975 end else 976 FDesktopWidget := nil; 977 {$ENDIF} 978end; 979 980destructor TGtk2WidgetSet.Destroy; 981begin 982 g_object_unref(im_context); 983 im_context:=nil; 984 im_context_widget:=nil; 985 FreeAndNil(StayOnTopList); 986 Gtk2Destroy; 987 {$IFDEF HASX} 988 if FDesktopWidget <> nil then 989 begin 990 gtk_widget_destroy(FDesktopWidget); 991 FDesktopWidget := nil; 992 end; 993 {$ENDIF} 994 995 inherited Destroy; 996end; 997 998function TGtk2WidgetSet.LCLPlatform: TLCLPlatform; 999begin 1000 Result:= lpGtk2; 1001end; 1002 1003function TGtk2WidgetSet.GetLCLCapability(ACapability: TLCLCapability): PtrUInt; 1004begin 1005 case ACapability of 1006 // Transparency partly works but code completion window would go behind SynEdit -> NO 1007 lcTransparentWindow: Result := LCL_CAPABILITY_NO; 1008 else 1009 Result := inherited GetLCLCapability(ACapability); 1010 end; 1011end; 1012 1013function gdk_screen_get_resolution(screen:PGdkScreen):gdouble; cdecl; external gdklib; 1014 1015{------------------------------------------------------------------------------ 1016 Method: TGtk2WidgetSet.AppInit 1017 Params: None 1018 Returns: Nothing 1019 1020 *Note: Initialize GTK engine 1021 (is called by TApplication.Initialize which is typically after all 1022 finalization sections) 1023 ------------------------------------------------------------------------------} 1024procedure TGtk2WidgetSet.AppInit(var ScreenInfo: TScreenInfo); 1025begin 1026 {$if defined(cpui386) or defined(cpux86_64)} 1027 // needed otherwise some gtk theme engines crash with division by zero 1028 {$IFNDEF DisableGtkDivZeroFix} 1029 SetExceptionMask(GetExceptionMask + [exOverflow,exZeroDivide,exInvalidOp]); 1030 {$ENDIF} 1031 {$ifend} 1032 1033 InitKeyboardTables; 1034 { Compute pixels per inch variable } 1035 ScreenInfo.PixelsPerInchX := 1036 RoundToInt(gdk_screen_get_resolution(gdk_screen_get_default)); 1037 ScreenInfo.PixelsPerInchY := 1038 ScreenInfo.PixelsPerInchX; 1039 if ScreenInfo.PixelsPerInchX <= 0 then 1040 begin 1041 ScreenInfo.PixelsPerInchX := 1042 RoundToInt(gdk_screen_width / (GetScreenWidthMM / 25.4)); 1043 ScreenInfo.PixelsPerInchY := 1044 RoundToInt(gdk_screen_height / (GetScreenHeightMM / 25.4)); 1045 end; 1046 ScreenInfo.ColorDepth := gdk_visual_get_system^.depth; 1047end; 1048 1049procedure TGtk2WidgetSet.AppBringToFront; 1050begin 1051 if Assigned(Application.MainForm) and Application.MainForm.HandleAllocated then 1052 begin 1053 gdk_window_raise({%H-}PGtkWidget(Application.MainForm.Handle)^.window); 1054 gdk_window_focus({%H-}PGtkWidget(Application.MainForm.Handle)^.window, 1055 gtk_get_current_event_time); 1056 end; 1057end; 1058 1059procedure TGtk2WidgetSet.AppMinimize; 1060var 1061 i: Integer; 1062 AForm: TCustomForm; 1063 WInfo: PWidgetInfo; 1064begin 1065 if Screen=nil then exit; 1066 {$IFDEF HASX} 1067 HideAllHints; 1068 {$ENDIF} 1069 for i:= 0 to Screen.CustomFormZOrderCount-1 do 1070 begin 1071 AForm := Screen.CustomFormsZOrdered[i]; 1072 if (AForm.Parent=nil) and AForm.HandleAllocated and 1073 GTK_WIDGET_VISIBLE({%H-}PGtkWidget(AForm.Handle)) and 1074 not (AForm.FormStyle in [fsMDIChild, fsSplash]) and 1075 not (AForm.BorderStyle in [bsNone]) then 1076 begin 1077 WInfo := GetWidgetInfo({%H-}PGtkWidget(AForm.Handle)); 1078 // prevent recursion in gtk2wsforms GDK_WINDOW_STATE event 1079 if WInfo^.FormWindowState.new_window_state <> GDK_WINDOW_STATE_ICONIFIED then 1080 gtk_window_iconify({%H-}PGtkWindow(AForm.Handle)); 1081 end; 1082 end; 1083end; 1084 1085procedure TGtk2WidgetSet.AppRestore; 1086var 1087 i: Integer; 1088 AForm: TCustomForm; 1089begin 1090 if Screen=nil then exit; 1091 for i:= Screen.CustomFormZOrderCount-1 downto 0 do 1092 begin 1093 AForm:=Screen.CustomFormsZOrdered[i]; 1094 if (AForm.Parent=nil) and AForm.HandleAllocated and 1095 GTK_WIDGET_VISIBLE({%H-}PGtkWidget(AForm.Handle)) and 1096 not (AForm.FormStyle in [fsMDIChild, fsSplash]) and 1097 not (AForm.BorderStyle in [bsNone]) then 1098 gtk_window_deiconify({%H-}PGtkWindow(AForm.Handle)); 1099 end; 1100 {$IFDEF HASX} 1101 RestoreAllHints; 1102 {$ENDIF} 1103end; 1104 1105function TGtk2WidgetSet.GetAppHandle: THandle; 1106begin 1107 {$ifdef windows} 1108 Result := GetWin32AppHandle; 1109 {$else} 1110 Result := inherited GetAppHandle; 1111 {$endif} 1112end; 1113 1114type 1115 TGtk2TempFormStyleSet = Set of TFormStyle; 1116const 1117 TGtk2TopForms: Array[Boolean] of TGtk2TempFormStyleSet = (fsAllNonSystemStayOnTop, 1118 fsAllStayOnTop); 1119 1120 1121procedure gdk_window_restack(w, s: PGdkWindow; above: gboolean); cdecl; external gdklib; 1122function gdk_screen_get_active_window(screen: PGdkScreen):PGdkWindow; cdecl; external gdklib; 1123 1124function TGtk2WidgetSet.AppRemoveStayOnTopFlags(const ASystemTopAlso: Boolean 1125 ): Boolean; 1126var 1127 i: Integer; 1128 AForm: TCustomForm; 1129 W: PGtkWidget; 1130 Flags: TGdkWindowState; 1131 B: Boolean; 1132 act: PGdkWindow; 1133 nact: PGdkWindow; 1134begin 1135 Result := True; 1136 if StayOnTopList = nil then 1137 StayOnTopList := TMap.Create(TMapIdType(ituPtrSize), SizeOf(TGtkWidget)); 1138 1139 // todo: all screens should be evaluated 1140 // depending on the screen of a window 1141 act:=gdk_screen_get_active_window(gdk_screen_get_default); 1142 // act is typically returned for X11. other systems might 1143 // not implement it. 1144 nact:=act; 1145 1146 for i := 0 to Screen.CustomFormZOrderCount - 1 do 1147 begin 1148 AForm := Screen.CustomFormsZOrdered[i]; 1149 if AForm.HandleAllocated then 1150 begin 1151 W := {%H-}PGtkWidget(AForm.Handle); 1152 // do not raise assertion in case of invalid PGdkWindow 1153 B := GDK_IS_WINDOW(W^.Window); 1154 if B then 1155 Flags := gdk_window_get_state(W^.Window); 1156 if B and (AForm.Parent = nil) and 1157 not (csDesigning in AForm.ComponentState) and 1158 (AForm.FormStyle in TGtk2TopForms[ASystemTopAlso]) and 1159 GTK_WIDGET_VISIBLE(W) and 1160 not gtk_window_get_modal(PGtkWindow(W)) and 1161 (Flags and GDK_WINDOW_STATE_ICONIFIED = 0) then 1162 begin 1163 gdk_window_set_keep_above(W^.Window, False); 1164 if Assigned(nact) then 1165 begin 1166 gdk_window_restack(W^.Window, act, False); 1167 nact:=W^.Window; 1168 end 1169 else begin 1170 gdk_window_lower(W^.Window); // send to the bottom 1171 gdk_window_raise(W^.Window); // restore back 1172 end; 1173 if not StayOnTopList.HasId(W) then 1174 StayOnTopList.Add(W, W); 1175 end; 1176 end; 1177 end; 1178 if Assigned(act) then g_object_unref(act); 1179end; 1180 1181function TGtk2WidgetSet.AppRestoreStayOnTopFlags(const ASystemTopAlso: Boolean 1182 ): Boolean; 1183var 1184 i: Integer; 1185 AForm: TCustomForm; 1186 W: PGtkWidget; 1187 Flags: TGdkWindowState; 1188 B: Boolean; 1189begin 1190 Result := True; 1191 if StayOnTopList = nil then 1192 exit; 1193 for i := Screen.CustomFormZOrderCount - 1 downto 0 do 1194 begin 1195 AForm := Screen.CustomFormsZOrdered[i]; 1196 if AForm.HandleAllocated then 1197 begin 1198 W := {%H-}PGtkWidget(AForm.Handle); 1199 // do not raise assertion in case of invalid PGdkWindow 1200 B := GDK_IS_WINDOW(W^.Window); 1201 if B then 1202 Flags := gdk_window_get_state(W^.Window); 1203 if B and (AForm.Parent = nil) and 1204 not (csDesigning in AForm.ComponentState) and 1205 (AForm.FormStyle in TGtk2TopForms[ASystemTopAlso]) and 1206 GTK_WIDGET_VISIBLE(W) and 1207 not gtk_window_get_modal(PGtkWindow(W)) and 1208 (Flags and GDK_WINDOW_STATE_ICONIFIED = 0) then 1209 begin 1210 if StayOnTopList.HasId(W) then 1211 gdk_window_set_keep_above(W^.Window, True); 1212 end; 1213 end; 1214 end; 1215 FreeAndNil(StayOnTopList); 1216end; 1217 1218 1219{off $define GtkFixedWithWindow} 1220{------------------------------------------------------------------------------ 1221 Procedure: GLogFunc 1222 1223 Replaces the default glib loghandler. All errors, warnings etc, are logged 1224 through this function. 1225 Here are Fatals, Criticals and Errors translated to Exceptions 1226 Comment Ex to skip exception, comment Level to skip logging 1227 ------------------------------------------------------------------------------} 1228procedure GLogFunc(ALogDomain: Pgchar; ALogLevel: TGLogLevelFlags; 1229 AMessage: Pgchar; AData: gpointer);cdecl; 1230var 1231 Flag, Level, Domain: String; 1232 Ex: ExceptClass; 1233begin 1234(* 1235 G_LOG_FLAG_RECURSION = 1 shl 0; 1236 G_LOG_FLAG_FATAL = 1 shl 1; 1237 G_LOG_LEVEL_ERROR = 1 shl 2; 1238 G_LOG_LEVEL_CRITICAL = 1 shl 3; 1239 G_LOG_LEVEL_WARNING = 1 shl 4; 1240 G_LOG_LEVEL_MESSAGE = 1 shl 5; 1241 G_LOG_LEVEL_INFO = 1 shl 6; 1242 G_LOG_LEVEL_DEBUG = 1 shl 7; 1243 G_LOG_LEVEL_MASK = (1 shl 8) - 2; 1244*) 1245 if (AData=nil) then ; 1246 1247 Ex := nil; 1248 Level := ''; 1249 Flag := ''; 1250 1251 if ALogDomain = nil 1252 then Domain := '' 1253 else Domain := ALogDomain + ': '; 1254 1255 if ALogLevel and G_LOG_FLAG_RECURSION <> 0 1256 then Flag := '[RECURSION] '; 1257 1258 if ALogLevel and G_LOG_FLAG_FATAL <> 0 1259 then Flag := Flag + '[FATAL] '; 1260 1261 if ALogLevel and G_LOG_LEVEL_ERROR <> 0 1262 then begin 1263 Level := 'ERROR'; 1264 Ex := EInterfaceError; 1265 end 1266 else 1267 if ALogLevel and G_LOG_LEVEL_CRITICAL <> 0 1268 then begin 1269 Level := 'CRITICAL'; 1270 Ex := EInterfaceCritical; 1271 end 1272{ Commented out for issue #31138. The whole system freezed because of GTK2 exception: 1273"Invalid borders specified for theme pixmap: .../line-h.png. Borders don't fit within the image." 1274ToDo: Fix the issue properly. 1275 else 1276 if ALogLevel and G_LOG_LEVEL_WARNING <> 0 1277 then begin 1278 Level := 'WARNING'; 1279 Ex := EInterfaceWarning; 1280 end 1281} 1282 else 1283 if ALogLevel and G_LOG_LEVEL_INFO <> 0 1284 then begin 1285 Level := 'INFO'; 1286 end 1287 else 1288 if ALogLevel and G_LOG_LEVEL_DEBUG <> 0 1289 then begin 1290 Level := 'DEBUG'; 1291 end 1292 else begin 1293 Level := 'USER'; 1294 end; 1295 1296 if Ex = nil 1297 then begin 1298 if Level <> '' 1299 then DebugLn('[', Level, '] ', Flag, Domain, AMessage); 1300 end 1301 else begin 1302 if ALogLevel and G_LOG_FLAG_FATAL <> 0 1303 then begin 1304 // always create exception 1305 // 1306 // see callstack for more info 1307 raise Ex.Create(Flag + Domain + AMessage); 1308 end 1309 else begin 1310 // create a debugger trappable exception 1311 // but for now let the app continue and log a line 1312 // in future when all warnings etc. are gone they might raise 1313 // a real exception 1314 // 1315 // see callstack for more info 1316 try 1317 raise Ex.Create(Flag + Domain + AMessage); 1318 except 1319 on Exception do begin 1320 // just write a line 1321 DebugLn('[', Level, '] ', Flag, Domain, AMessage); 1322 end; 1323 end; 1324 end; 1325 end; 1326 1327end; 1328 1329{$ifdef Unix} 1330 1331// TThread.Synchronize support 1332var 1333 threadsync_pipein, threadsync_pipeout: cint; 1334 threadsync_giochannel: pgiochannel; 1335 childsig_pending: boolean; 1336 1337procedure ChildEventHandler({%H-}sig: longint; {%H-}siginfo: psiginfo; 1338 {%H-}sigcontext: psigcontext); cdecl; 1339begin 1340 childsig_pending := true; 1341 WakeMainThread(nil); 1342end; 1343 1344procedure InstallSignalHandler; 1345var 1346 child_action: sigactionrec; 1347begin 1348 child_action.sa_handler := @ChildEventHandler; 1349 fpsigemptyset(child_action.sa_mask); 1350 child_action.sa_flags := 0; 1351 fpsigaction(SIGCHLD, @child_action, nil); 1352end; 1353 1354{$endif} 1355 1356{------------------------------------------------------------------------------ 1357 Method: TGtk2WidgetSet.Create 1358 Params: None 1359 Returns: Nothing 1360 1361 Constructor for the class. 1362 ------------------------------------------------------------------------------} 1363procedure TGtk2WidgetSet.Gtk2Create; 1364{$IFDEF EnabledGtkThreading} 1365{$IFNDEF Win32} 1366var 1367 TM: TThreadManager; 1368 GtkThread: PGThread; 1369{$ENDIF} 1370{$ENDIF} 1371begin 1372 //if ClassType = TGtkWidgetSet 1373 //then raise EInvalidOperation.Create('Cannot create the base gtkwidgetset, use gtk1 or gtk2 instead'); 1374 1375 FAppActive := False; 1376 FLastFocusIn := nil; 1377 FLastFocusOut := nil; 1378 1379 LastWFPMousePos := Point(MaxInt, MaxInt); 1380 1381 FIsLibraryInstance := False; 1382 FGtkTerminated := False; 1383 1384 {$IFDEF EnabledGtkThreading} 1385 {$IFNDEF Win32} 1386 GtkThread := g_thread_self(); 1387 if GtkThread <> nil then 1388 begin 1389 if GtkThread^.data = nil then 1390 GtkThread^.data := @Self 1391 else 1392 FIsLibraryInstance := True; 1393 end; 1394 if GetThreadManager(TM{%H-}) and Assigned(TM.InitManager) and g_thread_supported then 1395 begin 1396 g_thread_init(nil); 1397 {$IFDEF USE_GTK_MAIN_OLD_ITERATION} 1398 gdk_threads_init; 1399 gdk_threads_enter; 1400 {$ENDIF} 1401 fMultiThreadingEnabled := True; 1402 end; 1403 {$ELSE} 1404 g_thread_init(nil); 1405 {$ENDIF} 1406 {$ENDIF} 1407 1408 // DCs, GDIObjects 1409 FDeviceContexts := TDynHashArray.Create(-1); 1410 FDeviceContexts.Options:=FDeviceContexts.Options+[dhaoCacheContains]; 1411 FGDIObjects := TDynHashArray.Create(-1); 1412 FGDIObjects.Options:=FGDIObjects.Options+[dhaoCacheContains]; 1413 Gtk2Def.ReleaseGDIObject:=@ReleaseGDIObject; 1414 Gtk2Def.ReferenceGDIObject:=@ReferenceGDIObject; 1415 1416 FDefaultFontDesc:= nil; 1417 // messages 1418 FMessageQueue := TGtkMessageQueue.Create; 1419 WaitingForMessages := false; 1420 FWidgetsWithResizeRequest := TDynHashArray.Create(-1); 1421 FWidgetsWithResizeRequest.Options:= 1422 FWidgetsWithResizeRequest.Options+[dhaoCacheContains]; 1423 FWidgetsResized := TDynHashArray.Create(-1); 1424 FWidgetsResized.Options:=FWidgetsResized.Options+[dhaoCacheContains]; 1425 FFixWidgetsResized := TDynHashArray.Create(-1); 1426 1427 FTimerData := TFPList.Create; 1428 {$IFDEF Use_KeyStateList} 1429 FKeyStateList_ := TFPList.Create; 1430 {$ENDIF} 1431 1432 DestroyConnectedWidgetCB:=@DestroyConnectedWidget; 1433 1434 FRCFilename := ChangeFileExt(ParamStrUTF8(0),'.gtkrc'); 1435 FRCFileParsed := false; 1436 1437 // initialize app level gtk engine 1438 gtk_set_locale (); 1439 1440 // call init and pass cmd line args 1441 PassCmdLineOptions; 1442 1443 // set glib log handler 1444 FLogHandlerID := g_log_set_handler(nil, -1, @GLogFunc, Self); 1445 1446 // read gtk rc file 1447 ParseRCFile; 1448 1449 // Initialize Stringlist for holding styles 1450 Styles := TStringlist.Create; 1451 1452 {$IFDEF Use_KeyStateList} 1453 gtk_key_snooper_install(@GTKKeySnooper, FKeyStateList_); 1454 {$ELSE} 1455 gtk_key_snooper_install(@GTKKeySnooper, nil); 1456 {$ENDIF} 1457 1458 // Init tooltips 1459 FGTKToolTips := gtk_tooltips_new; 1460 //gtk_object_ref(PGTKObject(FGTKToolTips)); 1461 gtk_toolTips_Enable(FGTKToolTips); 1462 1463 // Init stock objects; 1464 InitStockItems; 1465 InitSystemColors; 1466 InitSystemBrushes; 1467 1468 // clipboard 1469 ClipboardTypeAtoms[ctPrimarySelection]:=GDK_SELECTION_PRIMARY; 1470 ClipboardTypeAtoms[ctSecondarySelection]:=GDK_SELECTION_SECONDARY; 1471 ClipboardTypeAtoms[ctClipboard]:=gdk_atom_intern('CLIPBOARD',GdkFalse); 1472 1473{$ifdef Unix} 1474 InitSynchronizeSupport; 1475{$ifdef UseAsyncProcess} 1476 DebugLn(['TGtk2WidgetSet.Create Installing signal handler for TAsyncProcess']); 1477 InstallSignalHandler; 1478{$endif} 1479{$endif} 1480 1481 GTK2WidgetSet := Self; 1482end; 1483 1484{------------------------------------------------------------------------------ 1485 Method: TGtk2WidgetSet.PassCmdLineOptions 1486 Params: None 1487 Returns: Nothing 1488 1489 Passes command line options to the gtk engine 1490 ------------------------------------------------------------------------------} 1491procedure TGtk2WidgetSet.PassCmdLineOptions; 1492 1493 function SearchOption(const Option: string; Remove: boolean): boolean; 1494 var 1495 i: Integer; 1496 ArgCount: LongInt; 1497 begin 1498 Result:=false; 1499 if Option='' then exit; 1500 i:=0; 1501 ArgCount:=argc; 1502 while i<ArgCount do begin 1503 if AnsiStrComp(PChar(Option),argv[i])=0 then begin 1504 // option exists 1505 Result:=true; 1506 if Remove then begin 1507 // remove option from parameters, so that no other parameter parsed 1508 // can see it. 1509 dec(ArgCount); 1510 while i<ArgCount do begin 1511 argv[i]:=argv[i+1]; 1512 inc(i); 1513 end; 1514 argv[i]:=nil; 1515 end; 1516 exit; 1517 end; 1518 inc(i); 1519 end; 1520 end; 1521 1522begin 1523 gtk_init(@argc,@argv); 1524 UseTransientForModalWindows := not SearchOption('--lcl-no-transient',true); 1525end; 1526 1527{------------------------------------------------------------------------------ 1528 procedure TGtk2WidgetSet.FreeAllStyles; 1529 ------------------------------------------------------------------------------} 1530procedure TGtk2WidgetSet.FreeAllStyles; 1531begin 1532 If Assigned(Styles) then begin 1533 ReleaseAllStyles; 1534 FreeAndNil(Styles); 1535 end; 1536end; 1537 1538{$ifdef TraceGdiCalls} 1539procedure DumpBackTrace(BackTrace: TCallBacksArray); 1540var 1541 i: Integer; 1542begin 1543 for i:=0 to MaxCallBacks do 1544 Debugln(GetLineInfo(BackTrace[i], false)); 1545end; 1546 1547procedure FillStackAddrs(bp: pointer; BackTraces: PCallBacksArray); 1548var 1549 prevbp: pointer; 1550 caller_frame, 1551 caller_addr : Pointer; 1552 i: Integer; 1553begin 1554 Prevbp := bp-1; 1555 i:=0; 1556 while (bp>prevbp)do begin 1557 caller_addr := get_caller_addr(bp); 1558 caller_frame := get_caller_frame(bp); 1559 BackTraces^[i] := Caller_Addr; 1560 inc(i); 1561 if (caller_addr=nil) or 1562 (caller_frame=nil) or 1563 (i>MaxCallBacks) then 1564 break; 1565 prevbp:=bp; 1566 bp:=caller_frame; 1567 end; 1568end; 1569{$endif} 1570{------------------------------------------------------------------------------ 1571 Method: TGtk2WidgetSet._Destroy 1572 Params: None 1573 Returns: Nothing 1574 1575 Gtk2 original Destructor for the class. 1576 ------------------------------------------------------------------------------} 1577procedure TGtk2WidgetSet.Gtk2Destroy; 1578const 1579 ProcName = '[TGtk2WidgetSet.Destroy]'; 1580var 1581 n: Integer; 1582 pTimerInfo : PGtkITimerinfo; 1583 GDITypeCount: array[TGDIType] of Integer; 1584 GDIType: TGDIType; 1585 HashItem: PDynHashArrayItem; 1586 QueueItem : TGtkMessageQueueItem; 1587 NextQueueItem : TGtkMessageQueueItem; 1588begin 1589 if FDockImage <> nil then 1590 gtk_widget_destroy(FDockImage); 1591 1592 ReAllocMem(FExtUTF8OutCache,0); 1593 FExtUTF8OutCacheSize:=0; 1594 1595 FreeAllStyles; 1596 FreeStockItems; 1597 FreeSystemBrushes; 1598 1599 if FGTKToolTips<>nil then begin 1600 gtk_object_sink(PGTKObject(FGTKToolTips)); 1601 FGTKToolTips := nil; 1602 end; 1603 1604 // tidy up the paint messages 1605 FMessageQueue.Lock; 1606 try 1607 QueueItem:=FMessageQueue.FirstMessageItem; 1608 while (QueueItem<>nil) do begin 1609 NextQueueItem := TGtkMessageQueueItem(QueueItem.Next); 1610 if QueueItem.IsPaintMessage then 1611 fMessageQueue.RemoveMessage(QueueItem,FPMF_All,true); 1612 QueueItem := NextQueueItem; 1613 end; 1614 1615 // warn about unremoved paint messages 1616 if fMessageQueue.HasPaintMessages then begin 1617 DebugLn(ProcName, Format(rsWarningUnremovedPaintMessages, 1618 [IntToStr(fMessageQueue.NumberOfPaintMessages)])); 1619 end; 1620 finally 1621 FMessageQueue.UnLock; 1622 end; 1623 1624 // warn about unreleased DC 1625 if (FDeviceContexts.Count > 0) 1626 then begin 1627 DebugLn(ProcName, Format(rsWarningUnreleasedDCsDump, 1628 [FDeviceContexts.Count])); 1629 1630 n:=0; 1631 DbgOut(ProcName,' DCs: '); 1632 HashItem:=FDeviceContexts.FirstHashItem; 1633 while (n<7) and (HashItem<>nil) do 1634 begin 1635 DbgOut(' ',DbgS(HashItem^.Item)); 1636 HashItem:=HashItem^.Next; 1637 inc(n); 1638 end; 1639 DebugLn(); 1640 end; 1641 1642 // warn about unreleased gdi objects 1643 if (FGDIObjects.Count > 0) 1644 then begin 1645 DebugLn(ProcName,Format(rsWarningUnreleasedGDIObjectsDump, 1646 [FGDIObjects.Count])); 1647 for GDIType := Low(TGDIType) to High(TGDIType) do 1648 GDITypeCount[GDIType] := 0; 1649 1650 n:=0; 1651 {$ifndef TraceGdiCalls} 1652 DbgOut(ProcName,' GDIOs:'); 1653 {$endif} 1654 HashItem := FGDIObjects.FirstHashItem; 1655 while (HashItem <> nil) do 1656 begin 1657 {$ifndef TraceGdiCalls} 1658 if n < 7 1659 then 1660 DbgOut(' ',DbgS(HashItem^.Item)); 1661 {$endif} 1662 1663 Inc(GDITypeCount[PGdiObject(HashItem^.Item)^.GDIType]); 1664 HashItem := HashItem^.Next; 1665 Inc(n); 1666 end; 1667 {$ifndef TraceGdiCalls} 1668 DebugLn(); 1669 {$endif} 1670 1671 for GDIType := Low(GDIType) to High(GDIType) do 1672 if GDITypeCount[GDIType] > 0 then 1673 DebugLn(ProcName,Format(' %s: %d', [dbgs(GDIType), GDITypeCount[GDIType]])); 1674 1675 // tidy up messages 1676 if FMessageQueue.Count > 0 then begin 1677 DebugLn(ProcName, Format(rsWarningUnreleasedMessagesInQueue,[FMessageQueue.Count])); 1678 while FMessageQueue.First<>nil do 1679 fMessageQueue.RemoveMessage(fMessageQueue.FirstMessageItem,FPMF_All,true); 1680 end; 1681 end; 1682 1683 // warn about unreleased timers 1684 n := FTimerData.Count; 1685 if (n > 0) then 1686 begin 1687 DebugLn(ProcName,Format(rsWarningUnreleasedTimerInfos,[n])); 1688 while (n > 0) do 1689 begin 1690 dec (n); 1691 pTimerInfo := PGtkITimerinfo (FTimerData.Items[n]); 1692 Dispose (pTimerInfo); 1693 FTimerData.Delete (n); 1694 end; 1695 end; 1696 1697 {$ifdef TraceGdiCalls} 1698 if FDeviceContexts.Count>0 then begin 1699 //DebugLn('BackTrace for unreleased device contexts follows:'); 1700 n:=0; 1701 HashItem:=FDeviceContexts.FirstHashItem; 1702 while (HashItem<>nil) and (n<MaxTraces) do 1703 begin 1704 DebugLn('DC: ', Dbgs(HashItem^.Item)); 1705 DumpBackTrace(TGtkDeviceContext(HashItem^.Item).StackAddrs); 1706 DebugLn(); 1707 HashItem:=HashItem^.Next; 1708 end; 1709 if (n>=MaxTraces) then begin 1710 DebugLn('... Truncated dump DeviceContext leakage dump.'); 1711 DebugLn(); 1712 end; 1713 end; 1714 1715 if (FGDIObjects.Count > 0) 1716 then begin 1717 //DebugLn('BackTrace for unreleased gdi objects follows:'); 1718 for GDIType := Low(TGDIType) to High(TGDIType) do begin 1719 if GDITypeCount[GDIType]<>0 then begin 1720 n:=0; 1721 HashItem := FGDIObjects.FirstHashItem; 1722 while (HashItem <> nil) and (n<MaxTraces) do begin 1723 DebugLn(dbgs(gdiType),': ', dbgs(HashItem^.Item)); 1724 DumpBackTrace(PgdiObject(HashItem^.Item)^.StackAddrs); 1725 DebugLn(); 1726 HashItem := HashItem^.Next; 1727 inc(n); 1728 end; 1729 if (n>=MaxTraces) then begin 1730 DebugLn('... Truncated ',dbgs(GDIType),' leakage dump.'); 1731 DebugLn(); 1732 end; 1733 end; 1734 end; 1735 end; 1736 {$endif} 1737 1738 FreeAndNil(FWidgetsWithResizeRequest); 1739 FreeAndNil(FWidgetsResized); 1740 FreeAndNil(FFixWidgetsResized); 1741 FreeAndNil(FMessageQueue); 1742 FreeAndNil(FDeviceContexts); 1743 FreeAndNil(FGDIObjects); 1744 {$IFDEF Use_KeyStateList} 1745 FreeAndNil(FKeyStateList_); 1746 {$ENDIF} 1747 FreeAndNil(FTimerData); 1748 1749 GtkDefDone; 1750 FreeAndNil(FDCManager); 1751 1752 // finally remove our loghandler 1753 g_log_remove_handler(nil, FLogHandlerID); 1754 1755 GTK2WidgetSet := nil; 1756 WakeMainThread := nil; 1757 1758 {$IFDEF EnabledGtkThreading} 1759 if MultiThreadingEnabled then 1760 begin 1761 {$IFNDEF Win32} 1762 {$IFDEF USE_GTK_MAIN_OLD_ITERATION} 1763 gdk_threads_leave; 1764 {$ENDIF} 1765 {$ENDIF} 1766 fMultiThreadingEnabled := False; 1767 end; 1768 {$ENDIF} 1769 1770end; 1771 1772{$ifdef Unix} 1773 1774procedure TGtk2WidgetSet.PrepareSynchronize(AObject: TObject); 1775{ This method is the WakeMainThread of the unit classes. 1776 It is called in TThread.Synchronize to wake up the main thread = LCL GUI thread. 1777 see: TGtk2WidgetSet.InitSynchronizeSupport 1778} 1779var 1780 thrash: char; 1781begin 1782 // ToDo: TGtk2WidgetSet.PrepareSynchronize what is AObject? 1783 1784 // wake up GUI thread by sending a byte through the threadsync pipe 1785 thrash:='l'; 1786 fpwrite(threadsync_pipeout, thrash, 1); 1787end; 1788 1789procedure TGtk2WidgetSet.ProcessChildSignal; 1790var 1791 pid: tpid; 1792 reason: TChildExitReason; 1793 status: integer; 1794 info: dword; 1795 handler: PChildSignalEventHandler; 1796begin 1797 repeat 1798 status:=0; 1799 pid := fpwaitpid(-1, status, WNOHANG); 1800 if pid <= 0 then break; 1801 if wifexited(status) then 1802 begin 1803 reason := cerExit; 1804 info := wexitstatus(status); 1805 end else 1806 if wifsignaled(status) then 1807 begin 1808 reason := cerSignal; 1809 info := wtermsig(status); 1810 end else 1811 continue; 1812 1813 handler := FChildSignalHandlers; 1814 while handler <> nil do 1815 begin 1816 if handler^.pid = pid then 1817 begin 1818 handler^.OnEvent(handler^.UserData, reason, info); 1819 break; 1820 end; 1821 handler := handler^.NextHandler; 1822 end; 1823 until false; 1824end; 1825 1826function threadsync_iocallback({%H-}source: PGIOChannel; {%H-}condition: TGIOCondition; 1827 data: gpointer): gboolean; cdecl; 1828var 1829 thrashspace: array[1..1024] of byte; 1830begin 1831 // read the sent bytes 1832 fpread(threadsync_pipein, {%H-}thrashspace[1], 1); 1833 1834 Result := true; 1835 // one of children signaled ? 1836 if childsig_pending then 1837 begin 1838 childsig_pending := false; 1839 TGtk2WidgetSet(data).ProcessChildSignal; 1840 end; 1841 // execute the to-be synchronized method 1842 if IsMultiThread then 1843 CheckSynchronize; 1844end; 1845 1846procedure TGtk2WidgetSet.InitSynchronizeSupport; 1847{ When a thread calls its Synchronize, it calls 1848 WakeMainThread (defined in the unit classes). 1849 Set 1850} 1851begin 1852 { TThread.Synchronize ``glue'' } 1853 WakeMainThread := @PrepareSynchronize; 1854 assignpipe(threadsync_pipein, threadsync_pipeout); 1855 threadsync_giochannel := g_io_channel_unix_new(threadsync_pipein); 1856 g_io_add_watch(threadsync_giochannel, G_IO_IN, @threadsync_iocallback, Self); 1857end; 1858 1859{$else} 1860 1861{$message warn TThread.Synchronize will not work on Gtk/Win32 } 1862 1863procedure InitSynchronizeSupport; 1864begin 1865end; 1866 1867{$endif} 1868 1869{------------------------------------------------------------------------------ 1870 procedure TGtk2WidgetSet.UpdateTransientWindows; 1871 ------------------------------------------------------------------------------} 1872procedure TGtk2WidgetSet.UpdateTransientWindows; 1873 1874type 1875 PTransientWindow = ^TTransientWindow; 1876 TTransientWindow = record 1877 GtkWindow: PGtkWindow; 1878 Component: TComponent; 1879 IsModal: boolean; 1880 SortIndex: integer; 1881 TransientParent: PGtkWindow; 1882 end; 1883 1884var 1885 AllWindows: TFPList; 1886 List,orgList: PGList; 1887 Window: PGTKWindow; 1888 ATransientWindow: PTransientWindow; 1889 LCLObject: TObject; 1890 LCLComponent: TComponent; 1891 i: Integer; 1892 FirstModal: Integer; 1893 j: Integer; 1894 ATransientWindow1: PTransientWindow; 1895 ATransientWindow2: PTransientWindow; 1896 ParentTransientWindow: PTransientWindow; 1897 OldTransientParent: PGtkWindow; 1898begin 1899 if (not UseTransientForModalWindows) then exit; 1900 if UpdatingTransientWindows then begin 1901 DebugLn('TGtk2WidgetSet.UpdateTransientWindows already updating'); 1902 exit; 1903 end; 1904 UpdatingTransientWindows:=true; 1905 try 1906 {$IFDEF VerboseTransient} 1907 DebugLn('TGtk2WidgetSet.UpdateTransientWindows'); 1908 {$ENDIF} 1909 AllWindows:=nil; 1910 1911 // find all currently visible gtkwindows 1912 List := gdk_window_get_toplevels; 1913 orgList := List; 1914 while List <> nil do 1915 begin 1916 if (List^.Data <> nil) 1917 then begin 1918 gdk_window_get_user_data(PGDKWindow(List^.Data), Pgpointer(@Window)); 1919 if GtkWidgetIsA(PGtkWidget(Window), GTK_TYPE_WINDOW) 1920 and gtk_widget_visible(PGtkWidget(Window)) 1921 then begin 1922 // visible window found -> add to list 1923 New(ATransientWindow); 1924 FillChar(ATransientWindow^,SizeOf(TTransientWindow),0); 1925 ATransientWindow^.GtkWindow:=Window; 1926 LCLObject:=GetLCLObject(Window); 1927 if (LCLObject<>nil) and (LCLObject is TComponent) then begin 1928 LCLComponent:=TComponent(LCLObject); 1929 ATransientWindow^.Component:=LCLComponent; 1930 end; 1931 if (ModalWindows<>nil) then 1932 ATransientWindow^.SortIndex:=ModalWindows.IndexOf(Window) 1933 else 1934 ATransientWindow^.SortIndex:=-1; 1935 ATransientWindow^.IsModal:=(ATransientWindow^.SortIndex>=0) 1936 and (GTK_WIDGET_VISIBLE(PGtkWidget(Window))); 1937 if not ATransientWindow^.IsModal then begin 1938 if (LCLObject is TCustomForm) 1939 and (TCustomForm(LCLObject).Parent=nil) then 1940 ATransientWindow^.SortIndex:= 1941 Screen.CustomFormZIndex(TCustomForm(LCLObject)); 1942 end; 1943 1944 if ATransientWindow^.SortIndex<0 then begin 1945 // this window has no form. Move it to the back. 1946 ATransientWindow^.SortIndex:=Screen.CustomFormCount; 1947 end; 1948 1949 //DebugLn(['TGtk2WidgetSet.UpdateTransientWindows LCLObject=',DbgSName(LCLObject),' ATransientWindow^.SortIndex=',ATransientWindow^.SortIndex]); 1950 if AllWindows=nil then AllWindows:=TFPList.Create; 1951 AllWindows.Add(ATransientWindow); 1952 end; 1953 end; 1954 list := g_list_next(list); 1955 end; 1956 if Assigned(orgList) then 1957 begin 1958 g_list_free(orgList); 1959 list:=nil; orgList:=nil; 1960 end; 1961 1962 if AllWindows=nil then exit; 1963 1964 //for i:=0 to SCreen.CustomFormZOrderCount-1 do 1965 // DebugLn(['TGtk2WidgetSet.UpdateTransientWindows i=',i,'/',SCreen.CustomFormZOrderCount,' ',DbgSName(SCreen.CustomFormsZOrdered[i])]); 1966 1967 // sort 1968 // move all modal windows to the end of the window list 1969 i:=AllWindows.Count-1; 1970 FirstModal:=AllWindows.Count; 1971 while i>=0 do begin 1972 ATransientWindow:=PTransientWindow(AllWindows[i]); 1973 if ATransientWindow^.IsModal 1974 and (i<FirstModal) then begin 1975 dec(FirstModal); 1976 if i<FirstModal then 1977 AllWindows.Exchange(i,FirstModal); 1978 end; 1979 dec(i); 1980 end; 1981 1982 if FirstModal=AllWindows.Count then begin 1983 // there is no modal window 1984 // -> break all transient window relation ships 1985 for i:=AllWindows.Count-1 downto 0 do begin 1986 ATransientWindow:=PTransientWindow(AllWindows[i]); 1987 {$IFDEF VerboseTransient} 1988 debugln(['TGtk2WidgetSet.UpdateTransientWindows Untransient ',i, 1989 ' ',dbgsname(ATransientWindow^.Component)]); 1990 {$ENDIF} 1991 gtk_window_set_transient_for(ATransientWindow^.GtkWindow,nil); 1992 end; 1993 end else begin 1994 // there are modal windows 1995 // -> sort windows in z order and setup transient relationships 1996 1997 //DebugLn(['TGtk2WidgetSet.UpdateTransientWindows ModalWindows=',AllWindows.Count-FirstModal,' NonModalWindows=',FirstModal]); 1998 1999 // sort modal windows (bubble sort) 2000 for i:=FirstModal to AllWindows.Count-2 do begin 2001 for j:=i+1 to AllWindows.Count-1 do begin 2002 ATransientWindow1:=PTransientWindow(AllWindows[i]); 2003 ATransientWindow2:=PTransientWindow(AllWindows[j]); 2004 if ATransientWindow1^.SortIndex>ATransientWindow2^.SortIndex then 2005 AllWindows.Exchange(i,j); 2006 end; 2007 end; 2008 2009 // sort non modal windows for z order 2010 // ToDo: How do we get the z order? 2011 // For now, just use the inverse order in the Screen object 2012 // that means: the lower in the Screen object, the later in the transient list 2013 for i:=0 to FirstModal-2 do begin 2014 for j:=i+1 to FirstModal-1 do begin 2015 ATransientWindow1:=PTransientWindow(AllWindows[i]); 2016 ATransientWindow2:=PTransientWindow(AllWindows[j]); 2017 if ATransientWindow1^.SortIndex<ATransientWindow2^.SortIndex then 2018 AllWindows.Exchange(i,j); 2019 end; 2020 end; 2021 2022 // set all transient relationships for LCL windows 2023 ParentTransientWindow:=nil; 2024 for i:=0 to AllWindows.Count-1 do begin 2025 ATransientWindow:=PTransientWindow(AllWindows[i]); 2026 if (ATransientWindow^.Component<>nil) 2027 and GTK_WIDGET_VISIBLE(PgtkWidget(ATransientWindow^.GtkWindow)) then 2028 begin 2029 if ParentTransientWindow<>nil then begin 2030 {$IFDEF VerboseTransient} 2031 DebugLn(['Define TRANSIENT ', 2032 ' Parent=', 2033 dbgsname(ParentTransientWindow^.Component), 2034 ' Index=',ParentTransientWindow^.SortIndex, 2035 ' Wnd=',DbgS(ParentTransientWindow^.GtkWindow), 2036 ' Child=',dbgsname(ATransientWindow^.Component), 2037 ' Index=',ATransientWindow^.SortIndex, 2038 ' Wnd=',DbgS(ATransientWindow^.GtkWindow), 2039 '']); 2040 {$ENDIF} 2041 ATransientWindow^.TransientParent:=ParentTransientWindow^.GtkWindow; 2042 end; 2043 ParentTransientWindow:=ATransientWindow; 2044 end; 2045 end; 2046 2047 // Each transient relationship can reorder the visible forms 2048 // To reduce flickering and creation of temporary circles 2049 // do the setup in two separate steps: 2050 2051 // break unneeded transient relationships 2052 for i:=AllWindows.Count-1 downto 0 do begin 2053 ATransientWindow:=PTransientWindow(AllWindows[i]); 2054 OldTransientParent:=ATransientWindow^.GtkWindow^.transient_parent; 2055 if (OldTransientParent<>ATransientWindow^.TransientParent) then begin 2056 {$IFDEF VerboseTransient} 2057 DebugLn(['Break old TRANSIENT i=',i,'/',AllWindows.Count, 2058 ' OldTransientParent=',DbgS(OldTransientParent), 2059 ' Child=',dbgsname(ATransientWindow^.Component), 2060 ' Index=',ATransientWindow^.SortIndex, 2061 ' Wnd=',DbgS(ATransientWindow^.GtkWindow), 2062 '']); 2063 {$ENDIF} 2064 gtk_window_set_transient_for(ATransientWindow^.GtkWindow,nil); 2065 end; 2066 end; 2067 2068 // setup transient relationships 2069 for i:=0 to AllWindows.Count-1 do begin 2070 ATransientWindow:=PTransientWindow(AllWindows[i]); 2071 if ATransientWindow^.TransientParent=nil then continue; 2072 {$IFDEF VerboseTransient} 2073 DebugLn(['Set TRANSIENT i=',i,'/',AllWindows.Count, 2074 ' Child=',dbgsname(ATransientWindow^.Component), 2075 ' Index=',ATransientWindow^.SortIndex, 2076 ' Wnd=',DbgS(ATransientWindow^.GtkWindow), 2077 ' Parent=',DbgS(ATransientWindow^.TransientParent), 2078 '']); 2079 {$ENDIF} 2080 gtk_window_set_transient_for(ATransientWindow^.GtkWindow, 2081 ATransientWindow^.TransientParent); 2082 end; 2083 end; 2084 2085 // clean up 2086 for i:=0 to AllWindows.Count-1 do begin 2087 ATransientWindow:=PTransientWindow(AllWindows[i]); 2088 Dispose(ATransientWindow); 2089 end; 2090 AllWindows.Free; 2091 finally 2092 UpdatingTransientWindows:=false; 2093 end; 2094end; 2095 2096{------------------------------------------------------------------------------ 2097 procedure TGtk2WidgetSet.UntransientWindow(GtkWindow: PGtkWindow); 2098 ------------------------------------------------------------------------------} 2099procedure TGtk2WidgetSet.UntransientWindow(GtkWindow: PGtkWindow); 2100{$IFDEF VerboseTransient} 2101var 2102 LCLObject: TObject; 2103{$ENDIF} 2104begin 2105 {$IFDEF VerboseTransient} 2106 DbgOut('TGtk2WidgetSet.UntransientWindow ',DbgS(GtkWindow)); 2107 LCLObject:=GetLCLObject(PGtkWidget(GtkWindow)); 2108 if LCLObject<>nil then 2109 DbgOut(' LCLObject=',LCLObject.ClassName) 2110 else 2111 DbgOut(' LCLObject=nil'); 2112 DebugLn(''); 2113 {$ENDIF} 2114 // hide window, so that UpdateTransientWindows untransients it 2115 if GTK_WIDGET_VISIBLE(PgtkWidget(GtkWindow)) then 2116 gtk_widget_hide(PgtkWidget(GtkWindow)); 2117 UpdateTransientWindows; 2118 // remove it from the modal window list 2119 if ModalWindows<>nil then begin 2120 ModalWindows.Remove(GtkWindow); 2121 if ModalWindows.Count=0 then FreeAndNil(ModalWindows); 2122 end; 2123end; 2124 2125{------------------------------------------------------------------------------ 2126 Method: TGtk2WidgetSet.SendCachedLCLMessages 2127 Params: None 2128 Returns: Nothing 2129 2130 Some LCL messages are not sent directly to the gtk. Send them now. 2131 ------------------------------------------------------------------------------} 2132procedure TGtk2WidgetSet.SendCachedLCLMessages; 2133 2134 procedure SendCachedLCLResizeRequests; 2135 var 2136 Widget: PGtkWidget; 2137 LCLControl: TWinControl; 2138 IsTopLevelWidget: boolean; 2139 TopologicalList: TFPList; // list of PGtkWidget; 2140 i: integer; 2141 2142 procedure RaiseWidgetWithoutControl; 2143 begin 2144 RaiseGDBException('ERROR: TGtk2WidgetSet.SendCachedLCLMessages Widget ' 2145 +DbgS(Widget)+' without LCL control'); 2146 end; 2147 2148 begin 2149 if FWidgetsWithResizeRequest.Count=0 then exit; 2150 {$IFDEF VerboseSizeMsg} 2151 DebugLn('GGG1 SendCachedLCLResizeRequests SizeMsgCount=',dbgs(FWidgetsWithResizeRequest.Count)); 2152 {$ENDIF} 2153 2154 TopologicalList:=CreateTopologicalSortedWidgets(FWidgetsWithResizeRequest); 2155 for i:=0 to TopologicalList.Count-1 do begin 2156 Widget:=TopologicalList[i]; 2157 2158 // resize widget 2159 LCLControl:=TWinControl(GetLCLObject(Widget)); 2160 if (LCLControl=nil) or (not (LCLControl is TControl)) then begin 2161 RaiseWidgetWithoutControl; 2162 end; 2163 {$IFDEF VerboseSizeMsg} 2164 if CompareText(LCLControl.ClassName,'TScrollBar')=0 then 2165 DebugLn('SendCachedLCLMessages ',LCLControl.Name,':',LCLControl.ClassName, 2166 ' ',dbgs(LCLControl.Left)+','+dbgs(LCLControl.Top)+','+dbgs(LCLControl.Width)+'x'+dbgs(LCLControl.Height)); 2167 {$ENDIF} 2168 2169 IsTopLevelWidget:= (LCLControl is TCustomForm) 2170 and (LCLControl.Parent = nil); 2171 2172 if not IsTopLevelWidget then begin 2173 SetWidgetSizeAndPosition(LCLControl); 2174 end 2175 else begin 2176 // resize form 2177 {$IFDEF VerboseFormPositioning} 2178 DebugLn('VFP SendCachedLCLMessages1 ', dbgs(GetControlWindow(Widget)<>nil)); 2179 if (LCLControl is TCustomForm) then 2180 DebugLn('VFP SendCachedLCLMessages2 ',LCLControl.ClassName,' ', 2181 dbgs(LCLControl.Left),',',dbgs(LCLControl.Top),',',dbgs(LCLControl.Width),',',dbgs(LCLControl.Height)); 2182 {$ENDIF} 2183 SetWindowSizeAndPosition(PgtkWindow(Widget),TWinControl(LCLControl)); 2184 end; 2185 2186 end; 2187 TopologicalList.Free; 2188 FWidgetsWithResizeRequest.Clear; 2189 end; 2190 2191begin 2192 SendCachedLCLResizeRequests; 2193end; 2194 2195{------------------------------------------------------------------------------ 2196 Method: TGtk2WidgetSet.LCLtoGtkMessagePending 2197 Params: None 2198 Returns: boolean 2199 2200 Returns true if any messages from the lcl to the gtk is in cache and needs 2201 delivery. 2202 ------------------------------------------------------------------------------} 2203function TGtk2WidgetSet.LCLtoGtkMessagePending: boolean; 2204begin 2205 Result:=(FWidgetsWithResizeRequest.Count>0); 2206end; 2207 2208{------------------------------------------------------------------------------ 2209 Method: TGtk2WidgetSet.SendCachedGtkMessages 2210 Params: None 2211 Returns: Nothing 2212 2213 Some Gtk messages are not sent directly to the LCL. Send them now. 2214 ------------------------------------------------------------------------------} 2215procedure TGtk2WidgetSet.SendCachedGtkMessages; 2216begin 2217 SendCachedGtkResizeNotifications; 2218end; 2219 2220{ 2221 Changes some colors of the widget style 2222 2223 IMPORTANT: 2224 SystemColors like clBtnFace depend on the theme and widget class, so they 2225 must be read from the theme. But many gtk themes do not provide all colors 2226 and instead only provide bitmaps. 2227 Since we don't have good fallbacks yet, and many controls use SystemColors 2228 for Delphi compatibility: ignore SystemColors from the following list: 2229 2230 Gtk 2: 2231 2232 clNone (should be ignored anyway), 2233 clBtnFace, 2234 2235 Gtk 1: 2236 2237 clNone, 2238 Any system color 2239} 2240procedure TGtk2WidgetSet.SetWidgetColor(const AWidget: PGtkWidget; 2241 const FGColor, BGColor: TColor; const Mask: tGtkStateEnum); 2242var 2243 i: integer; 2244 xfg, xbg: TGdkColor; 2245 ChangeFGColor: Boolean; 2246 ChangeBGColor: Boolean; 2247 NewColor: PGdkColor; 2248begin 2249 ChangeFGColor := (FGColor <> clNone); 2250 ChangeBGColor := (BGColor <> clNone); 2251 2252 if (not ChangeFGColor) and (not ChangeBGColor) then Exit; 2253 2254 // the GTKAPIWidget is self drawn, so no use to change the widget style. 2255 if GtkWidgetIsA(AWidget, GTKAPIWidget_GetType) then Exit; 2256 2257 {$IFDEF DisableWidgetColor} 2258 exit; 2259 {$ENDIF} 2260 2261 //DebugLn('TGtk2WidgetSet.SetWidgetColor ',GetWidgetDebugReport(AWidget),' ',hexstr(FGColor,8),' ',hexstr(BGColor,8)); 2262 //RaiseGDBException(''); 2263 if ChangeFGColor then 2264 begin 2265 if (FGColor = clDefault) then 2266 NewColor := nil 2267 else 2268 begin 2269 xfg := AllocGDKColor(ColorToRGB(FGColor)); 2270 NewColor := @xfg; 2271 end; 2272 for i := GTK_STATE_NORMAL to GTK_STATE_INSENSITIVE do 2273 begin 2274 if i in mask then 2275 begin 2276 if GTK_STYLE_TEXT in mask then 2277 gtk_widget_modify_text(AWidget, i, NewColor) 2278 else 2279 gtk_widget_modify_fg(AWidget, i, NewColor); 2280 end; 2281 end; 2282 end; 2283 2284 if ChangeBGColor then 2285 begin 2286 // setting bg color to nil will cancel previous calls to gtk_widget_modify_bg() 2287 // cannot use nil on a GtkLayout (issue #16183) 2288 if not GTK_IS_LAYOUT(AWidget) and 2289 ((BGColor = clDefault) or (BGColor = clBtnFace)) then 2290 NewColor := nil 2291 else 2292 begin 2293 xbg := AllocGDKColor(ColorToRGB(BGColor)); 2294 NewColor := @xbg; 2295 end; 2296 for i := GTK_STATE_NORMAL to GTK_STATE_INSENSITIVE do 2297 begin 2298 if i in mask then 2299 begin 2300 if GTK_STYLE_BASE in mask then 2301 gtk_widget_modify_base(AWidget, i, NewColor) 2302 else 2303 gtk_widget_modify_bg(AWidget, i, NewColor); 2304 end; 2305 end; 2306 end; 2307end; 2308 2309{------------------------------------------------------------------------------ 2310 Method: TGtk2WidgetSet.AppProcessMessages 2311 Params: None 2312 Returns: Nothing 2313 2314 Handle all pending messages of the GTK engine and of this interface 2315 ------------------------------------------------------------------------------} 2316procedure TGtk2WidgetSet.AppProcessMessages; 2317 2318 function PendingGtkMessagesExists: boolean; 2319 begin 2320 {$IFDEF USE_GTK_MAIN_OLD_ITERATION} 2321 Result:=(gtk_events_pending<>0) or LCLtoGtkMessagePending; 2322 {$ELSE} 2323 Result := g_main_context_pending(g_main_context_default) or 2324 LCLtoGtkMessagePending; 2325 {$ENDIF} 2326 end; 2327 2328var 2329 vlItem : TGtkMessageQueueItem; 2330 vlMsg : PMSg; 2331 i: Integer; 2332begin 2333 repeat 2334 // send cached LCL messages to the gtk 2335 //DebugLn(['TGtk2WidgetSet.AppProcessMessages SendCachedLCLMessages']); 2336 SendCachedLCLMessages; 2337 2338 // let gtk handle up to 100 messages and call our callbacks 2339 i:=100; 2340 2341 if not FGtkTerminated then 2342 begin 2343 {$IFDEF USE_GTK_MAIN_OLD_ITERATION} 2344 while (gtk_events_pending<>0) and (i>0) do 2345 begin 2346 if FGtkTerminated then 2347 break; 2348 gtk_main_iteration_do(False); 2349 dec(i); 2350 end; 2351 {$ELSE} 2352 while g_main_context_pending(g_main_context_default) and (i>0) do 2353 begin 2354 if FGtkTerminated then 2355 break; 2356 if not g_main_context_iteration(g_main_context_default, False) then 2357 break; 2358 dec(i); 2359 end; 2360 {$ENDIF} 2361 end; 2362 2363 //DebugLn(['TGtk2WidgetSet.AppProcessMessages SendCachedGtkMessages']); 2364 // send cached gtk messages to the lcl 2365 SendCachedGtkMessages; 2366 2367 // then handle our own messages 2368 while not Application.Terminated do begin 2369 fMessageQueue.Lock; 2370 try 2371 // fetch first message 2372 vlItem := fMessageQueue.FirstMessageItem; 2373 if vlItem = nil then break; 2374 2375 // remove message from queue 2376 if vlItem.IsPaintMessage then begin 2377 //DebugLn(['TGtk2WidgetSet.AppProcessMessages Paint: ',DbgSName(GetLCLObject(Pointer(vlItem.Msg^.hwnd)))]); 2378 // paint messages are the most expensive messages in the LCL, 2379 // therefore they are sent after all other 2380 if MovedPaintMessageCount<10 then begin 2381 inc(MovedPaintMessageCount); 2382 if fMessageQueue.HasNonPaintMessages then begin 2383 // there are non paint messages -> move paint message to the end 2384 fMessageQueue.MoveToLast(FMessageQueue.First); 2385 continue; 2386 end else begin 2387 // there are only paint messages left in the queue 2388 // -> check other queues 2389 if PendingGtkMessagesExists then break; 2390 end; 2391 end else begin 2392 // handle this paint message now 2393 MovedPaintMessageCount:=0; 2394 end; 2395 end; 2396 2397 //DebugLn(['TGtk2WidgetSet.AppProcessMessages SendMessage: ',DbgSName(GetLCLObject(Pointer(vlItem.Msg^.hwnd)))]); 2398 vlMsg:=fMessageQueue.PopFirstMessage; 2399 finally 2400 fMessageQueue.UnLock; 2401 end; 2402 2403 //debugln(['TGtk2WidgetSet.AppProcessMessages ',vlMsg^.Message,' ',LM_CHAR,' ',dbgsname(GetLCLObject(Pointer(vlMsg^.hwnd)))]); 2404 // Send message 2405 if vlMsg <> nil then 2406 begin 2407 try 2408 with vlMsg^ do SendMessage(hWND, Message, WParam, LParam); 2409 finally 2410 Dispose(vlMsg); 2411 end; 2412 end; 2413 end; 2414 2415 // proceed until all messages are handled 2416 until (not PendingGtkMessagesExists) or Application.Terminated; 2417end; 2418 2419{------------------------------------------------------------------------------ 2420 Method: TGtk2WidgetSet.AppWaitMessage 2421 Params: None 2422 Returns: Nothing 2423 2424 Passes execution control to the GTK engine till something happens 2425 ------------------------------------------------------------------------------} 2426procedure TGtk2WidgetSet.AppWaitMessage; 2427begin 2428 WaitingForMessages:=true; 2429 if not FGtkTerminated then 2430 begin 2431 {$IFDEF USE_GTK_MAIN_OLD_ITERATION} 2432 gtk_main_iteration_do(True); 2433 {$ELSE} 2434 g_main_context_iteration(g_main_context_default, True); 2435 {$ENDIF} 2436 end; 2437 WaitingForMessages:=false; 2438end; 2439 2440procedure TGtk2WidgetSet.FreeStockItems; 2441 2442 procedure DeleteAndNilObject(var h: HGDIOBJ); 2443 begin 2444 if h <> 0 then 2445 begin 2446 {%H-}PGdiObject(h)^.Shared := False; 2447 {%H-}PGdiObject(h)^.RefCount := 1; 2448 end; 2449 DeleteObject(h); 2450 h := 0; 2451 end; 2452 2453begin 2454 DeleteAndNilObject(FStockNullBrush); 2455 DeleteAndNilObject(FStockBlackBrush); 2456 DeleteAndNilObject(FStockLtGrayBrush); 2457 DeleteAndNilObject(FStockGrayBrush); 2458 DeleteAndNilObject(FStockDkGrayBrush); 2459 DeleteAndNilObject(FStockWhiteBrush); 2460 2461 DeleteAndNilObject(FStockNullPen); 2462 DeleteAndNilObject(FStockBlackPen); 2463 DeleteAndNilObject(FStockWhitePen); 2464 2465 DeleteAndNilObject(FStockSystemFont); 2466end; 2467 2468procedure TGtk2WidgetSet.InitSystemColors; 2469begin 2470 // we need to request style and inside UpdateSysColorMap will be indirectly called 2471 GetStyle(lgsButton); 2472 GetStyle(lgsWindow); 2473 GetStyle(lgsMenuBar); 2474 GetStyle(lgsMenuitem); 2475 GetStyle(lgsVerticalScrollbar); 2476 GetStyle(lgsTooltip); 2477end; 2478 2479procedure TGtk2WidgetSet.InitSystemBrushes; 2480var 2481 i: integer; 2482 LogBrush: TLogBrush; 2483begin 2484 FillChar(LogBrush{%H-}, SizeOf(TLogBrush), 0); 2485 for i := Low(FSysColorBrushes) to High(FSysColorBrushes) do 2486 begin 2487 LogBrush.lbColor := GetSysColor(i); 2488 FSysColorBrushes[i] := CreateBrushIndirect(LogBrush); 2489 {%H-}PGDIObject(FSysColorBrushes[i])^.Shared := True; 2490 end; 2491end; 2492 2493procedure TGtk2WidgetSet.FreeSystemBrushes; 2494 2495 procedure DeleteAndNilObject(var h: HGDIOBJ); 2496 begin 2497 if h <> 0 then 2498 begin 2499 {%H-}PGdiObject(h)^.Shared := False; 2500 {%H-}PGdiObject(h)^.RefCount := 1; 2501 end; 2502 DeleteObject(h); 2503 h := 0; 2504 end; 2505 2506var 2507 i: integer; 2508begin 2509 for i := Low(FSysColorBrushes) to High(FSysColorBrushes) do 2510 DeleteAndNilObject(FSysColorBrushes[i]); 2511end; 2512 2513{------------------------------------------------------------------------------ 2514 Method: TGtk2WidgetSet.AppTerminate 2515 Params: None 2516 Returns: Nothing 2517 2518 *Note: Tells GTK Engine to halt and destroy 2519 ------------------------------------------------------------------------------} 2520procedure TGtk2WidgetSet.AppTerminate; 2521begin 2522 if FIsLibraryInstance then 2523 FGtkTerminated := True; 2524 // writeln('TGtk2WidgetSet.AppTerminate called from library ...'); 2525 // g_main_context_wakeup(g_main_context_default); 2526 // MG: using gtk_main_quit is not a clean way to close 2527 //gtk_main_quit; 2528end; 2529 2530function TGtk2WidgetSet.GetAppActive: Boolean; 2531begin 2532 Result := FAppActive; 2533end; 2534 2535function TGtk2WidgetSet.GetTitleBarHeight: Integer; 2536var 2537 I: Integer; 2538 AForm: TCustomForm; 2539 AWindow: PGdkWindow; 2540 ARect: TGdkRectangle; 2541 AW, AH: GInt; 2542begin 2543 Result := 30; 2544 if FCachedTitleBarHeight > 0 then 2545 Result := FCachedTitleBarHeight 2546 else 2547 if Assigned(Application) and not Application.Terminated and 2548 Assigned(Application.MainForm) then 2549 begin 2550 for i := 0 to Screen.CustomFormZOrderCount - 1 do 2551 begin 2552 AForm := Screen.CustomFormsZOrdered[i]; 2553 if (AForm.HandleAllocated) and (AForm.Visible) and (AForm.Parent = nil) and 2554 (AForm.BorderStyle <> bsNone) then 2555 begin 2556 AWindow := {%H-}PGtkWidget(AForm.Handle)^.window; 2557 if GDK_IS_WINDOW(AWindow) then 2558 begin 2559 gdk_window_get_frame_extents(AWindow, @ARect); 2560 gdk_window_get_size(AWindow, @AW, @AH); 2561 FCachedTitleBarHeight := ARect.Height - AH - 1; 2562 FCachedBorderSize := (ARect.Width - AW) div 2; 2563 Result := ARect.Height - AH - 1; 2564 break; 2565 end; 2566 end; 2567 end; 2568 end; 2569end; 2570 2571procedure TGtk2WidgetSet.SetAppActive(const AValue: Boolean); 2572begin 2573 if AValue <> FAppActive then 2574 begin 2575 FAppActive := AValue; 2576 if FAppActive then 2577 begin 2578 Application.IntfAppActivate; 2579 AppRestoreStayOnTopFlags(False); 2580 end else 2581 begin 2582 Application.IntfAppDeactivate; 2583 AppRemoveStayOnTopFlags(False); 2584 end; 2585 end; 2586end; 2587 2588function gtkAppFocusTimer({%H-}Data: gPointer):gBoolean; cdecl; 2589// needed by app activate/deactivate 2590begin 2591 Result := CallBackDefaultReturn; 2592 if TGtk2WidgetSet(WidgetSet).LastFocusIn = nil then 2593 TGtk2WidgetSet(WidgetSet).AppActive := False; 2594 gtk_timeout_remove(TGtk2WidgetSet(WidgetSet).FocusTimer); 2595 TGtk2WidgetSet(WidgetSet).FocusTimer := 0; 2596end; 2597 2598procedure TGtk2WidgetSet.StartFocusTimer; 2599begin 2600 FLastFocusIn := nil; 2601 if FocusTimer <> 0 then 2602 gtk_timeout_remove(TGtk2WidgetSet(WidgetSet).FocusTimer); 2603 FocusTimer := gtk_timeout_add(50, TGtkFunction(@gtkAppFocusTimer), nil); 2604end; 2605 2606procedure TGtk2WidgetSet.InitStockItems; 2607var 2608 LogBrush: TLogBrush; 2609 logPen : TLogPen; 2610begin 2611 FillChar(LogBrush{%H-}, SizeOf(TLogBrush), 0); 2612 LogBrush.lbStyle := BS_NULL; 2613 FStockNullBrush := CreateBrushIndirect(LogBrush); 2614 {%H-}PGDIObject(FStockNullBrush)^.Shared := True; 2615 LogBrush.lbStyle := BS_SOLID; 2616 LogBrush.lbColor := $000000; 2617 FStockBlackBrush := CreateBrushIndirect(LogBrush); 2618 {%H-}PGDIObject(FStockBlackBrush)^.Shared := True; 2619 LogBrush.lbColor := $C0C0C0; 2620 FStockLtGrayBrush := CreateBrushIndirect(LogBrush); 2621 {%H-}PGDIObject(FStockLtGrayBrush)^.Shared := True; 2622 LogBrush.lbColor := $808080; 2623 FStockGrayBrush := CreateBrushIndirect(LogBrush); 2624 {%H-}PGDIObject(FStockGrayBrush)^.Shared := True; 2625 LogBrush.lbColor := $404040; 2626 FStockDkGrayBrush := CreateBrushIndirect(LogBrush); 2627 {%H-}PGDIObject(FStockDkGrayBrush)^.Shared := True; 2628 LogBrush.lbColor := $FFFFFF; 2629 FStockWhiteBrush := CreateBrushIndirect(LogBrush); 2630 {%H-}PGDIObject(FStockWhiteBrush)^.Shared := True; 2631 2632 LogPen.lopnStyle := PS_NULL; 2633 LogPen.lopnWidth.X := 1; 2634 LogPen.lopnColor := $FFFFFF; 2635 FStockNullPen := CreatePenIndirect(LogPen); 2636 {%H-}PGDIObject(FStockNullPen)^.Shared := True; 2637 LogPen.lopnStyle := PS_SOLID; 2638 FStockWhitePen := CreatePenIndirect(LogPen); 2639 {%H-}PGDIObject(FStockWhitePen)^.Shared := True; 2640 LogPen.lopnColor := $000000; 2641 FStockBlackPen := CreatePenIndirect(LogPen); 2642 {%H-}PGDIObject(FStockBlackPen)^.Shared := True; 2643 2644 FStockSystemFont := 0;//Styles aren't initialized yet 2645end; 2646 2647{------------------------------------------------------------------------------ 2648 procedure TGtk2WidgetSet.AppSetTitle(const ATitle: string); 2649-------------------------------------------------------------------------------} 2650procedure TGtk2WidgetSet.AppSetTitle(const ATitle: string); 2651begin 2652 // ToDo: TGtk2WidgetSet.AppSetTitle: has a gtk2 application such a thing? 2653end; 2654 2655{------------------------------------------------------------------------------ 2656 Function: CreateTimer 2657 Params: Interval: 2658 TimerFunc: Callback 2659 Returns: a GTK-timer id (use this ID to destroy timer) 2660 2661 This function will create a GTK timer object and associate a callback to it. 2662 2663 Design: A callback to the TTimer class is implemented. 2664 ------------------------------------------------------------------------------} 2665function TGtk2WidgetSet.CreateTimer(Interval: integer; 2666 TimerProc: TWSTimerProc) : THandle; 2667var 2668 TimerInfo: PGtkITimerinfo; 2669begin 2670 if ((Interval < 1) or (not Assigned(TimerProc))) 2671 then 2672 Result := 0 2673 else begin 2674 New(TimerInfo); 2675 FillByte(TimerInfo^,SizeOf(TGtkITimerinfo),0); 2676 TimerInfo^.TimerFunc := TimerProc; 2677 {$IFDEF VerboseTimer} 2678 DebugLn(['TGtk2WidgetSet.CreateTimer Interval=',dbgs(Interval)]); 2679 {$ENDIF} 2680 Result:= gtk_timeout_add(Interval, @gtkTimerCB, TimerInfo); 2681 if Result = 0 then 2682 Dispose(TimerInfo) 2683 else begin 2684 TimerInfo^.TimerFunc := TimerProc; 2685 TimerInfo^.TimerHandle:=Result; 2686 FTimerData.Add(TimerInfo); 2687 end; 2688 end; 2689end; 2690 2691{------------------------------------------------------------------------------ 2692 Function: DestroyTimer 2693 Params: TimerHandle 2694 Returns: 2695 2696 WARNING: There seems to be a bug in gtk-1.2.x which breaks gtk_timeout_remove 2697 thus we can't dispose PGtkITimerinfo here (s.a. gtkTimerCB). 2698 ------------------------------------------------------------------------------} 2699function TGtk2WidgetSet.DestroyTimer(TimerHandle: THandle) : boolean; 2700var 2701 n : integer; 2702 TimerInfo : PGtkITimerinfo; 2703begin 2704 //DebugLn('Trace:removing timer!!!'); 2705 n := FTimerData.Count; 2706 while (n > 0) do begin 2707 dec (n); 2708 TimerInfo := PGtkITimerinfo(FTimerData.Items[n]); 2709 if (TimerInfo^.TimerHandle=guint(TimerHandle)) then 2710 begin 2711 {$IFDEF VerboseTimer} 2712 DebugLn(['TGtk2WidgetSet.DestroyTimer TimerInfo=',DbgS(TimerInfo),' TimerHandle=',TimerInfo^.TimerHandle]); 2713 {$ENDIF} 2714 gtk_timeout_remove(TimerInfo^.TimerHandle); 2715 FTimerData.Delete(n); 2716 Dispose(TimerInfo); 2717 end; 2718 end; 2719 Result:=true; 2720end; 2721 2722{------------------------------------------------------------------------------ 2723 function TGtk2WidgetSet.InternalGetDIBits(DC: HDC; Bitmap: HBitmap; 2724 StartScan, NumScans: UINT; 2725 BitSize : Longint; Bits: Pointer; 2726 var BitInfo: BitmapInfo; Usage: UINT; DIB : Boolean): Integer; 2727 ------------------------------------------------------------------------------} 2728function TGtk2WidgetSet.InternalGetDIBits(DC: HDC; Bitmap: HBitmap; 2729 StartScan, NumScans: UINT; BitSize : Longint; Bits: Pointer; 2730 out BitInfo: BitmapInfo; Usage: UINT; DIB : Boolean): Integer; 2731const 2732 PadLine : array[0..12] of Byte = (0,0,0,0,0,0,0,0,0,0,1,0,0); 2733 TempBuffer : array[0..2] of Byte = (0,0,0); 2734 2735var 2736 GdiObject: PGDIObject absolute Bitmap; 2737 2738 Source: PGDKPixbuf; 2739 rowstride, PixelPos: Longint; 2740 Pixels: PByte; 2741 FDIB: TDIBSection; 2742 X, Y: Longint; 2743 PadSize, Pos, BytesPerPixel: Longint; 2744 Buf16Bit: word; 2745 2746 procedure DataSourceInitialize(Bitmap : PGDIObject; Width : Longint); 2747 begin 2748 Source := nil; 2749 2750 case Bitmap^.GDIBitmapType of 2751 gbBitmap: 2752 if Bitmap^.GDIBitmapObject <> nil 2753 then begin 2754 {$ifdef VerboseGdkPixbuf} debugln('DataSourceInitialize A1');{$endif} 2755 2756 Source := CreatePixbufFromDrawable(Bitmap^.GDIBitmapObject, Bitmap^.Colormap, False, 0,StartScan,0,0,Width,StartScan + NumScans); 2757 rowstride := gdk_pixbuf_get_rowstride(Source); 2758 Pixels := PByte(gdk_pixbuf_get_pixels(Source)); 2759 2760 {$ifdef VerboseGdkPixbuf} debugln('DataSourceInitialize A2');{$endif} 2761 end; 2762 gbPixmap: 2763 if Bitmap^.GDIPixmapObject.Image <> nil 2764 then begin 2765 {$ifdef VerboseGdkPixbuf} debugln('DataSourceInitialize B1');{$endif} 2766 2767 Source := CreatePixbufFromDrawable(Bitmap^.GDIPixmapObject.Image, Bitmap^.Colormap, False, 0, StartScan, 0, 0, Width, StartScan + NumScans); 2768 {$IFDEF VerboseGtkToDos}{$note TODO: Apply alpha based on mask when 32bit mode is added}{$ENDIF} 2769 2770 rowstride := gdk_pixbuf_get_rowstride(Source); 2771 Pixels := PByte(gdk_pixbuf_get_pixels(Source)); 2772 2773 {$ifdef VerboseGdkPixbuf} debugln('DataSourceInitialize B2');{$endif} 2774 end; 2775 gbPixbuf: 2776 if Bitmap^.GDIPixbufObject <> nil 2777 then begin 2778 rowstride := gdk_pixbuf_get_rowstride(Bitmap^.GDIPixbufObject); 2779 Pixels := PByte(gdk_pixbuf_get_pixels(Bitmap^.GDIPixbufObject)); 2780 end; 2781 end; 2782 end; 2783 2784 function DataSourceGetGDIRGB(Bitmap : PGDIObject; X, Y : Longint) : TGDIRGB; 2785 begin 2786 if Bitmap <> nil then ; //Keep compiler happy.. 2787 2788 PixelPos := rowstride*Y + X*3; 2789 2790 with Result do 2791 begin 2792 Red := Pixels[PixelPos + 0]; 2793 Green := Pixels[PixelPos + 1]; 2794 Blue := Pixels[PixelPos + 2]; 2795 end; 2796 end; 2797 2798 procedure DataSourceFinalize; 2799 begin 2800 if Source <> nil 2801 then gdk_pixbuf_unref(Source); 2802 end; 2803 2804 procedure WriteData(Value : PByte; Size : Longint); 2805 begin 2806 System.Move(Value^, PByte(Bits)[Pos], Size); 2807 Inc(Pos, Size); 2808 end; 2809 2810 procedure WriteData(Value : Word); 2811 begin 2812 PByte(Bits)[Pos] := Lo(Value); 2813 inc(Pos); 2814 PByte(Bits)[Pos] := Hi(Value); 2815 inc(Pos); 2816 end; 2817 2818begin 2819 //DebugLn('trace:[TGtk2WidgetSet.InternalGetDIBits]'); 2820 2821 Result := 0; 2822 FillByte(BitInfo{%H-},SizeOf(BitInfo),0); 2823 2824 if (DC=0) or (Usage=0) then ; 2825 if not IsValidGDIObject(Bitmap) 2826 then begin 2827 DebugLn('WARNING: [TGtk2WidgetSet.InternalGetDIBits] invalid Bitmap!'); 2828 Exit; 2829 end; 2830 2831 if GdiObject^.GDIType <> gdiBitmap 2832 then begin 2833 DebugLn('WARNING: [TGtk2WidgetSet.InternalGetDIBits] not a Bitmap!'); 2834 Exit; 2835 end; 2836 2837 2838 FillChar(FDIB{%H-}, SizeOf(FDIB), 0); 2839 GetObject(Bitmap, SizeOf(FDIB), @FDIB); 2840 2841 with GdiObject^, BitInfo.bmiHeader do 2842 begin 2843 if not DIB 2844 then begin 2845 NumScans := biHeight; 2846 StartScan := 0; 2847 end; 2848 BytesPerPixel := biBitCount div 8; 2849 2850 if BitSize <= 0 then 2851 BitSize := longint(SizeOf(Byte)) 2852 *(longint(biSizeImage) div biHeight) 2853 *longint(NumScans + StartScan); 2854 if MemSize(Bits) < PtrInt(BitSize) 2855 then begin 2856 DebugLn('WARNING: [TGtk2WidgetSet.InternalGetDIBits] not enough memory allocated for Bits!'); 2857 exit; 2858 end; 2859 2860 // ToDo: other bitcounts 2861 if (biBitCount<>24) and (biBitCount<>16) 2862 then begin 2863 DebugLn('WARNING: [TGtk2WidgetSet.InternalGetDIBits] unsupported biBitCount=',dbgs(biBitCount)); 2864 exit; 2865 end; 2866 2867 if NumScans = 0 then Exit; 2868 2869 Pos := 0; 2870 PadSize := (Longint(biSizeImage) div biHeight) - biWidth * BytesPerPixel; 2871 2872 {$ifdef DebugGDK} BeginGDKErrorTrap; try{$ENDIF} 2873 DataSourceInitialize(GdiObject, biWidth); 2874 2875 if DIB 2876 then Y := NumScans - 1 2877 else Y := 0; 2878 2879 case biBitCount of 2880 24: repeat 2881 for X := 0 to biwidth - 1 do 2882 begin 2883 with DataSourceGetGDIRGB({%H-}PGDIObject(Bitmap), X, Y) do 2884 begin 2885 TempBuffer[0] := Blue; 2886 TempBuffer[1] := Green; 2887 TempBuffer[2] := Red; 2888 end; 2889 WriteData(TempBuffer, BytesPerPixel); 2890 end; 2891 WriteData(PadLine, PadSize); 2892 2893 if DIB 2894 then dec(y) 2895 else inc(y); 2896 until (Y < 0) or (y >= longint(NumScans)); 2897 2898 16: repeat 2899 for X := 0 to biwidth - 1 do 2900 begin 2901 with DataSourceGetGDIRGB({%H-}PGDIObject(Bitmap), X, Y) do 2902 begin 2903 Buf16Bit := (Blue shr 3) shl 11 2904 + (Green shr 2) shl 5 2905 + (Red shr 3); 2906 end; 2907 WriteData(Buf16Bit); 2908 end; 2909 WriteData(PadLine, PadSize); 2910 2911 if DIB 2912 then dec(y) 2913 else inc(y); 2914 until (Y < 0) or (y >= longint(NumScans)); 2915 end; 2916 end; 2917 2918 DataSourceFinalize; 2919 2920 2921 {$ifdef DebugGDK}finally EndGDKErrorTrap; end;{$endif} 2922end; 2923 2924function TGtk2WidgetSet.RawImage_DescriptionFromDrawable(out 2925 ADesc: TRawImageDescription; ADrawable: PGdkDrawable; ACustomAlpha: Boolean 2926 ): boolean; 2927var 2928 Visual: PGdkVisual; 2929 Image: PGdkImage; 2930 Width, Height, Depth: integer; 2931 IsBitmap: Boolean; 2932begin 2933 Visual := nil; 2934 Width := 0; 2935 Height := 0; 2936 2937 if ADrawable = nil 2938 then begin 2939 Visual := gdk_visual_get_system; 2940 IsBitmap := False; 2941 end 2942 else begin 2943 gdk_drawable_get_size(ADrawable, @Width, @Height); 2944 Depth := gdk_drawable_get_depth(ADrawable); 2945 Visual := gdk_window_get_visual(ADrawable); 2946 // pixmaps and bitmaps do not have a visual, but for pixmaps we need one 2947 if Visual = nil 2948 then Visual := gdk_visual_get_best_with_depth(Depth); 2949 IsBitmap := Depth = 1; 2950 end; 2951 2952 if (Visual = nil) and not IsBitmap // bitmaps don't have a visual 2953 then begin 2954 DebugLn('TGtk2WidgetSet.RawImage_DescriptionFromDrawable: visual failed'); 2955 Exit(False); 2956 end; 2957 2958 ADesc.Init; 2959 ADesc.Width := cardinal(Width); 2960 ADesc.Height := cardinal(Height); 2961 ADesc.BitOrder := riboBitsInOrder; 2962 2963 if ACustomAlpha 2964 then begin 2965 // always give pixbuf description for alpha images 2966 ADesc.Format:=ricfRGBA; 2967 ADesc.Depth := 32; 2968 ADesc.BitsPerPixel := 32; 2969 ADesc.LineEnd := rileDWordBoundary; 2970 ADesc.ByteOrder := riboLSBFirst; 2971 2972 ADesc.RedPrec := 8; 2973 ADesc.RedShift := 0; 2974 ADesc.GreenPrec := 8; 2975 ADesc.GreenShift := 8; 2976 ADesc.BluePrec := 8; 2977 ADesc.BlueShift := 16; 2978 ADesc.AlphaPrec := 8; 2979 ADesc.AlphaShift := 24; 2980 2981 ADesc.MaskBitsPerPixel := 1; 2982 ADesc.MaskShift := 0; 2983 ADesc.MaskLineEnd := rileByteBoundary; 2984 ADesc.MaskBitOrder := riboBitsInOrder; 2985 2986 Exit(True); 2987 end; 2988 2989 // Format 2990 if IsBitmap 2991 then begin 2992 ADesc.Format := ricfGray; 2993 end 2994 else begin 2995 case Visual^.thetype of 2996 GDK_VISUAL_STATIC_GRAY: ADesc.Format:=ricfGray; 2997 GDK_VISUAL_GRAYSCALE: ADesc.Format:=ricfGray; 2998 GDK_VISUAL_STATIC_COLOR: ADesc.Format:=ricfGray; // this is not really gray, but an index in a color map, but colormaps are not supported yet, so use gray 2999 GDK_VISUAL_PSEUDO_COLOR: ADesc.Format:=ricfGray; 3000 GDK_VISUAL_TRUE_COLOR: ADesc.Format:=ricfRGBA; 3001 GDK_VISUAL_DIRECT_COLOR: ADesc.Format:=ricfRGBA; 3002 else 3003 DebugLn('TGtk2WidgetSet.GetWindowRawImageDescription unknown Visual type ', 3004 dbgs(Integer(Visual^.thetype))); 3005 Exit(False); 3006 end; 3007 end; 3008 3009 // Palette 3010 if not IsBitmap 3011 and (Visual^.thetype in [GDK_VISUAL_GRAYSCALE, 3012 GDK_VISUAL_STATIC_COLOR,GDK_VISUAL_PSEUDO_COLOR]) 3013 then begin 3014 // has palette 3015 // ToDo 3016 ADesc.PaletteColorCount:=0; 3017 end; 3018 3019 // Depth 3020 if IsBitmap 3021 then ADesc.Depth := 1 3022 else ADesc.Depth := Visual^.Depth; 3023 3024 if IsBitmap or (Visual^.byte_order = GDK_MSB_FIRST) 3025 then ADesc.ByteOrder := riboMSBFirst 3026 else ADesc.ByteOrder := riboLSBFirst; 3027 3028 ADesc.LineOrder := riloTopToBottom; 3029 3030 case ADesc.Depth of 3031 0..8: ADesc.BitsPerPixel := ADesc.Depth; 3032 9..16: ADesc.BitsPerPixel := 16; 3033 17..32: ADesc.BitsPerPixel := 32; 3034 else 3035 ADesc.BitsPerPixel := 64; 3036 end; 3037 3038 if IsBitmap 3039 then begin 3040 ADesc.LineEnd := rileByteBoundary; 3041 ADesc.RedPrec := 1; 3042 ADesc.RedShift := 0; 3043 end 3044 else begin 3045 // Try retrieving the lineend 3046 Image := gdk_image_new(GDK_IMAGE_NORMAL, Visual, 1, 1); 3047 if Image = nil 3048 then begin 3049 DebugLn('TGtk2WidgetSet.GetWindowRawImageDescription testimage creation failed '); 3050 Exit(False); 3051 end; 3052 try 3053 // the minimum alignment we can detect is bpp 3054 // that is no problem since a line consists of n x bytesperpixel bytes 3055 case Image^.bpl of 3056 1: ADesc.LineEnd := rileByteBoundary; 3057 2: ADesc.LineEnd := rileWordBoundary; 3058 4: ADesc.LineEnd := rileDWordBoundary; 3059 8: ADesc.LineEnd := rileQWordBoundary; 3060 else 3061 DebugLn('TGtk2WidgetSet.GetWindowRawImageDescription Unknown line end: %d', [Image^.bpl]); 3062 Exit(False); 3063 end; 3064 finally 3065 gdk_image_destroy(Image); 3066 Image := nil; 3067 end; 3068 3069 ADesc.RedPrec := Visual^.red_prec; 3070 ADesc.RedShift := Visual^.red_shift; 3071 ADesc.GreenPrec := Visual^.green_prec; 3072 ADesc.GreenShift := Visual^.green_shift; 3073 ADesc.BluePrec := Visual^.blue_prec; 3074 ADesc.BlueShift := Visual^.blue_shift; 3075 3076 ADesc.MaskBitsPerPixel := 1; 3077 ADesc.MaskShift := 0; 3078 ADesc.MaskLineEnd := rileByteBoundary; 3079 ADesc.MaskBitOrder := riboBitsInOrder; 3080 end; 3081 3082 {$IFDEF VerboseRawImage} 3083 DebugLn('TGtk2WidgetSet.GetWindowRawImageDescription A ',ADesc.AsString); 3084 {$ENDIF} 3085 3086 Result := True; 3087end; 3088 3089function TGtk2WidgetSet.RawImage_DescriptionFromPixbuf(out ADesc: TRawImageDescription; APixbuf: PGdkPixbuf): boolean; 3090var 3091 Width, Height, Depth: integer; 3092 HasAlpha: Boolean; 3093begin 3094 Width := 0; 3095 Height := 0; 3096 3097 if APixbuf = nil 3098 then begin 3099 HasAlpha := False; 3100 Depth := 24; 3101 end 3102 else begin 3103 Width := gdk_pixbuf_get_width(APixbuf); 3104 Height := gdk_pixbuf_get_height(APixbuf); 3105 Depth := gdk_pixbuf_get_bits_per_sample(APixbuf) * gdk_pixbuf_get_n_channels(APixbuf); 3106 HasAlpha := gdk_pixbuf_get_has_alpha(APixbuf); 3107 end; 3108 3109 ADesc.Init; 3110 ADesc.Width := cardinal(Width); 3111 ADesc.Height := cardinal(Height); 3112 ADesc.BitOrder := riboBitsInOrder; 3113 3114 if HasAlpha 3115 then begin 3116 // always give pixbuf description for alpha images 3117 ADesc.Format:=ricfRGBA; 3118 ADesc.Depth := 32; 3119 ADesc.BitsPerPixel := 32; 3120 ADesc.LineEnd := rileDWordBoundary; 3121 ADesc.ByteOrder := riboLSBFirst; 3122 3123 ADesc.RedPrec := 8; 3124 ADesc.RedShift := 0; 3125 ADesc.GreenPrec := 8; 3126 ADesc.GreenShift := 8; 3127 ADesc.BluePrec := 8; 3128 ADesc.BlueShift := 16; 3129 ADesc.AlphaPrec := 8; 3130 ADesc.AlphaShift := 24; 3131 3132 ADesc.MaskBitsPerPixel := 0; 3133 ADesc.MaskShift := 0; 3134 ADesc.MaskLineEnd := rileByteBoundary; 3135 ADesc.MaskBitOrder := riboBitsInOrder; 3136 end 3137 else 3138 begin 3139 ADesc.Depth := Depth; 3140 ADesc.BitsPerPixel := 32; 3141 ADesc.LineEnd := rileDWordBoundary; 3142 ADesc.ByteOrder := riboLSBFirst; 3143 ADesc.MaskBitsPerPixel := 0; 3144 ADesc.MaskShift := 0; 3145 ADesc.MaskLineEnd := rileByteBoundary; 3146 ADesc.MaskBitOrder := riboBitsInOrder; 3147 3148 ADesc.RedPrec := 8; 3149 ADesc.RedShift := 0; 3150 ADesc.GreenPrec := 8; 3151 ADesc.GreenShift := 8; 3152 ADesc.BluePrec := 8; 3153 ADesc.BlueShift := 16; 3154 ADesc.AlphaPrec := 0; 3155 ADesc.AlphaShift := 24; 3156 end; 3157 3158 Result := True; 3159end; 3160 3161function TGtk2WidgetSet.RawImage_FromDrawable(out ARawImage: TRawImage; ADrawable, AAlpha: PGdkDrawable; ARect: PRect): boolean; 3162var 3163 ADesc: TRawImageDescription absolute ARawImage.Description; 3164 3165 function GetFromPixbuf(const ARect: TRect): Boolean; 3166 var 3167 Pixbuf: PGdkPixbuf; 3168 pixels: pguchar; 3169 begin 3170 // create pixbuf with alpha channel first 3171 Pixbuf := CreatePixbufFromDrawable(ADrawable, nil, True, ARect.Left, ARect.Top, 0, 0, ADesc.Width, ADesc.Height); 3172 try 3173 pixels := gdk_pixbuf_get_pixels(Pixbuf); 3174 3175 ARawImage.DataSize := PtrUInt(gdk_pixbuf_get_rowstride(Pixbuf)) * PtrUInt(ADesc.Height); 3176 ReAllocMem(ARawImage.Data, ARawImage.DataSize); 3177 if ARawImage.DataSize > 0 then 3178 System.Move(pixels^, ARawImage.Data^, ARawImage.DataSize); 3179 3180 //DbgDumpPixmap(ADrawable, 'RawImage_FromDrawable - image'); 3181 //DbgDumpBitmap(AAlpha, 'RawImage_FromDrawable - alpha'); 3182 //DbgDumpPixbuf(Pixbuf, 'RawImage_FromDrawable - pixbuf'); 3183 finally 3184 gdk_pixbuf_unref(Pixbuf); 3185 end; 3186 3187 Result := RawImage_SetAlpha(ARawImage, AAlpha, @ARect); 3188 end; 3189 3190 function GetFromImage(const ARect: TRect): Boolean; 3191 var 3192 Image: PGdkImage; 3193 begin 3194 Image := gdk_image_get(ADrawable, ARect.Left, ARect.Top, ADesc.Width, ADesc.Height); 3195 if Image = nil 3196 then begin 3197 DebugLn('WARNING: TGtk2WidgetSet.RawImage_FromDrawable: gdk_image_get failed'); 3198 exit(False); 3199 end; 3200 3201 try 3202 {$ifdef RawimageConsistencyCheks} 3203 // consistency checks 3204 if ADesc.Depth <> Image^.Depth then 3205 RaiseGDBException('ARawImage.Description.Depth<>Image^.Depth '+IntToStr(ADesc.Depth)+'<>'+IntToStr(Image^.Depth)); 3206 if ADesc.BitsPerPixel <> Image^.bits_per_pixel then 3207 RaiseGDBException('NewRawImage.Description.BitsPerPixel<>AnImage^.bpp'); 3208 {$endif} 3209 3210 ARawImage.DataSize := PtrUInt(Image^.bpl) * PtrUInt(Image^.Height); 3211 {$IFDEF VerboseRawImage} 3212 DebugLn('TGtk2WidgetSet.RawImage_FromDrawable: G Width=',dbgs(Image^.Width),' Height=',dbgs(Image^.Height), 3213 ' BitsPerPixel=',dbgs(ADesc.BitsPerPixel),' bpl=',dbgs(Image^.bpl)); 3214 {$ENDIF} 3215 3216 // copy data 3217 ADesc.Width := Image^.Width; 3218 ADesc.Height := Image^.Height; 3219 ReAllocMem(ARawImage.Data, ARawImage.DataSize); 3220 if ARawImage.DataSize > 0 3221 then begin 3222 System.Move(Image^.Mem^, ARawImage.Data^, ARawImage.DataSize); 3223 if Image^.Depth = 1 3224 then CheckGdkImageBitOrder(Image, ARawImage.Data, ARawImage.DataSize); 3225 end; 3226 3227 {$IFDEF VerboseRawImage} 3228 DebugLn('TGtk2WidgetSet.RawImage_FromDrawable: H ', 3229 ' Width=',dbgs(ADesc.Width), 3230 ' Height=',dbgs(ADesc.Height), 3231 ' Depth=',dbgs(ADesc.Depth), 3232 ' DataSize=',dbgs(ARawImage.DataSize)); 3233 {$ENDIF} 3234 finally 3235 gdk_image_destroy(Image); 3236 end; 3237 3238 Result := True; 3239 end; 3240 3241var 3242 R, R1: TRect; 3243 UseAlpha: Boolean; 3244begin 3245 Result := False; 3246 if ADrawable = nil then 3247 RaiseGDBException('TGtk2WidgetSet.RawImage_FromDrawable'); 3248 3249 ARawImage.Init; 3250 3251 UseAlpha := AAlpha <> nil; 3252 3253 // get raw image description 3254 if not RawImage_DescriptionFromDrawable(ADesc, ADrawable, UseAlpha) 3255 then begin 3256 DebugLn('WARNING: TGtk2WidgetSet.RawImage_FromDrawable: RawImage_DescriptionFromDrawable failed '); 3257 Exit; 3258 end; 3259 3260 R := Rect(0, 0, ADesc.Width, ADesc.Height); 3261 if ARect <> nil 3262 then begin 3263 // get intersection 3264 IntersectRect(R1{%H-}, ARect^, R); 3265 R := R1; 3266 ADesc.Width := R.Right - R.Left; 3267 ADesc.Height := R.Bottom - R.Top; 3268 end; 3269 3270 {$IFDEF VerboseRawImage} 3271 DebugLn('TGtk2WidgetSet.RawImage_FromDrawable get image ', 3272 dbgs(R.Left),',',dbgs(R.Top),',',dbgs(R.Right),',',dbgs(R.Bottom), 3273 ' GDKWindow=',DbgS(ADrawable)); 3274 {$ENDIF} 3275 if (ADesc.Width <= 0) or (ADesc.Height <= 0) 3276 then begin 3277 //DebugLn('WARNING: TGtk2WidgetSet.GetRawImageFromGdkWindow Intersection empty'); 3278 exit; 3279 end; 3280 3281 if UseAlpha 3282 then Result := GetFromPixbuf(R) 3283 else Result := GetFromImage(R); 3284end; 3285 3286function TGtk2WidgetSet.RawImage_FromPixbuf(out ARawImage: TRawImage; 3287 APixbuf: PGdkPixbuf; ARect: PRect): boolean; 3288var 3289 ADesc: TRawImageDescription absolute ARawImage.Description; 3290 Pixbuf: PGdkPixbuf; 3291 pixels: pguchar; 3292 Dest: PByte; 3293 R, R1: TRect; 3294 i: Integer; 3295 SourceStride, DestStride: PtrUInt; 3296begin 3297 Result := False; 3298 if APixbuf = nil then 3299 RaiseGDBException('TGtk2WidgetSet.RawImage_FromPixbuf'); 3300 3301 //DbgDumpPixbuf(APixbuf); 3302 3303 ARawImage.Init; 3304 3305 // get raw image description 3306 if not RawImage_DescriptionFromPixbuf(ADesc, APixbuf) 3307 then begin 3308 DebugLn('WARNING: TGtk2WidgetSet.RawImage_FromPixbuf: RawImage_DescriptionFromPixbuf failed '); 3309 Exit; 3310 end; 3311 3312 R := Rect(0, 0, ADesc.Width, ADesc.Height); 3313 if ARect <> nil 3314 then begin 3315 // get intersection 3316 IntersectRect(R1{%H-}, ARect^, R); 3317 R := R1; 3318 ADesc.Width := R.Right - R.Left; 3319 ADesc.Height := R.Bottom - R.Top; 3320 end; 3321 3322 if (ADesc.Width <= 0) or (ADesc.Height <= 0) 3323 then begin 3324 exit; 3325 end; 3326 3327 Pixbuf := gdk_pixbuf_new_subpixbuf(APixbuf, R.Left, R.Top, ADesc.Width, ADesc.Height); 3328 try 3329 pixels := gdk_pixbuf_get_pixels(Pixbuf); 3330 SourceStride := PtrUInt(gdk_pixbuf_get_rowstride(Pixbuf)); 3331 DestStride := ADesc.BytesPerLine; 3332 ARawImage.DataSize := DestStride * PtrUInt(ADesc.Height); 3333 ReAllocMem(ARawImage.Data, ARawImage.DataSize); 3334 if ARawImage.DataSize > 0 then 3335 if SourceStride = DestStride then 3336 System.Move(pixels^, ARawImage.Data^, ARawImage.DataSize) 3337 else begin 3338 { Extra padding bytes - need to copy by line } 3339 Dest := ARawImage.Data; 3340 for i := 0 to ADesc.Height-1 do begin 3341 System.Move(pixels^, Dest^, ADesc.BytesPerLine); 3342 Inc(pixels, SourceStride); 3343 Inc(Dest, DestStride); 3344 end; 3345 end; 3346 finally 3347 gdk_pixbuf_unref(Pixbuf); 3348 end; 3349 3350 Result := True; 3351end; 3352 3353function TGtk2WidgetSet.RawImage_SetAlpha(var ARawImage: TRawImage; AAlpha: PGdkPixmap; ARect: PRect): boolean; 3354// ARect must have the same dimension as the rawimage 3355var 3356 ADesc: TRawImageDescription absolute ARawImage.Description; 3357 3358 procedure SetAlpha_32_1(AImage: PGdkImage; AWidth, AHeight: Cardinal); 3359 var 3360 SrcPtr, DstPtr, SrcLinePtr, DstLinePtr: PByte; 3361 DstPtr32: PDWord absolute DstPtr; 3362 SrcBytesPerLine: Integer; 3363 DstBytesPerLine: Integer; 3364 SrcBit, SrcStartBit, ShiftInc: ShortInt; 3365 DstMask: DWord; 3366 DstSet: DWord; 3367 X, Y: Cardinal; 3368 {$ifdef hasx} 3369 XImage: PXimage; 3370 {$endif} 3371 begin 3372 SrcLinePtr := AImage^.mem; 3373 SrcBytesPerLine := AImage^.bpl; 3374 DstLinePtr := ARawImage.Data; 3375 DstBytesPerLine := ARawImage.Description.BytesPerLine; 3376 3377 if ADesc.ByteOrder = DefaultByteOrder 3378 then DstSet := (not ($FFFFFFFF shl ADesc.AlphaPrec)) shl ADesc.AlphaShift 3379 else DstSet := (not ($FFFFFFFF shr ADesc.AlphaPrec)) shr ADesc.AlphaShift; 3380 DstMask := not DstSet; 3381 3382 // bit order for X11 can be normal or reversed order, win32 and direct_fb 3383 // is constant in reversed order 3384 SrcStartBit := 7; 3385 ShiftInc := -1; 3386 //todo: TEST 3387 {$ifdef HasX} 3388 XImage := gdk_x11_image_get_ximage(AImage); 3389 if XImage^.bitmap_bit_order = LSBFirst 3390 then begin 3391 SrcStartBit := 0; 3392 ShiftInc := 1; 3393 end; 3394 {$endif} 3395 3396 for Y := 0 to AHeight - 1 do 3397 begin 3398 SrcBit := SrcStartBit; 3399 SrcPtr := SrcLinePtr; 3400 DstPtr := DstLinePtr; 3401 for x := 0 to AWidth - 1 do 3402 begin 3403 if SrcPtr^ and (1 shl SrcBit) = 0 3404 then DstPtr32^ := DstPtr32^ and DstMask 3405 else DstPtr32^ := (DstPtr32^ and DstMask) or DstSet; 3406 Inc(DstPtr32); 3407 SrcBit := SrcBit + ShiftInc; 3408 if SrcBit and $F8 <> 0 3409 then begin 3410 SrcBit := SrcBit and 7; 3411 Inc(SrcPtr); 3412 end; 3413 end; 3414 Inc(SrcLinePtr, SrcBytesPerLine); 3415 Inc(DstLinePtr, DstBytesPerLine); 3416 end; 3417 end; 3418 3419 procedure SetAlpha_32_8(AImage: PGdkImage; AWidth, AHeight: Cardinal); 3420 var 3421 SrcPtr, DstPtr, SrcLinePtr, DstLinePtr: PByte; 3422 DstPtr32: PDWord absolute DstPtr; 3423 SrcBytesPerLine: Integer; 3424 DstBytesPerLine: Integer; 3425 DstMask: DWord; 3426 DstShift: Byte; 3427 X, Y: Cardinal; 3428 begin 3429 SrcLinePtr := AImage^.mem; 3430 SrcBytesPerLine := AImage^.bpl; 3431 DstLinePtr := ARawImage.Data; 3432 DstBytesPerLine := ARawImage.Description.BytesPerLine; 3433 3434 DstMask := not (((1 shl ADesc.AlphaPrec) - 1) shl ADesc.AlphaShift); 3435 DstShift := ADesc.AlphaShift; 3436 3437 for Y := 0 to AHeight - 1 do 3438 begin 3439 SrcPtr := SrcLinePtr; 3440 DstPtr := DstLinePtr; 3441 for x := 0 to AWidth - 1 do 3442 begin 3443 DstPtr32^ := (DstPtr32^ and DstMask) or (Cardinal(SrcPtr^) shl DstShift); 3444 Inc(DstPtr32); 3445 Inc(SrcPtr); 3446 end; 3447 Inc(SrcLinePtr, SrcBytesPerLine); 3448 Inc(DstLinePtr, DstBytesPerLine); 3449 end; 3450 end; 3451 3452var 3453 Width, Height, H, W, D: cardinal; 3454 Image: PGdkImage; 3455 R: TRect; 3456begin 3457 Result := False; 3458 3459 if ARawImage.Data = nil 3460 then begin 3461 {$ifdef RawimageConsistencyChecks} 3462 RaiseGDBException('TGtk2WidgetSet.RawImage_SetAlpha RawImage.Data = nil'); 3463 {$else} 3464 DebugLn('WARNING: TGtk2WidgetSet.RawImage_SetAlpha RawImage.Data = nil'); 3465 {$endif} 3466 Exit; 3467 end; 3468 3469 if ADesc.AlphaPrec = 0 3470 then begin 3471 {$ifdef RawimageConsistencyChecks} 3472 RaiseGDBException('TGtk2WidgetSet.RawImage_SetAlpha RawImage.Description.AlphaPrec = 0'); 3473 {$else} 3474 DebugLn('WARNING: TGtk2WidgetSet.RawImage_SetAlpha No alpha channel defined'); 3475 {$endif} 3476 Exit; 3477 end; 3478 3479 if AAlpha = nil 3480 then begin 3481 DebugLn('WARNING: TGtk2WidgetSet.RawImage_SetAlpha Alpha = nil'); 3482 Exit; 3483 end; 3484 3485 gdk_drawable_get_size(AAlpha, @W, @H); 3486 D := gdk_drawable_get_depth(AAlpha); 3487 if (D <> 1) and (D <> 8) 3488 then begin 3489 DebugLn('WARNING: TGtk2WidgetSet.RawImage_SetAlpha: Only a Depth of 1 or 8 is supported. (depth=%d)', [D]); 3490 Exit; 3491 end; 3492 3493 if ARect = nil 3494 then R := Rect(0, 0, ADesc.Width, ADesc.Height) 3495 else R := ARect^; 3496 3497 if (longint(W) < R.Right) or (longint(H) < R.Bottom) 3498 then begin 3499 DebugLn('WARNING: TGtk2WidgetSet.RawImage_SetAlpha: Rect(%d,%d %d,%d) outside alpha pixmap(0,0 %d,%d)', [R.Left, R.Top, R.Right, R.Bottom, W, H]); 3500 Exit; 3501 end; 3502 3503 Width := R.Right - R.Left; 3504 Height := R.Bottom - R.Top; 3505 3506 if Width <> ADesc.Width 3507 then begin 3508 {$ifdef RawimageConsistencyChecks} 3509 RaiseGDBException('TGtk2WidgetSet.RawImage_SetAlpha: Width <> RawImage.Description.Width'); 3510 {$else} 3511 DebugLn('WARNING: TGtk2WidgetSet.RawImage_SetAlpha: Width(=%d) <> RawImage.Description.Width(=%d)', [Width, ADesc.Width]); 3512 {$endif} 3513 Exit; 3514 end; 3515 3516 if Height <> ADesc.Height 3517 then begin 3518 {$ifdef RawimageConsistencyChecks} 3519 RaiseGDBException('TGtk2WidgetSet.RawImage_SetAlpha: Height <> RawImage.Description.Height'); 3520 {$else} 3521 DebugLn('WARNING: TGtk2WidgetSet.RawImage_SetAlpha: Height(=%d) <> RawImage.Description.Height(=%d)', [Height, ADesc.Height]); 3522 {$endif} 3523 Exit; 3524 end; 3525 3526 // get gdk_image from gdkbitmap 3527 Image := gdk_image_get(AAlpha, R.Left, R.Top, Width, Height); 3528 if Image = nil 3529 then begin 3530 DebugLn('WARNING: TGtk2WidgetSet.RawImage_SetAlpha: gdk_image_get failed'); 3531 Exit; 3532 end; 3533 3534 try 3535 case ADesc.BitsPerPixel of 3536 32: begin 3537 if D = 1 3538 then SetAlpha_32_1(Image, Width, Height) 3539 else SetAlpha_32_8(Image, Width, Height); 3540 end; 3541 else 3542 DebugLn('WARNING: TGtk2WidgetSet.RawImage_SetAlpha: RawImage.Description.BitsPerPixel=%d not supported', [ADesc.BitsPerPixel]); 3543 Exit; 3544 end; 3545 3546 finally 3547 gdk_image_destroy(Image); 3548 end; 3549 3550 Result:=true; 3551end; 3552 3553function TGtk2WidgetSet.RawImage_AddMask(var ARawImage: TRawImage; AMask: PGdkBitmap; ARect: PRect): boolean; 3554// ARect must have the same dimension as the rawimage 3555 3556var 3557 ADesc: TRawImageDescription absolute ARawImage.Description; 3558 Left, Top, Width, Height, H: longint; 3559 Image: PGdkImage; 3560 BytesPerLine: Integer; 3561 SrcPtr, DstPtr: PByte; 3562begin 3563 Result := False; 3564 3565 if ARawImage.Mask <> nil 3566 then begin 3567 {$ifdef RawimageConsistencyChecks} 3568 RaiseGDBException('TGtk2WidgetSet.RawImage_AddMask RawImage.Mask <> nil'); 3569 {$else} 3570 DebugLn('WARNING: TGtk2WidgetSet.RawImage_AddMask RawImage.Mask <> nil'); 3571 {$endif} 3572 Exit; 3573 end; 3574 3575 if AMask = nil 3576 then begin 3577 DebugLn('WARNING: TGtk2WidgetSet.RawImage_AddMask AMask = nil'); 3578 Exit; 3579 end; 3580 3581 if ARect = nil 3582 then begin 3583 Left := 0; 3584 Top := 0; 3585 Width := ADesc.Width; 3586 Height := ADesc.Height; 3587 end 3588 else begin 3589 Left := ARect^.Left; 3590 Top := ARect^.Top; 3591 Width := Min(ADesc.Width, ARect^.Right - ARect^.Left); 3592 Height := Min(ADesc.Height, ARect^.Bottom - ARect^.Top); 3593 end; 3594 3595 if cardinal(Width) <> ADesc.Width 3596 then begin 3597 {$ifdef RawimageConsistencyChecks} 3598 RaiseGDBException('TGtk2WidgetSet.RawImage_AddMask: Width <> RawImage.Description.Width'); 3599 {$else} 3600 DebugLn('WARNING: TGtk2WidgetSet.RawImage_AddMask: Width(=%d) <> RawImage.Description.Width(=%d)', [Width, ADesc.Width]); 3601 {$endif} 3602 Exit; 3603 end; 3604 3605 if cardinal(Height) <> ADesc.Height 3606 then begin 3607 {$ifdef RawimageConsistencyChecks} 3608 RaiseGDBException('TGtk2WidgetSet.RawImage_AddMask: Height <> RawImage.Description.Height'); 3609 {$else} 3610 DebugLn('WARNING: TGtk2WidgetSet.RawImage_AddMask: Height(=%d) <> RawImage.Description.Height(=%d)', [Height, ADesc.Height]); 3611 {$endif} 3612 Exit; 3613 end; 3614 3615 // get gdk_image from gdkbitmap 3616 Image := gdk_image_get(AMask, Left, Top, Width, Height); 3617 if Image = nil 3618 then begin 3619 DebugLn('WARNING: TGtk2WidgetSet.RawImage_AddMask: gdk_image_get failed'); 3620 Exit; 3621 end; 3622 3623 try 3624 {$IFDEF VerboseRawImage} 3625 DebugLn('TGtk2WidgetSet.RawImage_AddMask: A BytesPerLine=',dbgs(Image^.bpl), 3626 ' theType=',dbgs(ord(Image^._type)), 3627 ' depth=',dbgs(Image^.depth),' AnImage^.bpp=',dbgs(Image^.bpp)); 3628 DebugLn('RawImage=', ARawImage.Description.AsString); 3629 {$ENDIF} 3630 3631 // See also GetWindowRawImageDescription 3632 ADesc.MaskBitsPerPixel := GetGdkImageBitsPerPixel(Image); 3633 ADesc.MaskLineEnd := rileByteBoundary;// gdk_bitmap_create_from_data expects rileByteBoundary 3634 BytesPerLine := GetBytesPerLine(ADesc.Width, ADesc.MaskBitsPerPixel, ADesc.MaskLineEnd); 3635 ARawImage.MaskSize := PtrUInt(BytesPerLine) * PtrUInt(Height); 3636 3637 ReAllocMem(ARawImage.Mask, ARawImage.MaskSize); 3638 if ARawImage.MaskSize > 0 3639 then begin 3640 // copy data 3641 if BytesPerLine = Image^.bpl 3642 then begin 3643 // we can copy all in one go 3644 System.Move(Image^.Mem^, ARawImage.Mask^, ARawImage.MaskSize); 3645 end 3646 else begin 3647 // copy line by line 3648 SrcPtr := Image^.Mem; 3649 DstPtr := ARawImage.Mask; 3650 H := Height; 3651 while H > 0 do 3652 begin 3653 System.Move(SrcPtr^, DstPtr^, BytesPerLine); 3654 Inc(SrcPtr, Image^.bpl); 3655 Inc(DstPtr, BytesPerLine); 3656 Dec(H); 3657 end; 3658 end; 3659 CheckGdkImageBitOrder(Image, ARawImage.Mask, ARawImage.MaskSize); 3660 end; 3661 3662 3663 {$IFDEF VerboseRawImage} 3664 {DebugLn('TGtk2WidgetSet.GetRawImageMaskFromGdkBitmap H ', 3665 ' Width=',dbgs(ARawImage.Description.Width), 3666 ' Height=',dbgs(ARawImage.Description.Height), 3667 ' AlphaBitsPerPixel=',dbgs(ARawImage.Description.AlphaBitsPerPixel), 3668 ' MaskSize=',dbgs(ARawImage.MaskSize));} 3669 {$ENDIF} 3670 finally 3671 gdk_image_destroy(Image); 3672 end; 3673 3674 Result:=true; 3675end; 3676 3677{------------------------------------------------------------------------------ 3678 Function: TGtk2WidgetSet.StretchCopyArea 3679 Params: DestDC: The destination devicecontext 3680 X, Y: The left/top corner of the destination rectangle 3681 Width, Height: The size of the destination rectangle 3682 SrcDC: The source devicecontext 3683 XSrc, YSrc: The left/top corner of the source rectangle 3684 SrcWidth, SrcHeight: The size of the source rectangle 3685 Mask: An optional mask 3686 XMask, YMask: Only used if Mask<>nil 3687 Rop: The raster operation to be performed 3688 Returns: True if succesful 3689 3690 The StretchBlt function copies a bitmap from a source rectangle into a 3691 destination rectangle using the specified raster operation. If needed, it 3692 resizes the bitmap to fit the dimensions of the destination rectangle. 3693 Sizing is done according to the stretching mode currently set in the 3694 destination device context. 3695 If SrcDC contains a mask the pixmap will be copied with this transparency. 3696 3697 ToDo: 3698 Mirroring 3699 Extended NonDrawable support (Image, Bitmap, etc) 3700 Scale mask 3701 ------------------------------------------------------------------------------} 3702function TGtk2WidgetSet.StretchCopyArea(DestDC: HDC; X, Y, Width, Height: Integer; 3703 SrcDC: HDC; XSrc, YSrc, SrcWidth, SrcHeight: Integer; 3704 Mask: HBITMAP; XMask, YMask: Integer; 3705 Rop: Cardinal): Boolean; 3706var 3707 SrcDevContext: TGtkDeviceContext absolute SrcDC; 3708 DstDevContext: TGtkDeviceContext absolute DestDC; 3709 TempPixmap: PGdkPixmap; 3710 TempMaskBitmap: PGdkBitmap; 3711 SizeChange, ROpIsSpecial: Boolean; 3712 FlipHorz, FlipVert: Boolean; 3713 3714 function ScaleAndROP(DestGC: PGDKGC; 3715 Src: PGDKDrawable; SrcPixmap: PGdkDrawable; SrcMaskBitmap: PGdkBitmap): Boolean; 3716 var 3717 Depth: Integer; 3718 ScaleMethod: TGdkInterpType; 3719 ShrinkWidth, ShrinkHeight: Boolean; 3720 GC: PGDKGC; 3721 begin 3722 {$IFDEF VerboseStretchCopyArea} 3723 3724 DebugLn('ScaleAndROP START DestGC=',DbgS(DestGC), 3725 ' SrcPixmap=',DbgS(SrcPixmap), 3726 ' SrcMaskPixmap=',DbgS(SrcMaskBitmap)); 3727 {$ENDIF} 3728 Result := False; 3729 3730 if DestGC = nil 3731 then begin 3732 DebugLn('WARNING: [TGtk2WidgetSet.StretchCopyArea] Uninitialized DestGC'); 3733 exit; 3734 end; 3735 3736 // create a temporary graphic context for the scale and raster operations 3737 // copy the destination GC values into the temporary GC 3738 GC := gdk_gc_new(DstDevContext.Drawable); 3739 gdk_gc_copy(GC, DestGC); 3740 3741 // clear any previous clipping in the temporary GC 3742 gdk_gc_set_clip_region(GC, nil); 3743 gdk_gc_set_clip_rectangle(GC, nil); 3744 3745 if SizeChange 3746 then begin 3747 {$IFDEF VerboseStretchCopyArea} 3748 Depth:=gdk_visual_get_system^.Depth; 3749 DebugLn('ScaleAndROP Scaling buffer: '+dbgs(Width),' x '+dbgs(Height),' x '+dbgs(Depth)); 3750 {$ENDIF} 3751 3752 // calculate ScaleMethod 3753 {$IFDEF VerboseGtkToDos}{$note use SetStretchBltMode(dc, mode) here}{$ENDIF} 3754 //GDKPixbuf Scaling is not done in the same way as Windows 3755 //but by rights ScaleMethod should really be chosen based 3756 //on the destination device's internal flag 3757 {GDK_INTERP_NEAREST,GDK_INTERP_TILES, 3758 GDK_INTERP_BILINEAR,GDK_INTERP_HYPER);} 3759 3760 ShrinkWidth := Width < SrcWidth; 3761 ShrinkHeight := Height < SrcHeight; 3762 if ShrinkWidth and ShrinkHeight 3763 then ScaleMethod := GDK_INTERP_TILES 3764 else 3765 if ShrinkWidth or ShrinkHeight 3766 then ScaleMethod := GDK_INTERP_BILINEAR//GDK_INTERP_HYPER 3767 else begin 3768 if DstDevContext.Antialiasing then ScaleMethod := GDK_INTERP_BILINEAR 3769 else ScaleMethod := GDK_INTERP_NEAREST; 3770 end; 3771 3772 // Scale the src part to a temporary pixmap with the size of the 3773 // destination rectangle 3774 3775 Result := ScalePixmapAndMask(GC, ScaleMethod, 3776 SrcPixmap, XSrc, YSrc, SrcWidth, SrcHeight, 3777 nil, SrcMaskBitmap, 3778 Width, Height, FlipHorz, FlipVert, TempPixmap, TempMaskBitmap); 3779 if not Result 3780 then DebugLn('WARNING: ScaleAndROP ScalePixmap for pixmap failed'); 3781 end 3782 else begin 3783 if ROpIsSpecial 3784 then begin 3785 // no scaling, but special ROp 3786 3787 Depth:=gdk_visual_get_system^.Depth; 3788 {$IFDEF VerboseStretchCopyArea} 3789 DebugLn('ScaleAndROP Creating rop buffer: '+dbgs(Width),' x '+dbgs(Height),' x '+dbgs(Depth)); 3790 {$ENDIF} 3791 TempPixmap := gdk_pixmap_new(nil,SrcWidth,SrcHeight,Depth); 3792 gdk_window_copy_area(TempPixmap, GC, 0, 0, 3793 Src, XSrc, YSrc, SrcWidth, SrcHeight); 3794 end; 3795 Result := True; 3796 end; 3797 3798 // set raster operation in the destination GC 3799 if Result 3800 then SetGCRasterOperation(DestGC, ROP); 3801 3802 gdk_gc_unref(GC); 3803 end; 3804 3805 procedure ROPFillBuffer(DC : hDC); 3806 var 3807 OldCurrentBrush: PGdiObject; 3808 Brush : hBrush; 3809 begin 3810 if TempPixmap = nil then exit; 3811 3812 if not ((ROp=WHITENESS) or (ROp=BLACKNESS) or (ROp=DSTINVERT)) then Exit; 3813 3814 {$IFDEF VerboseStretchCopyArea} 3815 DebugLn('ROPFillBuffer ROp='+dbgs(ROp)); 3816 {$ENDIF} 3817 with TGtkDeviceContext(DC) do 3818 begin 3819 // Temporarily hold the old brush to 3820 // replace it with the given brush 3821 OldCurrentBrush := CurrentBrush; 3822 if ROP = WHITENESS 3823 then 3824 Brush := GetStockObject(WHITE_BRUSH) 3825 else 3826 Brush := GetStockObject(BLACK_BRUSH); 3827 CurrentBrush := {%H-}PGdiObject(Brush); 3828 SelectedColors := dcscBrush; 3829 3830 if not IsNullBrush 3831 then begin 3832 gdk_draw_rectangle(TempPixmap, GC, 1, 0, 0, Width, Height); 3833 end; 3834 // Restore current brush 3835 CurrentBrush := OldCurrentBrush; 3836 end; 3837 end; 3838 3839 function SrcDevBitmapToDrawable: Boolean; 3840 var 3841 SrcDrawable: PGdkDrawable; 3842 MskBitmap: PGdkBitmap; 3843 ClipMask: PGdkBitmap; 3844 SrcGDIBitmap: PGdiObject; 3845 B: Boolean; 3846 TmpPixbuf, TmpPixbuf2: PGdkPixbuf; 3847 begin 3848 Result:=true; 3849 3850 // special case for copying from bitmaps with alpha channel 3851 if (ROP=SRCCOPY) and Assigned(SrcDevContext.Pixbuf) then 3852 begin 3853 if SizeChange then 3854 begin 3855 // there isn't a "stretch draw" function for pixbufs so we need to make 3856 // a temporary scaled copy if we have a different size 3857 if (Width <> SrcWidth) or (Height <> SrcHeight) then begin 3858 TmpPixbuf:=gdk_pixbuf_scale_simple(SrcDevContext.Pixbuf, Width, Height, GDK_INTERP_HYPER); 3859 if not Assigned(TmpPixbuf) then 3860 begin 3861 DebugLn('SrcDevBitmapToDrawable: failed to create temporary pixbuf for scaled draw'); 3862 exit; 3863 end; 3864 end else begin 3865 // same size but we have flips, just increase the refcount of the 3866 // original pixbuf 3867 TmpPixbuf:=SrcDevContext.Pixbuf; 3868 gdk_pixbuf_ref(TmpPixbuf); 3869 end; 3870 // flip the pixmap, if necessary 3871 if FlipHorz then begin 3872 TmpPixbuf2:=gdk_pixbuf_flip(TmpPixbuf, True); 3873 gdk_pixbuf_unref(TmpPixbuf); 3874 TmpPixbuf:=TmpPixbuf2; 3875 end; 3876 if FlipVert then begin 3877 TmpPixbuf2:=gdk_pixbuf_flip(TmpPixbuf, False); 3878 gdk_pixbuf_unref(TmpPixbuf); 3879 TmpPixbuf:=TmpPixbuf2; 3880 end; 3881 // draw and release the final pixbuf 3882 gdk_draw_pixbuf(DstDevContext.Drawable, DstDevContext.GC, TmpPixbuf, XSrc, YSrc, X, Y, Width, Height, GDK_RGB_DITHER_MAX, 0, 0); 3883 gdk_pixbuf_unref(TmpPixbuf); 3884 end else 3885 begin 3886 gdk_draw_pixbuf(DstDevContext.Drawable, DstDevContext.GC, SrcDevContext.Pixbuf, XSrc, YSrc, X, Y, Width, Height, GDK_RGB_DITHER_MAX, 0, 0); 3887 end; 3888 Exit; 3889 end; 3890 3891 {$IFDEF VerboseStretchCopyArea} 3892 DebugLn('SrcDevBitmapToDrawable Start'); 3893 {$ENDIF} 3894 B := False; 3895 SrcGDIBitmap := SrcDevContext.CurrentBitmap; 3896 if SrcGDIBitmap = nil then 3897 begin 3898 SrcDrawable := SrcDevContext.Drawable; 3899 MskBitmap := nil; 3900 if SrcDrawable = nil then 3901 begin 3902 DebugLn('SrcDevBitmapToDrawable NOTE: SrcDevContext.CurrentBitmap=nil, SrcDevContext.Drawable = nil'); 3903 exit; 3904 end; 3905 end else 3906 begin 3907 SrcDrawable := SrcGDIBitmap^.GDIPixmapObject.Image; 3908 MskBitmap := CreateGdkMaskBitmap(HBITMAP({%H-}PtrUInt(SrcGDIBitmap)), Mask); 3909 end; 3910 3911 {$IFDEF VerboseStretchCopyArea} 3912 DebugLn('SrcDevBitmapToDrawable SrcPixmap=[',GetWindowDebugReport(SrcDrawable),']', 3913 ' MaskPixmap=[',GetWindowDebugReport(MskBitmap),']'); 3914 {$ENDIF} 3915 3916 if (MskBitmap = nil) and (not SizeChange) and (ROP=SRCCOPY) then 3917 begin 3918 // simply copy the area 3919 {$IFDEF VerboseStretchCopyArea} 3920 DebugLn('SrcDevBitmapToDrawable Simple copy'); 3921 {$ENDIF} 3922 gdk_gc_set_function(DstDevContext.GC, GDK_COPY); 3923 gdk_window_copy_area(DstDevContext.Drawable, DstDevContext.GC, X, Y, 3924 SrcDrawable, XSrc, YSrc, Width, Height); 3925 gdk_gc_set_function(DstDevContext.GC, DstDevContext.GetFunction); 3926 Exit; 3927 end; 3928 3929 3930 // perform raster operation and scaling into Scale and fGC 3931 DstDevContext.SelectedColors := dcscCustom; 3932 if not ScaleAndROP(DstDevContext.GC, SrcDevContext.Drawable, SrcDrawable, MskBitmap) then 3933 begin 3934 if MskBitmap <> nil then 3935 gdk_bitmap_unref(MskBitmap); 3936 DebugLn('WARNING: SrcDevBitmapToDrawable: ScaleAndROP failed'); 3937 Exit; 3938 end; 3939 3940 {$IFDEF VerboseStretchCopyArea} 3941 DebugLn('SrcDevBitmapToDrawable TempPixmap=',DbgS(TempPixmap),' TempMaskPixmap=',DbgS(TempMaskBitmap)); 3942 {$ENDIF} 3943 if TempPixmap <> nil then 3944 begin 3945 SrcDrawable := TempPixmap; 3946 XSrc := 0; 3947 YSrc := 0; 3948 SrcWidth := Width; 3949 SrcHeight := Height; 3950 end; 3951 if TempMaskBitmap <> nil then 3952 begin 3953 if MskBitmap <> nil then 3954 begin 3955 gdk_bitmap_unref(MskBitmap); 3956 B := True; 3957 end; 3958 MskBitmap := TempMaskBitmap; 3959 XMask := 0; 3960 YMask := 0; 3961 end; 3962 3963 case ROP of 3964 WHITENESS, BLACKNESS : 3965 ROPFillBuffer(DestDC); 3966 end; 3967 3968 {$IFDEF VerboseStretchCopyArea} 3969 DebugLn('SrcDevBitmapToDrawable ', 3970 ' SrcDrawable=',DbgS(SrcDrawable), 3971 ' XSrc='+dbgs(XSrc),' YSrc='+dbgs(YSrc),' SrcWidth='+dbgs(SrcWidth),' SrcHeight='+dbgs(SrcHeight), 3972 ' MaskPixmap=',DbgS(MskBitmap), 3973 ' XMask='+dbgs(XMask),' YMask='+dbgs(YMask), 3974 ''); 3975 {$ENDIF} 3976 3977 // set clipping mask for transparency 3978 MergeClipping(DstDevContext, DstDevContext.GC, X, Y, Width, Height, 3979 MskBitmap, XMask, YMask, ClipMask); 3980 3981 // draw image 3982 {$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF} 3983 gdk_window_copy_area(DstDevContext.Drawable, DstDevContext.GC, X, Y, 3984 SrcDrawable, XSrc, YSrc, SrcWidth, SrcHeight); 3985 {$IFDEF DebugGDK}EndGDKErrorTrap;{$ENDIF} 3986 3987 // unset clipping mask for transparency 3988 DstDevContext.ResetGCClipping; 3989 if ClipMask <> nil then 3990 gdk_bitmap_unref(ClipMask); 3991 3992 if not B and (MskBitmap <> nil) then 3993 gdk_bitmap_unref(MskBitmap); 3994 3995 // restore raster operation to SRCCOPY 3996 gdk_gc_set_function(DstDevContext.GC, GDK_Copy); 3997 3998 Result:=True; 3999 end; 4000 4001 function DrawableToDrawable: Boolean; 4002 begin 4003 {$IFDEF VerboseStretchCopyArea} 4004 DebugLn('DrawableToDrawable Start'); 4005 {$ENDIF} 4006 Result:=SrcDevBitmapToDrawable; 4007 end; 4008 4009 function PixmapToDrawable: Boolean; 4010 begin 4011 {$IFDEF VerboseStretchCopyArea} 4012 DebugLn('PixmapToDrawable Start'); 4013 {$ENDIF} 4014 Result:=SrcDevBitmapToDrawable; 4015 end; 4016 4017 function PixmapToBitmap: Boolean; 4018 begin 4019 DebugLn('WARNING: [TGtk2WidgetSet.StretchCopyArea] PixmapToBitmap unimplemented!'); 4020 Result:=false; 4021 end; 4022 4023 function BitmapToPixmap: Boolean; 4024 begin 4025 DebugLn('WARNING: [TGtk2WidgetSet.StretchCopyArea] BitmapToPixmap unimplemented!'); 4026 Result:=false; 4027 end; 4028 4029 function Unsupported: Boolean; 4030 begin 4031 DebugLn('WARNING: [TGtk2WidgetSet.StretchCopyArea] Destination and/or Source unsupported!!'); 4032 Result:=false; 4033 end; 4034 4035 //---------- 4036 function NoDrawableToNoDrawable: Boolean; 4037 begin 4038 Result := Unsupported; 4039 if SrcDevContext.CurrentBitmap = nil then Exit; 4040 if DstDevContext.CurrentBitmap = nil then Exit; 4041 4042 case SrcDevContext.CurrentBitmap^.GDIBitmapType of 4043 gbBitmap: 4044 case DstDevContext.CurrentBitmap^.GDIBitmapType of 4045 gbBitmap: Result:=DrawableToDrawable; 4046 gbPixmap: Result:=BitmapToPixmap; 4047 end; 4048 gbPixmap: 4049 case DstDevContext.CurrentBitmap^.GDIBitmapType of 4050 gbBitmap: Result:=PixmapToBitmap; 4051 gbPixmap: Result:=DrawableToDrawable; 4052 end; 4053 end; 4054 end; 4055 4056 function NoDrawableToDrawable: Boolean; 4057 begin 4058 Result := Unsupported; 4059 if SrcDevContext.CurrentBitmap = nil then Exit; 4060 4061 case SrcDevContext.CurrentBitmap^.GDIBitmapType of 4062 gbBitmap: Result:=PixmapToDrawable; 4063 gbPixmap: Result:=PixmapToDrawable; 4064 end; 4065 end; 4066 4067 function DrawableToNoDrawable: Boolean; 4068 begin 4069 Result := Unsupported; 4070 if DstDevContext.CurrentBitmap = nil then Exit; 4071 4072 case DstDevContext.CurrentBitmap^.GDIBitmapType of 4073 gbBitmap: Result:=Unsupported; 4074 gbPixmap: Result:=Unsupported; 4075 end; 4076 end; 4077 4078 procedure RaiseSrcDrawableNil; 4079 begin 4080 DebugLn(['RaiseSrcDrawableNil ',GetWidgetDebugReport(SrcDevContext.Widget)]); 4081 RaiseGDBException(Format('TGtk2WidgetSet.StretchCopyArea SrcDC=%p Drawable=nil', [Pointer(SrcDevContext)])); 4082 end; 4083 4084 procedure RaiseDestDrawableNil; 4085 begin 4086 RaiseGDBException(Format('TGtk2WidgetSet.StretchCopyArea DestDC=%p Drawable=nil', [Pointer(DstDevContext)])); 4087 end; 4088 4089var 4090 NewSrcWidth: Integer; 4091 NewSrcHeight: Integer; 4092 NewWidth: Integer; 4093 NewHeight: Integer; 4094 SrcDCOrigin: TPoint; 4095 DstDCOrigin: TPoint; 4096 SrcWholeWidth, SrcWholeHeight: integer; 4097 DstWholeWidth, DstWholeHeight: integer; 4098begin 4099 Result := IsValidDC(DestDC) and IsValidDC(SrcDC); 4100 {$IFDEF VerboseStretchCopyArea} 4101 DebugLn('StretchCopyArea Start '+dbgs(Result)); 4102 {$ENDIF} 4103 if not Result then Exit; 4104 4105 if SrcDevContext.HasTransf then 4106 begin 4107 // TK: later with shear and rotation error here? 4108 SrcDevContext.TransfPoint(XSrc, YSrc); 4109 SrcDevContext.TransfExtent(SrcWidth, SrcHeight); 4110 end; 4111 SrcDCOrigin := SrcDevContext.Offset; 4112 Inc(XSrc, SrcDCOrigin.X); 4113 Inc(YSrc, SrcDCOrigin.Y); 4114 4115 if DstDevContext.HasTransf then 4116 begin 4117 // TK: later with shear and rotation error here? 4118 DstDevContext.TransfPoint(X, Y); 4119 DstDevContext.TransfExtent(Width, Height); 4120 end; 4121 DstDCOrigin := DstDevContext.Offset; 4122 Inc(X, DstDCOrigin.X); 4123 Inc(Y, DstDCOrigin.Y); 4124 4125 FlipHorz := Width < 0; 4126 if FlipHorz then 4127 begin 4128 Width := -Width; 4129 X := X - Width; 4130 end; 4131 4132 FlipVert := Height < 0; 4133 if FlipVert then 4134 begin 4135 Height := -Height; 4136 Y := Y - Height; 4137 end; 4138 4139 if (Width = 0) or (Height = 0) then exit; 4140 if (SrcWidth = 0) or (SrcHeight = 0) then exit; 4141 4142 SizeChange := (Width <> SrcWidth) or (Height <> SrcHeight) or FlipVert or FlipHorz; 4143 ROpIsSpecial := (Rop <> SRCCOPY); 4144 4145 if SrcDevContext.Drawable = nil then RaiseSrcDrawableNil; 4146 gdk_window_get_size(PGdkWindow(SrcDevContext.Drawable), @SrcWholeWidth, @SrcWholeHeight); 4147 4148 4149 if DstDevContext.Drawable = nil then RaiseDestDrawableNil; 4150 gdk_window_get_size(PGdkWindow(DstDevContext.Drawable), @DstWholeWidth, @DstWholeHeight); 4151 4152 {$IFDEF VerboseStretchCopyArea} 4153 DebugLn('TGtk2WidgetSet.StretchCopyArea BEFORE CLIPPING X='+dbgs(X),' Y='+dbgs(Y),' Width='+dbgs(Width),' Height='+dbgs(Height), 4154 ' XSrc='+dbgs(XSrc)+' YSrc='+dbgs(YSrc)+' SrcWidth='+dbgs(SrcWidth)+' SrcHeight='+dbgs(SrcHeight), 4155 ' SrcDrawable=',DbgS(TGtkDeviceContext(SrcDC).Drawable), 4156 ' SrcOrigin='+dbgs(SrcDCOrigin), 4157 ' DestDrawable='+DbgS(TGtkDeviceContext(DestDC).Drawable), 4158 ' DestOrigin='+dbgs(DstDCOrigin), 4159 ' Mask='+DbgS(Mask)+' XMask='+dbgs(XMask)+' YMask='+dbgs(YMask), 4160 ' SizeChange='+dbgs(SizeChange)+' ROpIsSpecial='+dbgs(ROpIsSpecial), 4161 ' DestWhole='+dbgs(DstWholeWidth)+','+dbgs(DstWholeHeight), 4162 ' SrcWhole='+dbgs(SrcWholeWidth)+','+dbgs(SrcWholeHeight), 4163 ''); 4164 {$ENDIF} 4165 {$IFDEF VerboseGtkToDos}{$note use intersectrect here}{$ENDIF} 4166 if X >= DstWholeWidth then Exit; 4167 if Y >= DstWholeHeight then exit; 4168 if X + Width <= 0 then exit; 4169 if Y + Height <=0 then exit; 4170 if XSrc >= SrcWholeWidth then Exit; 4171 if YSrc >= SrcWholeHeight then exit; 4172 if XSrc + SrcWidth <= 0 then exit; 4173 if YSrc + SrcHeight <=0 then exit; 4174 4175 // gdk does not allow copying areas, party laying out of bounds 4176 // -> clip 4177 4178 // clip src to the left 4179 if (XSrc<0) then begin 4180 NewSrcWidth:=SrcWidth+XSrc; 4181 NewWidth:=((Width*NewSrcWidth) div SrcWidth); 4182 {$IFDEF VerboseStretchCopyArea} 4183 DebugLn('StretchCopyArea Cliping Src to left NewSrcWidth='+dbgs(NewSrcWidth),' NewWidth='+dbgs(NewWidth)); 4184 {$ENDIF} 4185 if NewWidth = 0 then exit; 4186 inc(X, Width-NewWidth); 4187 if X >= DstWholeWidth then exit; 4188 XSrc:=0; 4189 SrcWidth := NewSrcWidth; 4190 end; 4191 4192 // clip src to the top 4193 if (YSrc<0) then begin 4194 NewSrcHeight:=SrcHeight+YSrc; 4195 NewHeight:=((Height*NewSrcHeight) div SrcHeight); 4196 {$IFDEF VerboseStretchCopyArea} 4197 DebugLn('StretchCopyArea Cliping Src to top NewSrcHeight='+dbgs(NewSrcHeight),' NewHeight='+dbgs(NewHeight)); 4198 {$ENDIF} 4199 if NewHeight = 0 then exit; 4200 inc(Y, Height - NewHeight); 4201 if Y >= DstWholeHeight then exit; 4202 YSrc:=0; 4203 SrcHeight := NewSrcHeight; 4204 end; 4205 4206 // clip src to the right 4207 if (XSrc+SrcWidth>SrcWholeWidth) then begin 4208 NewSrcWidth:=SrcWholeWidth-XSrc; 4209 Width:=((Width*NewSrcWidth) div SrcWidth); 4210 {$IFDEF VerboseStretchCopyArea} 4211 DebugLn('StretchCopyArea Cliping Src to right NewSrcWidth='+dbgs(NewSrcWidth),' NewWidth='+dbgs(Width)); 4212 {$ENDIF} 4213 if (Width=0) then exit; 4214 if (X+Width<=0) then exit; 4215 SrcWidth:=NewSrcWidth; 4216 end; 4217 4218 // clip src to the bottom 4219 if (YSrc+SrcHeight>SrcWholeHeight) then begin 4220 NewSrcHeight:=SrcWholeHeight-YSrc; 4221 Height:=((Height*NewSrcHeight) div SrcHeight); 4222 {$IFDEF VerboseStretchCopyArea} 4223 DebugLn('StretchCopyArea Cliping Src to bottom NewSrcHeight='+dbgs(NewSrcHeight),' NewHeight='+dbgs(Height)); 4224 {$ENDIF} 4225 if (Height=0) then exit; 4226 if (Y+Height<=0) then exit; 4227 SrcHeight:=NewSrcHeight; 4228 end; 4229 4230 if Mask = 0 4231 then begin 4232 XMask := XSrc; 4233 YMask := YSrc; 4234 end; 4235 4236 // mark temporary scaling/rop buffers as uninitialized 4237 TempPixmap := nil; 4238 TempMaskBitmap := nil; 4239 4240 {$IFDEF VerboseStretchCopyArea} 4241 write('TGtk2WidgetSet.StretchCopyArea AFTER CLIPPING X='+dbgs(X)+' Y='+dbgs(Y)+' Width='+dbgs(Width)+' Height='+dbgs(Height), 4242 ' XSrc='+dbgs(XSrc),' YSrc='+dbgs(YSrc)+' SrcWidth='+dbgs(SrcWidth)+' SrcHeight='+dbgs(SrcHeight), 4243 ' SrcDrawable='+DbgS(SrcDevContext.Drawable), 4244 ' DestDrawable='+DbgS(DstDevContext.Drawable), 4245 ' Mask='+DbgS(Mask)+' XMask='+dbgs(XMask)+' YMask='+dbgs(YMask), 4246 ' SizeChange='+dbgs(SizeChange)+' ROpIsSpecial='+dbgs(ROpIsSpecial)); 4247 write(' ROp='); 4248 case ROp of 4249 SRCCOPY : DebugLn('SRCCOPY'); 4250 SRCPAINT : DebugLn('SRCPAINT'); 4251 SRCAND : DebugLn('SRCAND'); 4252 SRCINVERT : DebugLn('SRCINVERT'); 4253 SRCERASE : DebugLn('SRCERASE'); 4254 NOTSRCCOPY : DebugLn('NOTSRCCOPY'); 4255 NOTSRCERASE : DebugLn('NOTSRCERASE'); 4256 MERGECOPY : DebugLn('MERGECOPY'); 4257 MERGEPAINT : DebugLn('MERGEPAINT'); 4258 PATCOPY : DebugLn('PATCOPY'); 4259 PATPAINT : DebugLn('PATPAINT'); 4260 PATINVERT : DebugLn('PATINVERT'); 4261 DSTINVERT : DebugLn('DSTINVERT'); 4262 BLACKNESS : DebugLn('BLACKNESS'); 4263 WHITENESS : DebugLn('WHITENESS'); 4264 else 4265 DebugLn('???'); 4266 end; 4267 {$ENDIF} 4268 4269 {$IFDEF VerboseGtkToDos}{$note tode remove, earlier checks require drawable <> nil}{$ENDIF} 4270 if SrcDevContext.Drawable = nil 4271 then begin 4272 if DstDevContext.Drawable = nil 4273 then 4274 Result := NoDrawableToNoDrawable 4275 else 4276 Result := NoDrawableToDrawable; 4277 end 4278 else begin 4279 if DstDevContext.Drawable = nil 4280 then 4281 Result := DrawableToNoDrawable 4282 else 4283 Result := DrawableToDrawable; 4284 end; 4285 4286 if TempPixmap <> nil 4287 then gdk_pixmap_unref(TempPixmap); 4288 if TempMaskBitmap <> nil 4289 then gdk_pixmap_unref(TempMaskBitmap); 4290end; 4291 4292{$IFDEF HASX} 4293function TGtk2WidgetSet.GetDesktopWidget: PGtkWidget; 4294begin 4295 Result := FDesktopWidget; 4296end; 4297 4298{function TGtk2WidgetSet.X11Raise(AHandle: HWND): boolean; 4299var 4300 Display: PDisplay; 4301 RootWin: TWindow; 4302 ScreenNum: Integer; 4303 XClient: TXClientMessageEvent; 4304 WMAtom: TAtom; 4305 screen: PGdkScreen; 4306begin 4307 Result:=false; 4308 screen:=gdk_screen_get_default; 4309 Display := gdk_x11_get_default_xdisplay; 4310 4311 if Display = nil then 4312 exit; 4313 ScreenNum := gdk_screen_get_number(screen); 4314 RootWin := gdk_x11_get_default_root_xwindow; 4315 4316 XClient._type := ClientMessage; 4317 XClient.window := AHandle; 4318 WMAtom := XInternAtom(Display,'_NET_ACTIVE_WINDOW', False); 4319 XClient.message_type := WMATom; 4320 XClient.format := 32; 4321 XClient.data.l[0] := 1; 4322 XClient.data.l[1] := 0; 4323 XClient.data.l[2] := 0; 4324 Result:=XSendEvent (Display, RootWin, False, 4325 SubstructureRedirectMask or SubstructureNotifyMask, 4326 @XClient)<>0; 4327end;} 4328 4329function TGtk2WidgetSet.IsCurrentDesktop(AWindow: PGdkWindow): Boolean; 4330var 4331 Display: PDisplay; 4332 ScreenNum: Integer; 4333 RootWin: TWindow; 4334 WMAtom: TAtom; 4335 4336 typeReturned: TAtom; 4337 formatReturned: Integer; 4338 nitemsReturned: PtrInt; 4339 unused: PtrInt; 4340 WidgetIndex, DesktopIndex: Pointer; 4341 WidgetWin: TWindow; 4342begin 4343 Result := True; 4344 if AWindow = nil then 4345 exit; 4346 Display := gdk_x11_get_default_xdisplay; 4347 if Display = nil then 4348 exit; 4349 ScreenNum := gdk_x11_get_default_screen; 4350 RootWin := XRootWindow(Display, ScreenNum); 4351 WMAtom := XInternAtom(Display,'_NET_WM_DESKTOP', True); 4352 WidgetWin := gdk_x11_drawable_get_xid(PGdkDrawable(AWindow)); 4353 4354 if (WMAtom > 0) and (WidgetWin <> 0) then 4355 begin 4356 WidgetIndex := nil; 4357 DesktopIndex := nil; 4358 // first get our desktop num (virtual desktop !) 4359 if XGetWindowProperty(Display, WidgetWin, WMAtom, 0, 4, False, XA_CARDINAL, 4360 @typeReturned, @formatReturned, @nitemsReturned, 4361 @unused, @WidgetIndex) = Success then 4362 begin 4363 if (typeReturned = XA_CARDINAL) and (formatReturned = 32) and 4364 (WidgetIndex <> nil) then 4365 begin 4366 // now get current active desktop index 4367 WMAtom := XInternAtom(Display,'_NET_CURRENT_DESKTOP', True); 4368 if XGetWindowProperty(Display, RootWin, WMAtom, 0, 4, False, 4369 XA_CARDINAL, @typeReturned, @formatReturned, @nitemsReturned, 4370 @unused, @DesktopIndex) = Success then 4371 begin 4372 if (typeReturned = XA_CARDINAL) and (formatReturned = 32) and 4373 (DesktopIndex <> nil) then 4374 Result := PtrUint(WidgetIndex^) = PtrUint(DesktopIndex^); 4375 end; 4376 end; 4377 4378 if WidgetIndex <> nil then 4379 XFree(WidgetIndex); 4380 if DesktopIndex <> nil then 4381 XFree(DesktopIndex); 4382 WidgetIndex := nil; 4383 DesktopIndex := nil; 4384 end; 4385 end; 4386end; 4387 4388function TGtk2WidgetSet.GetWindowManager: String; 4389{used to get window manager name, so we can handle different wm's behaviour 4390 eg. kde vs. gnome} 4391var 4392 Display: PDisplay; 4393 RootWin: TWindow; 4394 WMAtom: TAtom; 4395 WMWindow: TWindow; 4396 4397 typeReturned: TAtom; 4398 formatReturned: Integer; 4399 nitemsReturned: PtrInt; 4400 unused: PtrInt; 4401 data: Pointer; 4402 // Screen: PGdkScreen; 4403begin 4404 Result := ''; 4405 4406 Display := gdk_x11_get_default_xdisplay; 4407 4408 if Display = nil then 4409 exit; 4410 // Screen := gdk_screen_get_default; 4411 RootWin := gdk_x11_get_default_root_xwindow; 4412 4413 WMAtom := XInternAtom(Display,'_NET_WM_DESKTOP', True); 4414 4415 if WMAtom > 0 then 4416 begin 4417 WMAtom := XInternAtom(Display,'_NET_SUPPORTING_WM_CHECK', False); 4418 if WMAtom > 0 then 4419 begin 4420 data := nil; 4421 WMWindow := 0; 4422 if XGetWindowProperty(Display, RootWin, WMAtom, 0, 1024, False, XA_WINDOW, 4423 @typeReturned, @formatReturned, @nitemsReturned, 4424 @unused, @data) = Success then 4425 begin 4426 if (typeReturned = XA_WINDOW) and (formatReturned = 32) and 4427 (Data <> nil) then 4428 begin 4429 // this is our window manager window 4430 WMWindow := TWindow(Data^); 4431 XFree(Data); 4432 Data := nil; 4433 end; 4434 if WMWindow = 0 then 4435 exit; 4436 WMAtom := XInternAtom(Display,'UTF8_STRING', False); 4437 if XGetWindowProperty(Display, WMWindow, 4438 XInternAtom(Display,'_NET_WM_NAME', False), 0, 1024, False, 4439 WMAtom, @typeReturned, @formatReturned, @nitemsReturned, 4440 @unused, @data) = Success then 4441 begin 4442 if (typeReturned = WMAtom) and (formatReturned = 8) then 4443 Result := LowerCase(StrPas(Data)); 4444 if Data <> nil then 4445 XFree(Data); 4446 Data := nil; 4447 end; 4448 end; 4449 end; 4450 end; 4451end; 4452 4453function TGtk2WidgetSet.X11GetActiveWindow: HWND; 4454var 4455 Display: PDisplay; 4456 RootWin, ResultWindow: TWindow; 4457 WMAtom: TAtom; 4458 ActualTypeReturn: TAtom; 4459 ActualFormatReturn: LongInt; 4460 NItemsReturn, BytesAfterReturn: Cardinal; 4461 Ptr: PByte; 4462 Valid: Boolean; 4463begin 4464 Result := 0; 4465 4466 Display := gdk_x11_get_default_xdisplay; 4467 4468 if Display = nil then Exit; 4469 4470 RootWin := gdk_x11_get_default_root_xwindow; 4471 WMAtom := XInternAtom(Display,'_NET_ACTIVE_WINDOW', False); 4472 Valid:=XGetWindowProperty(Display, RootWin, WMAtom, 0, 1, False, 4473 AnyPropertyType, @ActualTypeReturn, 4474 @ActualFormatReturn, @NItemsReturn, 4475 @BytesAfterReturn, @Ptr)=0; 4476 if Valid then 4477 try 4478 if (ActualTypeReturn = None) or (ActualFormatReturn <> 32) or not Assigned(Ptr) then 4479 Valid := False; 4480 if Valid then ResultWindow := PWindow(Ptr)^; 4481 finally 4482 if Assigned(Ptr) then XFree(Ptr); 4483 end; 4484 4485 if Valid then Result := {%H-}HWND(gdk_window_foreign_new(ResultWindow)); 4486end; 4487 4488function TGtk2WidgetSet.GetAlwaysOnTopX11(AWindow: PGdkWindow): boolean; 4489var 4490 Display: PDisplay; 4491 X11Window: TWindow; 4492 WMAtom: TAtom; 4493 typeReturned: TAtom; 4494 formatReturned: Integer; 4495 nitemsReturned: PtrInt; 4496 unused: PtrInt; 4497 data: Pointer; 4498begin 4499 Result := False; 4500 Display := gdk_x11_get_default_xdisplay; 4501 if Display = nil then 4502 exit; 4503 X11Window := gdk_x11_drawable_get_xid(PGdkDrawable(AWindow)); 4504 if X11Window = 0 then 4505 exit; 4506 WMAtom := XInternAtom(Display,'_NET_WM_STATE', False); 4507 if WMAtom > 0 then 4508 begin 4509 data := nil; 4510 if XGetWindowProperty(Display, X11Window, WMAtom, 0, 1024, False, XA_ATOM, 4511 @typeReturned, @formatReturned, @nitemsReturned, 4512 @unused, @data) = Success then 4513 begin 4514 if (typeReturned = XA_ATOM) and (formatReturned = 32) and 4515 (Data <> nil) then 4516 begin 4517 while nitemsReturned > 0 do 4518 begin 4519 // make happy ancient x11 or old kde ? 4520 if XInternAtom(Display,'_NET_WM_STATE_STAYS_ON_TOP', False) = TAtom(Data^) then 4521 Result := True 4522 else 4523 if XInternAtom(Display,'_NET_WM_STATE_ABOVE', False) = TAtom(Data^) then 4524 Result := True; 4525 dec(nItemsReturned); 4526 if Result or (nItemsReturned = 0) then 4527 break; 4528 inc(Data); 4529 end; 4530 if nitemsReturned > 0 then 4531 XFree(Data); 4532 Data := nil; 4533 end; 4534 end; 4535 end; 4536end; 4537 4538procedure TGtk2WidgetSet.HideAllHints; 4539var 4540 TopList, List: PGList; 4541 Window: PGTKWindow; 4542begin 4543 TopList := gdk_window_get_toplevels; 4544 List := TopList; 4545 while List <> nil do 4546 begin 4547 if (List^.Data <> nil) then 4548 begin 4549 gdk_window_get_user_data(PGDKWindow(List^.Data), Pgpointer(@Window)); 4550 if GDK_IS_WINDOW(PGDKWindow(List^.Data)) then 4551 begin 4552 if gtk_is_window(Window) then 4553 begin 4554 if g_object_get_data(PGObject(Window),'lclhintwindow') <> nil then 4555 begin 4556 if gdk_window_is_visible(PGDKWindow(List^.Data)) then 4557 begin 4558 g_object_set_data(PGObject(Window),'lclneedrestorevisible',Pointer(1)); 4559 gdk_window_hide(PGDKWindow(List^.Data)); 4560 end; 4561 end; 4562 end; 4563 end; 4564 end; 4565 list := g_list_next(list); 4566 end; 4567 if TopList <> nil then 4568 g_list_free(TopList); 4569end; 4570 4571procedure TGtk2WidgetSet.RestoreAllHints; 4572var 4573 TopList, List: PGList; 4574 Window: PGTKWindow; 4575begin 4576 TopList := gdk_window_get_toplevels; 4577 List := TopList; 4578 while List <> nil do 4579 begin 4580 if (List^.Data <> nil) then 4581 begin 4582 gdk_window_get_user_data(PGDKWindow(List^.Data), Pgpointer(@Window)); 4583 if GDK_IS_WINDOW(PGDKWindow(List^.Data)) then 4584 begin 4585 if gtk_is_window(Window) then 4586 begin 4587 if g_object_get_data(PGObject(Window),'lclhintwindow') <> nil then 4588 begin 4589 if g_object_get_data(PGObject(Window),'lclneedrestorevisible') <> nil then 4590 begin 4591 g_object_set_data(PGObject(Window),'lclneedrestorevisible', nil); 4592 gdk_window_show(PGDKWindow(List^.Data)); 4593 end; 4594 end; 4595 end; 4596 end; 4597 end; 4598 list := g_list_next(list); 4599 end; 4600 if TopList <> nil then 4601 g_list_free(TopList); 4602end; 4603 4604function TGtk2WidgetSet.compositeManagerRunning: Boolean; 4605var 4606 XDisplay: PDisplay; 4607 WMAtom: TAtom; 4608begin 4609 Result := False; 4610 // who's running such old composition manager ? 4611 if (gtk_major_version = 2) and (gtk_minor_version < 10) then 4612 exit; 4613 XDisplay := gdk_display; 4614 WMAtom := XInternAtom(XDisplay,'_NET_WM_CM_S0', False); 4615 if WMAtom > 0 then 4616 Result := XGetSelectionOwner(XDisplay, WMAtom) <> 0; 4617end; 4618 4619{$ENDIF} 4620{------------------------------------------------------------------------------ 4621 procedure TGtk2WidgetSet.BringFormToFront(Sender: TObject); 4622------------------------------------------------------------------------------} 4623procedure TGtk2WidgetSet.BringFormToFront(Sender: TObject); 4624var 4625 AWindow: PGdkWindow; 4626 Widget: PGtkWidget; 4627begin 4628 Widget := {%H-}PgtkWidget(TCustomForm(Sender).Handle); 4629 AWindow:=GetControlWindow(Widget); 4630 if AWindow<>nil then begin 4631 gdk_window_raise(AWindow); 4632 end; 4633end; 4634 4635{------------------------------------------------------------------------------ 4636 Method: TGtk2WidgetSet.ResizeChild 4637 4638 Params: sender - the object which invoked this function 4639 Left,Top,Width,Height - new dimensions for the control 4640 Returns: Nothing 4641 4642 *Note: Resize a child widget on the parents fixed widget 4643 ------------------------------------------------------------------------------} 4644procedure TGtk2WidgetSet.ResizeChild(Sender : TObject; 4645 Left, Top, Width, Height : Integer); 4646var 4647 LCLControl: TWinControl; 4648begin 4649 //DebugLn('[TGtk2WidgetSet.ResizeChild] START ',TControl(Sender).Name,':',Sender.Classname,' Left=',Left,' Top=',Top,' Width=',Width,' Height=',Height); 4650 //DebugLn((Format('trace: [TGtk2WidgetSet.ResizeChild] %s --> Resize', [Sender.ClassNAme]))); 4651 4652 if Sender is TWinControl then begin 4653 LCLControl:=TWinControl(Sender); 4654 if LCLControl.HandleAllocated then begin 4655 ResizeHandle(LCLControl); 4656 //if (Sender is TCustomForm) then 4657 //if CompareText(Sender.ClassName,'TScrollBar')=0 then 4658 // DebugLn(' FFF ResizeChild ',Sender.ClassName,' ',Left,',',Top,',',Width,',',Height); 4659 end; 4660 end; 4661 //DebugLn('[TGtk2WidgetSet.ResizeChild] END ',Sender.Classname,' Left=',Left,' Top=',Top,' Width=',Width,' Height=',Height); 4662end; 4663 4664procedure TGtk2WidgetSet.SetCallbackDirect(const AMsg: LongInt; 4665 const AGTKObject: PGTKObject; const ALCLObject: TObject); 4666begin 4667 SetCallbackEx(AMsg,AGTKObject,ALCLObject,true); 4668end; 4669 4670procedure TGtk2WidgetSet.SetCallback(const AMsg: LongInt; 4671 const AGTKObject: PGTKObject; const ALCLObject: TObject); 4672begin 4673 SetCallbackEx(AMsg,AGTKObject,ALCLObject,false); 4674end; 4675 4676{------------------------------------------------------------------------------ 4677 Function: TGtk2WidgetSet.RemoveCallBacks 4678 Params: Widget 4679 Returns: nothing 4680 4681 Removes Call Back Signals from the Widget 4682 ------------------------------------------------------------------------------} 4683procedure TGtk2WidgetSet.RemoveCallbacks(Widget: PGtkWidget); 4684var 4685 Info: PWinWidgetInfo; 4686begin 4687 if Widget = nil then Exit; 4688 Info := GetWidgetInfo(Widget, False); 4689 if Info <> nil then 4690 g_signal_handlers_disconnect_matched(Widget, G_SIGNAL_MATCH_DATA, 0, 0, nil, nil, Info); 4691end; 4692 4693{------------------------------------------------------------------------------- 4694 TGtk2WidgetSet.DestroyLCLComponent 4695 Params: Sender: TObject 4696 4697 Destroy the widget and all associated data 4698-------------------------------------------------------------------------------} 4699procedure TGtk2WidgetSet.DestroyLCLComponent(Sender : TObject); 4700var 4701 handle: hwnd; // handle of sender 4702 Widget: PGtkWidget; 4703 GtkWindow: PGtkWidget; 4704begin 4705 Handle := HWnd({%H-}PtrUInt(ObjectToGtkObject(Sender))); 4706 if Handle=0 then exit; 4707 Widget:={%H-}PGtkWidget(Handle); 4708 if WidgetIsDestroyingHandle(Widget) then exit; 4709 SetWidgetIsDestroyingHandle(Widget); 4710 4711 //DebugLn('TGtk2WidgetSet.DestroyLCLComponent A ',GetWidgetClassName(Widget)); 4712 4713 // if one of its widgets has the focus then unfocus 4714 GtkWindow:=gtk_widget_get_toplevel(Widget); 4715 if GtkWidgetIsA(GtkWindow,GTK_TYPE_WINDOW) 4716 and (GetNearestLCLObject(PGtkWindow(GtkWindow)^.Focus_Widget)=Sender) 4717 then 4718 gtk_window_set_focus(PGtkWindow(GtkWindow),nil); 4719 4720 if Sender is TCommonDialog then 4721 DestroyCommonDialogAddOns(TCommonDialog(Sender)); 4722 4723 if GTK_IS_ENTRY(Widget) then 4724 g_idle_remove_by_data(Widget); 4725 4726 // destroy widget and properties 4727 DestroyConnectedWidget(Widget,false); 4728 4729 // clean up unneeded containers 4730 if Sender is TMenuItem then 4731 DestroyEmptySubmenu(TMenuItem(Sender)); 4732 4733 // mouse click messages 4734 if LastMouse.WinControl=Sender then 4735 LastMouse.Button := 0; 4736end; 4737 4738procedure TGtk2WidgetSet.FinishCreateHandle(const AWinControl: TWinControl; 4739 Widget: PGtkWidget; const AParams: TCreateParams); 4740var 4741 WidgetInfo: PWidgetInfo; 4742 Allocation: TGTKAllocation; 4743begin 4744 WidgetInfo := GetWidgetInfo(Widget,true); // Widget info already created in CreateAPIWidget 4745 WidgetInfo^.LCLObject := AWinControl; 4746 WidgetInfo^.Style := AParams.Style; 4747 WidgetInfo^.ExStyle := AParams.ExStyle; 4748 WidgetInfo^.WndProc := {%H-}PtrUInt(AParams.WindowClass.lpfnWndProc); 4749 4750 // set allocation 4751 Allocation.X := AParams.X; 4752 Allocation.Y := AParams.Y; 4753 Allocation.Width := AParams.Width; 4754 Allocation.Height := AParams.Height; 4755 gtk_widget_size_allocate(Widget, @Allocation); 4756 4757 Set_RC_Name(AWinControl, Widget); 4758 TGtk2WSWinControl.SetCallbacks(PGtkObject(Widget), AWinControl); 4759end; 4760 4761procedure TGtk2WidgetSet.DestroyConnectedWidget(Widget: PGtkWidget; 4762 CheckIfDestroying: boolean); 4763var 4764 FixWidget: PGtkWidget; 4765 QueueItem : TGtkMessageQueueItem; 4766 NextItem : TGtkMessageQueueItem; 4767 MsgPtr: PMsg; 4768begin 4769 if CheckIfDestroying then begin 4770 if WidgetIsDestroyingHandle(Widget) then exit; 4771 SetWidgetIsDestroyingHandle(Widget); 4772 end; 4773 4774 FixWidget:=GetFixedWidget(Widget); 4775 4776 //DebugLn('TGtk2WidgetSet.DestroyLCLComponent B Widget=',GetWidgetDebugReport(Widget)); 4777 ClearAccelKey(Widget); 4778 4779 // untransient 4780 if GtkWidgetIsA(Widget,GTK_TYPE_WINDOW) then begin 4781 UntransientWindow(PGtkWindow(Widget)); 4782 end; 4783 4784 // callbacks 4785 RemoveCallbacks(Widget); 4786 4787 // update mouse capturing 4788 if (MouseCaptureWidget=Widget) or (MouseCaptureWidget=FixWidget) then 4789 MouseCaptureWidget:=nil; 4790 4791 // update clipboard widget 4792 if (ClipboardWidget=Widget) or (ClipboardWidget=FixWidget) then 4793 begin 4794 // clipboard widget destroyed 4795 if (Application<>nil) and (Application.MainForm<>nil) 4796 and (Application.MainForm.HandleAllocated) 4797 and ({%H-}PGtkWidget(Application.MainForm.Handle)<>Widget) then 4798 // there is still the main form left -> use it for clipboard 4799 SetClipboardWidget({%H-}PGtkWidget(Application.MainForm.Handle)) 4800 else 4801 // program closed -> close clipboard 4802 SetClipboardWidget(nil); 4803 end; 4804 4805 // update caret 4806 if GtkWidgetIsA(Widget,GTKAPIWidget_GetType) then 4807 DestroyCaret(HDC({%H-}PtrUInt(Widget))); 4808 4809 // remove pending size messages 4810 UnsetResizeRequest(Widget); 4811 FWidgetsResized.Remove(Widget); 4812 if FixWidget<>Widget then 4813 FFixWidgetsResized.Remove(FixWidget); 4814 4815 // destroy the widget 4816 //DebugLn(['TGtk2WidgetSet.DestroyConnectedWidget ',GetWidgetDebugReport(Widget)]); 4817 DestroyWidget(Widget); 4818 4819 // remove all remaining messages to this widget 4820 fMessageQueue.Lock; 4821 try 4822 QueueItem:=FMessageQueue.FirstMessageItem; 4823 while (QueueItem<>nil) do begin 4824 MsgPtr := QueueItem.Msg; 4825 NextItem := TGtkMessagequeueItem(QueueItem.Next); 4826 if ({%H-}PGtkWidget(MsgPtr^.hWnd)=Widget) then 4827 fMessageQueue.RemoveMessage(QueueItem,FPMF_All,true); 4828 QueueItem := NextItem; 4829 end; 4830 finally 4831 fMessageQueue.UnLock; 4832 end; 4833end; 4834 4835function TGtk2WidgetSet.GetCompStyle(Sender : TObject) : Longint; 4836begin 4837 Result := csNone; 4838 if (Sender is TControl) then 4839 Result := TControl(Sender).FCompStyle 4840 else 4841 if (Sender is TMenuItem) then 4842 Result := TMenuItem(Sender).FCompStyle 4843 else 4844 if (Sender is TMenu) or (Sender is TPopupMenu) 4845 then 4846 Result := TMenu(Sender).FCompStyle 4847 else 4848 if (Sender is TCommonDialog) 4849 then 4850 result := TCommonDialog(Sender).FCompStyle; 4851end; 4852 4853function TGtk2WidgetSet.GetCaption(Sender : TObject) : String; 4854begin 4855 Result := Sender.ClassName; 4856 if (Sender is TControl) then 4857 Result := TControl(Sender).Caption 4858 else 4859 if (Sender is TMenuItem) then 4860 Result := TMenuItem(Sender).Caption; 4861 4862 if Result = '' then 4863 Result := rsBlank; 4864end; 4865 4866function TGtk2WidgetSet.CreateAPIWidget( 4867 AWinControl: TWinControl): PGtkWidget; 4868// currently only used for csFixed 4869var 4870 Adjustment: PGTKAdjustment; 4871 WinWidgetInfo: PWinWidgetInfo; 4872begin 4873 Result := GTKAPIWidget_New; 4874 WinWidgetInfo := GetWidgetInfo(Result, True); 4875 WinWidgetInfo^.CoreWidget := PGTKAPIWidget(Result)^.Client; 4876 WinWidgetInfo^.LCLObject := AWinControl; 4877 4878 gtk_scrolled_window_set_policy(PGTKScrolledWindow(Result), 4879 GTK_POLICY_NEVER, GTK_POLICY_NEVER); 4880 4881 Adjustment := 4882 gtk_scrolled_window_get_vadjustment(PGTKScrolledWindow(Result)); 4883 if Adjustment <> nil 4884 then with Adjustment^ do 4885 begin 4886 g_object_set_data(PGObject(Adjustment), odnScrollBar, 4887 PGTKScrolledWindow(Result)^.VScrollBar); 4888 Step_Increment := 1; 4889 end; 4890 4891 Adjustment := 4892 gtk_scrolled_window_get_hadjustment(PGTKScrolledWindow(Result)); 4893 if Adjustment <> nil 4894 then with Adjustment^ do 4895 begin 4896 g_object_set_data(PGObject(Adjustment), odnScrollBar, 4897 PGTKScrolledWindow(Result)^.HScrollBar); 4898 Step_Increment := 1; 4899 end; 4900 4901 if AWinControl is TCustomControl then 4902 GTKAPIWidget_SetShadowType(PGTKAPIWidget(Result), 4903 BorderStyleShadowMap[TCustomControl(AWinControl).BorderStyle]); 4904end; 4905 4906{------------------------------------------------------------------------------ 4907 function TGtk2WidgetSet.CreateSimpleClientAreaWidget(Sender: TObject; 4908 NotOnParentsClientArea: boolean): PGtkWidget; 4909 4910 Create a fixed widget in a horizontal box 4911 ------------------------------------------------------------------------------} 4912function TGtk2WidgetSet.CreateSimpleClientAreaWidget(Sender: TObject; 4913 NotOnParentsClientArea: boolean): PGtkWidget; 4914var 4915 TempWidget: PGtkWidget; 4916 WinWidgetInfo: PWinWidgetInfo; 4917begin 4918 {$ifdef GtkFixedWithWindow} 4919 // Fixed + GdkWindow 4920 Result := gtk_hbox_new(false, 0); 4921 TempWidget := CreateFixedClientWidget; 4922 {$else} 4923 // Fixed w/o GdkWindow 4924 Result := gtk_event_box_new; 4925 { MG: Normally the event box should be made invisible as suggested 4926 here: http://library.gnome.org/devel/gtk/stable/GtkEventBox.html#gtk-event-box-set-visible-window 4927 But is has a sideeffect: 4928 Sometimes the mouse events for gtk widgets without window don't get any 4929 mouse events any longer. 4930 For example: Add a PageControl (Page3, Page4) into a PageControl (Page1,Page2). 4931 Start program. Click on Page2, which hides the inner PageControl. Then 4932 click to return to Page1. Now the inner PageControl does no longer 4933 receive mouse events and so you can not switch between Page3 and Page4.} 4934 // MG: disabled: gtk_event_box_set_visible_window(PGtkEventBox(Result), False); 4935 TempWidget := CreateFixedClientWidget(False); 4936 {$endif} 4937 4938 gtk_container_add(GTK_CONTAINER(Result), TempWidget); 4939 gtk_widget_show(TempWidget); 4940 if NotOnParentsClientArea then 4941 begin 4942 WinWidgetInfo:=GetWidgetInfo(Result, true); 4943 Include(WinWidgetInfo^.Flags, wwiNotOnParentsClientArea); 4944 end; 4945 SetFixedWidget(Result, TempWidget); 4946 SetMainWidget(Result, TempWidget); 4947 4948 // MG: should fix the invisible event box, but does not: 4949 // gtk_widget_add_events (PGtkWidget(Result), GDK_BUTTON_PRESS_MASK); 4950 4951 gtk_widget_show(Result); 4952end; 4953 4954function TGtk2WidgetSet.CreateStandardCursor(ACursor: SmallInt): hCursor; 4955var 4956 CursorValue: Integer; 4957begin 4958 Result := 0; 4959 if ACursor < crLow then Exit; 4960 if ACursor > crHigh then Exit; 4961 4962 case TCursor(ACursor) of 4963 crDefault: CursorValue := GDK_LEFT_PTR; 4964 crArrow: CursorValue := GDK_Arrow; 4965 crCross: CursorValue := GDK_Cross; 4966 crIBeam: CursorValue := GDK_XTerm; 4967 crSizeNESW: CursorValue := GDK_BOTTOM_LEFT_CORNER; 4968 crSizeNS: CursorValue := GDK_SB_V_DOUBLE_ARROW; 4969 crSizeNWSE: CursorValue := GDK_TOP_LEFT_CORNER; 4970 crSizeWE: CursorValue := GDK_SB_H_DOUBLE_ARROW; 4971 crSizeNW: CursorValue := GDK_TOP_LEFT_CORNER; 4972 crSizeN: CursorValue := GDK_TOP_SIDE; 4973 crSizeNE: CursorValue := GDK_TOP_RIGHT_CORNER; 4974 crSizeW: CursorValue := GDK_LEFT_SIDE; 4975 crSizeE: CursorValue := GDK_RIGHT_SIDE; 4976 crSizeSW: CursorValue := GDK_BOTTOM_LEFT_CORNER; 4977 crSizeS: CursorValue := GDK_BOTTOM_SIDE; 4978 crSizeSE: CursorValue := GDK_BOTTOM_RIGHT_CORNER; 4979 crUpArrow: CursorValue := GDK_LEFT_PTR; 4980 crHourGlass:CursorValue := GDK_WATCH; 4981 crHSplit: CursorValue := GDK_SB_H_DOUBLE_ARROW; 4982 crVSplit: CursorValue := GDK_SB_V_DOUBLE_ARROW; 4983 crAppStart: CursorValue := GDK_LEFT_PTR; 4984 crHelp: CursorValue := GDK_QUESTION_ARROW; 4985 crHandPoint:CursorValue := GDK_Hand2; 4986 crSizeAll: CursorValue := GDK_FLEUR; 4987 else 4988 CursorValue := -1; 4989 end; 4990 if CursorValue <> -1 then 4991 Result := hCursor({%H-}PtrUInt(gdk_cursor_new(CursorValue))); 4992end; 4993 4994{------------------------------------------------------------------------------ 4995 procedure TGtk2WidgetSet.DestroyEmptySubmenu(Sender: TObject); 4996 4997 Used by DestroyLCLComponent to destroy empty submenus, when destroying the 4998 last menu item. 4999------------------------------------------------------------------------------} 5000procedure TGtk2WidgetSet.DestroyEmptySubmenu(Sender: TObject); 5001var 5002 LCLMenuItem: TMenuItem; 5003 ParentLCLMenuItem: TMenuItem; 5004 ParentMenuWidget: PGtkWidget; 5005 ParentSubMenuWidget: PGtkWidget; 5006 SubMenuWidget: PGtkMenu; 5007begin 5008 if not (Sender is TMenuItem) then 5009 RaiseGDBException('TGtk2WidgetSet.DestroyEmptySubmenu'); 5010 // destroying a TMenuItem 5011 LCLMenuItem:=TMenuItem(Sender); 5012 // check if in a sub menu 5013 if (LCLMenuItem.Parent=nil) then exit; 5014 if not (LCLMenuItem.Parent is TMenuItem) then exit; 5015 ParentLCLMenuItem:=TMenuItem(LCLMenuItem.Parent); 5016 if not ParentLCLMenuItem.HandleAllocated then exit; 5017 ParentMenuWidget:={%H-}PGtkWidget(ParentLCLMenuItem.Handle); 5018 if not GtkWidgetIsA(ParentMenuWidget,GTK_TYPE_MENU_ITEM) then exit; 5019 ParentSubMenuWidget:=PGTKMenuItem(ParentMenuWidget)^.submenu; 5020 if not GtkWidgetIsA(ParentSubMenuWidget,GTK_TYPE_MENU) then exit; 5021 SubMenuWidget:=PGTKMenu(ParentSubMenuWidget); 5022 if SubMenuWidget^.menu_shell.children=nil then begin 5023 gtk_widget_destroy(PgtkWidget(SubMenuWidget)); 5024 g_object_set_data(PGObject(ParentMenuWidget),'ContainerMenu',nil); 5025 end; 5026end; 5027 5028{------------------------------------------------------------------------------ 5029 TGtkWidgetSet ShowHide 5030 *Note: Show or hide a widget 5031------------------------------------------------------------------------------} 5032{$IFDEF VerboseGtkToDos}{$note TODO: move to wsclass }{$ENDIF} 5033procedure TGtk2WidgetSet.SetVisible(Sender: TObject; const AVisible: Boolean); 5034 5035 procedure RaiseWrongClass; 5036 begin 5037 RaiseGDBException('TGtk2WidgetSet.ShowHide Sender.ClassName='+Sender.ClassName); 5038 end; 5039 5040var 5041 SenderWidget: PGTKWidget; 5042 LCLControl: TWinControl; 5043 Decor, Func : Longint; 5044 AWindow: PGdkWindow; 5045 ACustomForm: TCustomForm; 5046 CurWindowState: TWindowState; 5047 WidgetInfo: PWidgetInfo; 5048begin 5049 if not (Sender is TWinControl) then 5050 RaiseWrongClass; 5051 if (Sender is TCustomForm) then 5052 ACustomForm := TCustomForm(Sender) 5053 else 5054 ACustomForm := nil; 5055 5056 LCLControl:=TWinControl(Sender); 5057 if not LCLControl.HandleAllocated then exit; 5058 SenderWidget:={%H-}PgtkWidget(LCLControl.Handle); 5059 //if (Sender is TForm) and (Sender.ClassName='TForm1') then 5060 // DebugLn('[TGtk2WidgetSet.ShowHide] START ',TControl(Sender).Name,':',Sender.ClassName, 5061 // ' Visible=',TControl(Sender).Visible,' GtkVisible=',gtk_widget_visible(SenderWidget), 5062 // ' GtkRealized=',gtk_widget_realized(SenderWidget), 5063 // ' GtkMapped=',gtk_widget_mapped(SenderWidget), 5064 // ' Should=',AVisible ); 5065 if AVisible then 5066 begin 5067 if (ACustomForm<>nil) and (ACustomForm.Parent=nil) then begin 5068 // update shared accelerators 5069 ShareWindowAccelGroups(SenderWidget); 5070 end; 5071 5072 // before making the widget visible, set the position and size 5073 // this is not possible for windows - for windows position will be set 5074 // after widget become visible 5075 if FWidgetsWithResizeRequest.Contains(SenderWidget) then 5076 begin 5077 if (ACustomForm<>nil) and (ACustomForm.Parent=nil) then 5078 begin 5079 // top level control (a form without parent) 5080 {$IFDEF VerboseFormPositioning} 5081 DebugLn('VFP [TGtk2WidgetSet.ShowHide] A set bounds ', 5082 LCLControl.Name,':',LCLControl.ClassName, 5083 ' Window=',dbgs(GetControlWindow(SenderWidget)<>nil), 5084 ' ',dbgs(LCLControl.Left),',',dbgs(LCLControl.Top), 5085 ',',dbgs(LCLControl.Width),',',dbgs(LCLControl.Height)); 5086 {$ENDIF} 5087 SetWindowSizeAndPosition(PgtkWindow(SenderWidget),LCLControl); 5088 end 5089 else 5090 if (LCLControl.Parent<>nil) then 5091 begin 5092 // resize widget 5093 {$IFDEF VerboseSizeMsg} 5094 DebugLn(['TGtk2WidgetSet.ShowHide ',DbgSName(LCLControl)]); 5095 {$ENDIF} 5096 SetWidgetSizeAndPosition(LCLControl); 5097 end; 5098 {$ifndef windows} 5099 UnsetResizeRequest(SenderWidget); 5100 {$endif} 5101 end; 5102 5103 if (ACustomForm<>nil) and (ACustomForm.Parent=nil) then 5104 begin 5105 If (ACustomForm.BorderStyle <> bsSizeable) or 5106 ((ACustomForm.FormStyle in fsAllStayOnTop) 5107 and (not (csDesigning in ACustomForm.ComponentState))) 5108 then begin 5109 Decor := GetWindowDecorations(ACustomForm); 5110 Func := GetWindowFunction(ACustomForm); 5111 gtk_widget_realize(SenderWidget); 5112 AWindow:=GetControlWindow(SenderWidget); 5113 gdk_window_set_decorations(AWindow, decor); 5114 gdk_window_set_functions(AWindow, func); 5115 end; 5116 ShareWindowAccelGroups(SenderWidget); 5117 5118 // capturing is always gtkwindow dependent. On showing a new window 5119 // the gtk will put a new widget on the grab stack. 5120 // -> release our capture 5121 ReleaseMouseCapture; 5122 end; 5123 5124 if gtk_widget_visible(SenderWidget) then 5125 exit; 5126 5127 gtk_widget_show(SenderWidget); 5128 5129 if (ACustomForm <> nil) and 5130 (ACustomForm.Parent = nil) and 5131 (ACustomForm.ParentWindow = 0) then 5132 begin 5133 CurWindowState:=ACustomForm.WindowState; 5134 if csDesigning in ACustomForm.ComponentState then 5135 CurWindowState:=wsNormal; 5136 case CurWindowState of 5137 wsNormal: 5138 begin 5139 WidgetInfo := GetWidgetInfo(SenderWidget); 5140 with WidgetInfo^.FormWindowState do 5141 begin 5142 if new_window_state and GDK_WINDOW_STATE_ICONIFIED <> 0 then 5143 gtk_window_deiconify(PGtkWindow(SenderWidget)); 5144 if (new_window_state and GDK_WINDOW_STATE_MAXIMIZED <> 0) or 5145 (new_window_state and GDK_WINDOW_STATE_FULLSCREEN <> 0) then 5146 gtk_window_unmaximize(PGtkWindow(SenderWidget)); 5147 end; 5148 end; 5149 wsMaximized: gtk_window_maximize(PGtkWindow(SenderWidget)); 5150 wsMinimized: gtk_window_iconify(PGtkWindow(SenderWidget)); 5151 end; 5152 end; 5153 end 5154 else begin 5155 // hide 5156 if (ACustomForm<>nil) then 5157 UnshareWindowAccelGroups(SenderWidget); 5158 5159 if not gtk_widget_visible(SenderWidget) then 5160 exit; 5161 5162 // save previous position 5163 if ACustomForm <> nil then 5164 begin 5165 if (ACustomForm is TForm) and 5166 not (ACustomForm.FormStyle in [fsMDIChild, fsSplash]) 5167 and (ACustomForm.BorderStyle <> bsNone) then 5168 SetResizeRequest(SenderWidget); 5169 end; 5170 5171 gtk_widget_hide(SenderWidget); 5172 5173 if GtkWidgetIsA(SenderWidget,GTK_TYPE_WINDOW) then begin 5174 {$IFDEF VerboseTransient} 5175 DebugLn('TGtk2WidgetSet.ShowHide HIDE ',Sender.ClassName); 5176 {$ENDIF} 5177 UntransientWindow(PGtkWindow(SenderWidget)); 5178 end; 5179 end; 5180 5181 if GtkWidgetIsA(SenderWidget,GTK_TYPE_WINDOW) then begin 5182 // make sure when hiding a window, that at least the main window 5183 // is selectable via the window manager 5184 if (Application<>nil) and (Application.MainForm<>nil) 5185 and (Application.MainForm.HandleAllocated) then begin 5186 SetFormShowInTaskbar(Application.MainForm,stAlways); 5187 end; 5188 end; 5189 5190 //if Sender is TCustomForm then 5191 // DebugLn('[TGtk2WidgetSet.ShowHide] END ',Sender.ClassName,' Window=',FormWidget^.Window<>nil); 5192end; 5193 5194function TGtk2WidgetSet.DragImageList_BeginDrag(APixmap: PGdkPixmap; AMask: PGdkBitmap; AHotSpot: TPoint): Boolean; 5195var 5196 w, h: gint; 5197begin 5198 if FDragImageList = nil then 5199 begin 5200 FDragImageList := gtk_window_new(GTK_WINDOW_POPUP); 5201 gdk_drawable_get_size(APixmap, @w, @h); 5202 gtk_window_set_default_size(PGtkWindow(FDragImageList), w, h); 5203 gtk_widget_realize(FDragImageList); 5204 gdk_window_set_decorations(FDragImageList^.window, 0); 5205 gdk_window_set_functions(FDragImageList^.window, GDK_FUNC_RESIZE or GDK_FUNC_CLOSE); 5206 FDragImageListIcon := gtk_pixmap_new(APixmap, AMask); 5207 gtk_container_add(PGtkContainer(FDragImageList), FDragImageListIcon); 5208 gtk_widget_show(FDragImageListIcon); 5209 // make window transparent outside mask 5210 gdk_window_shape_combine_mask(FDragImageList^.window, AMask, 0, 0); 5211 FDragHotStop := AHotSpot; 5212 end; 5213 Result := FDragImageList <> nil; 5214end; 5215 5216procedure TGtk2WidgetSet.DragImageList_EndDrag; 5217begin 5218 if FDragImageList <> nil then 5219 begin 5220 if FDragImageListIcon <> nil then 5221 gtk_widget_destroy(FDragImageListIcon); 5222 gtk_widget_destroy(FDragImageList); 5223 FDragImageList := nil; 5224 end; 5225end; 5226 5227function TGtk2WidgetSet.DragImageList_DragMove(X, Y: Integer): Boolean; 5228begin 5229 Result := FDragImageList <> nil; 5230 if Result then 5231 begin 5232 if gdk_window_is_visible(FDragImageList^.Window) then 5233 gdk_window_raise(FDragImageList^.Window); 5234 gdk_window_move(FDragImageList^.Window, X - FDragHotStop.X, Y - FDragHotStop.Y); 5235 end; 5236end; 5237 5238function TGtk2WidgetSet.DragImageList_SetVisible(NewVisible: Boolean): Boolean; 5239begin 5240 Result := FDragImageList <> nil; 5241 if Result then 5242 if NewVisible then 5243 gtk_widget_show(FDragImageList) 5244 else 5245 gtk_widget_hide(FDragImageList); 5246end; 5247 5248{------------------------------------------------------------------------------- 5249 method TGtkWidgetSet LoadPixbufFromLazResource 5250 Params: const ResourceName: string; 5251 var Pixbuf: PGdkPixbuf 5252 Result: none 5253 5254 Loads a pixbuf from a lazarus resource. The resource must be a XPM file. 5255-------------------------------------------------------------------------------} 5256procedure TGtk2WidgetSet.LoadPixbufFromLazResource(const ResourceName: string; 5257 var Pixbuf: PGdkPixbuf); 5258var 5259 ImgData: PPChar; 5260begin 5261 Pixbuf:=nil; 5262 try 5263 ImgData:=LazResourceXPMToPPChar(ResourceName); 5264 except 5265 on e: Exception do 5266 DebugLn('WARNING: TGtk2WidgetSet.LoadXPMFromLazResource: '+e.Message); 5267 end; 5268 {$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF} 5269 {$IFDEF VerboseGdkPixbuf} 5270 debugln('LoadPixbufFromLazResource A1'); 5271 {$ENDIF} 5272 pixbuf:=gdk_pixbuf_new_from_xpm_data(ImgData); 5273 {$IFDEF VerboseGdkPixbuf} 5274 debugln('LoadPixbufFromLazResource A2'); 5275 {$ENDIF} 5276 {$IFDEF DebugGDK}EndGDKErrorTrap;{$ENDIF} 5277 FreeMem(ImgData); 5278end; 5279 5280{------------------------------------------------------------------------------ 5281 Method: TGtk2WidgetSet.SetPixel 5282 Params: Sender : the lcl object which called this func via SendMessage 5283 Data : pointer to a TLMSetGetPixel record 5284 Returns: nothing 5285 5286 Set the color of the specified pixel on the window?screen?object? 5287 ------------------------------------------------------------------------------} 5288procedure TGtk2WidgetSet.DCSetPixel(CanvasHandle: HDC; X, Y: integer; AColor: TGraphicsColor); 5289var 5290 DC : TGtkDeviceContext absolute CanvasHandle; 5291 DCOrigin: TPoint; 5292 GDKColor: TGDKColor; 5293begin 5294 if (DC = nil) or (DC.Drawable = nil) then exit; 5295 5296 DCOrigin := DC.TransfPointIndirect(DC.Offset); 5297 inc(X, DCOrigin.X); 5298 inc(Y, DCOrigin.Y); 5299 5300 DC.SelectedColors := dcscCustom; 5301 GDKColor := AllocGDKColor(ColorToRGB(AColor)); 5302 gdk_gc_set_foreground(DC.GC, @GDKColor); 5303 {$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF} 5304 gdk_draw_point(DC.Drawable, DC.GC, X, Y); 5305 {$IFDEF DebugGDK}EndGDKErrorTrap;{$ENDIF} 5306end; 5307 5308procedure TGtk2WidgetSet.DCRedraw(CanvasHandle: HDC); 5309var 5310 fWindow :pGdkWindow; 5311 widget : PgtkWIdget; 5312 PixMap : pgdkPixMap; 5313 Child: PGtkWidget; 5314begin 5315 //DebugLn('Trace:In AutoRedraw in GTKObject'); 5316 5317 Child := {%H-}PgtkWidget(CanvasHandle); 5318 Widget := GetFixedWidget(Child); 5319 pixmap := g_object_get_data(pgobject(Child),'Pixmap'); 5320 if PixMap = nil then Exit; 5321 fWindow := GetControlWindow(widget); 5322 5323 if fWindow<>nil then begin 5324 {$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF} 5325 gdk_draw_pixmap(fwindow, 5326 gtk_widget_get_style(widget)^.fg_gc[GTK_WIDGET_STATE (widget)], 5327 pixmap, 5328 0,0, 5329 0,0, 5330 pgtkwidget(widget)^.allocation.width, 5331 pgtkwidget(widget)^.allocation.height); 5332 {$IFDEF DebugGDK}EndGDKErrorTrap;{$ENDIF} 5333 end; 5334end; 5335 5336{------------------------------------------------------------------------------ 5337 Method: TGtk2WidgetSet.GetPixel 5338 Params: Sender : the lcl object which called this func via SenMessage 5339 Data : pointer to a TLMSetGetPixel record 5340 Returns: nothing 5341 5342 Get the color of the specified pixel on the window?screen?object? 5343 ------------------------------------------------------------------------------} 5344function TGtk2WidgetSet.DCGetPixel(CanvasHandle: HDC; X, Y: integer): TGraphicsColor; 5345var 5346 DC : TGtkDeviceContext absolute CanvasHandle; 5347 Image : pGDKImage; 5348 GDKColor: TGDKColor; 5349 Colormap : PGDKColormap; 5350 DCOrigin: TPoint; 5351 MaxX, MaxY: integer; 5352 Pixel: LongWord; 5353begin 5354 Result := clNone; 5355 if (DC = nil) or (DC.Drawable = nil) then Exit; 5356 5357 DCOrigin := DC.TransfPointIndirect(DC.Offset); 5358 inc(X, DCOrigin.X); 5359 inc(Y, DCOrigin.Y); 5360 5361 gdk_drawable_get_size(DC.Drawable, @MaxX, @MaxY); 5362 if (X<0) or (Y<0) or (X>=MaxX) or (Y>=MaxY) then exit; 5363 5364 Image := gdk_drawable_get_image(DC.Drawable,X,Y,1,1); 5365 if Image = nil then exit; 5366 5367 colormap := gdk_image_get_colormap(image); 5368 if colormap = nil then 5369 colormap := gdk_drawable_get_colormap(DC.Drawable); 5370 5371 if colormap = nil then 5372 colormap := gdk_colormap_get_system; 5373 5374 Pixel:=gdk_image_get_pixel(Image,0,0); 5375 FillChar(GDKColor{%H-}, SizeOf(GDKColor),0); 5376 // does not work with TBitmap.Canvas 5377 gdk_colormap_query_color(colormap, Pixel, @GDKColor); 5378 5379 gdk_image_unref(Image); 5380 5381 Result := TGDKColorToTColor(GDKColor); 5382end; 5383 5384{ TODO: move this ``LM_GETVALUE'' spinedit code someplace useful 5385 5386 csSpinEdit : 5387 Begin 5388 Single(Data^):=gtk_spin_button_get_value_As_Float(PgtkSpinButton(Handle)); 5389 end; 5390} 5391 5392{------------------------------------------------------------------------------ 5393 Function: IsValidDC 5394 Params: DC: a (LCL) devicecontext 5395 Returns: True if valid 5396 5397 Checks if the given DC is valid. 5398 ------------------------------------------------------------------------------} 5399function TGtk2WidgetSet.IsValidDC(const DC: HDC): Boolean; 5400begin 5401 Result := FDeviceContexts.Contains({%H-}Pointer(DC)); 5402end; 5403 5404{------------------------------------------------------------------------------ 5405 Function: IsValidGDIObject 5406 Params: GDIObject: a (LCL) gdiObject 5407 Returns: True if valid 5408 5409 Checks if the given GDIObject is valid (e.g. known to the gtk interface). 5410 This is a quick consistency check to avoid working with dangling pointers. 5411 ------------------------------------------------------------------------------} 5412function TGtk2WidgetSet.IsValidGDIObject(const AGDIObj: HGDIOBJ): Boolean; 5413var 5414 GdiObject: PGdiObject absolute AGDIObj; 5415begin 5416 Result := (AGDIObj <> 0) and FGDIObjects.Contains(GDIObject); 5417end; 5418 5419{------------------------------------------------------------------------------ 5420 Function: IsValidGDIObjectType 5421 Params: GDIObject: a (LCL) gdiObject 5422 GDIType: the requested type 5423 Returns: True if valid 5424 5425 Checks if the given GDIObject is valid and the GDItype is the requested type 5426 ------------------------------------------------------------------------------} 5427function TGtk2WidgetSet.IsValidGDIObjectType( 5428 const GDIObject: HGDIOBJ; const GDIType: TGDIType): Boolean; 5429begin 5430 Result := IsValidGDIObject(GDIObject) 5431 and ({%H-}PGdiObject(GDIObject)^.GDIType = GDIType); 5432end; 5433 5434 5435procedure TGtk2WidgetSet.DCSetAntialiasing(CanvasHandle: HDC; AEnabled: Boolean 5436 ); 5437var 5438 DC: TGtkDeviceContext; 5439begin 5440 if IsValidDC(CanvasHandle) then 5441 begin 5442 //if CanvasHandle = 1 then 5443 //DC := Gtk2DefaultContext 5444 //else 5445 DC := TGtkDeviceContext(CanvasHandle); 5446 DC.Antialiasing := AEnabled; 5447 end; 5448end; 5449 5450 5451{------------------------------------------------------------------------------ 5452 Function: NewDC 5453 Params: none 5454 Returns: a gtkwinapi DeviceContext 5455 5456 Creates a raw DC and adds it to FDeviceContexts. 5457 5458 Used internally by: CreateCompatibleDC, CreateDCForWidget and SaveDC 5459 ------------------------------------------------------------------------------} 5460function TGtk2WidgetSet.NewDC: TGtkDeviceContext; 5461begin 5462 //DebugLn(Format('Trace:> [TGtk2WidgetSet.NewDC]', [])); 5463 5464 if FDCManager = nil 5465 then begin 5466 FDCManager := TDeviceContextMemManager.Create(TGtkDeviceContext); 5467 FDCManager.MinimumFreeCount := 1000; 5468 end; 5469 Result := FDCManager.NewDeviceContext; 5470 {$IFDEF DebugLCLComponents} 5471 DebugDeviceContexts.MarkCreated(Result,'TGtk2WidgetSet.NewDC'); 5472 {$ENDIF} 5473 5474 FDeviceContexts.Add(Result); 5475 5476 {$ifdef TraceGdiCalls} 5477 FillStackAddrs(get_caller_frame(get_frame), @Result.StackAddrs); 5478 {$endif} 5479 //DebugLn(['[TGtk2WidgetSet.NewDC] ',DbgS(Result),' ',FDeviceContexts.Count]); 5480 //DebugLn(Format('Trace:< [TGtk2WidgetSet.NewDC] FDeviceContexts[%d] --> 0x%p', [n, Result])); 5481end; 5482 5483function TGtk2WidgetSet.FindDCWithGDIObject(GDIObject: PGdiObject 5484 ): TGtkDeviceContext; 5485var 5486 HashItem: PDynHashArrayItem; 5487 DC: TGtkDeviceContext; 5488 g: TGDIType; 5489 Cnt: Integer; 5490begin 5491 Result:=nil; 5492 if GdiObject=nil then exit; 5493 HashItem:=FDeviceContexts.FirstHashItem; 5494 Cnt:=0; 5495 while HashItem<>nil do begin 5496 DC:=TGtkDeviceContext(HashItem^.Item); 5497 for g:=Low(TGDIType) to High(TGDIType) do 5498 if DC.GDIObjects[g]=GdiObject then exit(DC); 5499 inc(Cnt); 5500 HashItem:=HashItem^.Next; 5501 end; 5502 if Cnt<>FDeviceContexts.Count then 5503 RaiseGDBException(''); 5504end; 5505 5506{------------------------------------------------------------------------------ 5507 procedure TGtk2WidgetSet.DisposeDC(DC: PDeviceContext); 5508 5509 Disposes a DC 5510 ------------------------------------------------------------------------------} 5511procedure TGtk2WidgetSet.DisposeDC(aDC: TGtkDeviceContext); 5512begin 5513 if not FDeviceContexts.Contains(aDC) then Exit; 5514 5515 FDeviceContexts.Remove(aDC); 5516 5517 {$IFDEF DebugLCLComponents} 5518 DebugDeviceContexts.MarkDestroyed(ADC); 5519 {$ENDIF} 5520 FDCManager.DisposeDeviceContext(ADC); 5521end; 5522 5523{------------------------------------------------------------------------------ 5524 function TGtk2WidgetSet.CreateDCForWidget(TheWidget: PGtkWidget; 5525 TheWindow: PGdkWindow; WithChildWindows: boolean): HDC; 5526 5527 Creates an initial DC 5528 ------------------------------------------------------------------------------} 5529function TGtk2WidgetSet.CreateDCForWidget(AWidget: PGtkWidget; 5530 AWindow: PGdkWindow; AWithChildWindows: Boolean; ADoubleBuffer: PgdkDrawable 5531 ): HDC; 5532var 5533 DC: TGtkDeviceContext absolute Result; 5534begin 5535 DC := NewDC; 5536 DC.SetWidget(AWidget, AWindow, AWithChildWindows, ADoubleBuffer); 5537end; 5538 5539{------------------------------------------------------------------------------ 5540 Function: NewGDIObject 5541 Params: none 5542 Returns: a gtkwinapi DeviceContext 5543 5544 Creates an initial GDIObject of GDIType. 5545 ------------------------------------------------------------------------------} 5546function TGtk2WidgetSet.NewGDIObject(const GDIType: TGDIType): PGdiObject; 5547begin 5548 //DebugLn(Format('Trace:> [TGtk2WidgetSet.NewGDIObject]', [])); 5549 Result:=Gtk2Def.InternalNewPGDIObject; 5550 {$ifdef TraceGdiCalls} 5551 FillStackAddrs(get_caller_frame(get_frame), @Result^.StackAddrs); 5552 {$endif} 5553 Result^.GDIType := GDIType; 5554 Result^.Shared := False; 5555 inc(Result^.RefCount); 5556 FGDIObjects.Add(Result); 5557 //DebugLn('[TGtk2WidgetSet.NewGDIObject] ',DbgS(Result),' ',FGDIObjects.Count); 5558 //DebugLn(Format('Trace:< [TGtk2WidgetSet.NewGDIObject] FGDIObjects --> 0x%p', [Result])); 5559end; 5560 5561{------------------------------------------------------------------------------ 5562 Function: NewGDIObject 5563 Params: GdiObject: PGdiObject 5564 Returns: none 5565 5566 Dispose a GdiObject 5567 ------------------------------------------------------------------------------} 5568procedure TGtk2WidgetSet.DisposeGDIObject(GdiObject: PGdiObject); 5569begin 5570 if FGDIObjects.Contains(GDIObject) then 5571 begin 5572 FGDIObjects.Remove(GDIObject); 5573 Gtk2Def.InternalDisposePGDIObject(GDIObject); 5574 end 5575 else 5576 RaiseGDBException(''); 5577end; 5578 5579function TGtk2WidgetSet.ReleaseGDIObject(GdiObject: PGdiObject): boolean; 5580 5581 procedure RaiseGDIObjectIsStillUsed; 5582 var 5583 CurGDIObject: PGDIObject; 5584 DC: TGtkDeviceContext; 5585 begin 5586 {$ifdef TraceGdiCalls} 5587 DebugLn(); 5588 DebugLn('TGtk2WidgetSet.ReleaseGDIObject: TraceCall for still used object: '); 5589 DumpBackTrace(PgdiObject(GdiObject)^.StackAddrs); 5590 DebugLn(); 5591 DebugLn('Exception will follow:'); 5592 DebugLn(); 5593 {$endif} 5594 // do not raise an exception, because this is a common bug in many programs 5595 // just give a warning 5596 CurGDIObject:=PGdiObject(GdiObject); 5597 debugln('TGtk2WidgetSet.ReleaseGDIObject GdiObject='+dbgs(CurGDIObject) 5598 +' '+dbgs(CurGDIObject^.GDIType) 5599 +' is still used. DCCount='+dbgs(CurGDIObject^.DCCount)); 5600 DC:=FindDCWithGDIObject(CurGDIObject); 5601 if DC<>nil then begin 5602 DebugLn(['DC: ',dbgs(Pointer(DC)),' ', 5603 GetWidgetDebugReport(DC.Widget)]); 5604 end else begin 5605 DebugLn(['No DC found with this GDIObject => either the DCCount is wrong or the DC is not in the DC list']); 5606 end; 5607 //DumpStack; 5608 //RaiseGDBException(''); 5609 end; 5610 5611 procedure RaiseInvalidGDIOwner; 5612 var 5613 o: PGDIObject; 5614 begin 5615 {$ifdef TraceGdiCalls} 5616 DebugLn(); 5617 DebugLn('TGtk2WidgetSet.ReleaseGDIObject: TraceCall for invalid object: '); 5618 DumpBackTrace(PgdiObject(GdiObject)^.StackAddrs); 5619 DebugLn(); 5620 DebugLn('Exception will follow:'); 5621 DebugLn(); 5622 {$endif} 5623 o:=PGdiObject(GdiObject); 5624 RaiseGDBException('TGtk2WidgetSet.ReleaseGDIObject invalid owner of' 5625 +' GdiObject='+dbgs(o) 5626 +' Owner='+dbgs(o^.Owner) 5627 +' Owner.OwnedGDIObjects='+dbgs(o^.Owner.OwnedGDIObjects[o^.GDIType])); 5628 end; 5629 5630begin 5631 if GDIObject = nil then 5632 begin 5633 Result := True; 5634 exit; 5635 end; 5636 {$IFDEF DebugLCLComponents} 5637 if DebugGdiObjects.IsDestroyed(GDIObject) then 5638 begin 5639 DebugLn(['TGtk2WidgetSet.ReleaseGDIObject object already deleted ',GDIObject]); 5640 debugln(DebugGdiObjects.GetInfo(GDIObject,true)); 5641 Halt; 5642 end; 5643 {$ENDIF} 5644 5645 with PGdiObject(GDIObject)^ do 5646 begin 5647 dec(RefCount); 5648 if (RefCount > 0) or Shared then 5649 begin 5650 Result := True; 5651 exit; 5652 end; 5653 if DCCount > 0 then 5654 begin 5655 RaiseGDIObjectIsStillUsed; 5656 exit(False); 5657 end; 5658 5659 if Owner <> nil then 5660 begin 5661 if Owner.OwnedGDIObjects[GDIType] <> PGdiObject(GDIObject) then 5662 RaiseInvalidGDIOwner; 5663 Owner.OwnedGDIObjects[GDIType] := nil; 5664 end; 5665 5666 case GDIType of 5667 gdiFont: 5668 begin 5669 if GDIFontObject <> nil then 5670 begin 5671 //DebugLn(['TGtk2WidgetSet.DeleteObject GDIObject=',dbgs(Pointer(PtrInt(GDIObject))),' GDIFontObject=',dbgs(GDIFontObject)]); 5672 FontCache.Unreference(GDIFontObject); 5673 end; 5674 end; 5675 gdiBrush: 5676 begin 5677 {$IFDEF DebugGDKTraps} 5678 BeginGDKErrorTrap; 5679 {$ENDIF} 5680 {$IFDEF DebugGDIBrush} 5681 debugln('TGtk2WidgetSet.DeleteObject gdiBrush: ',DbgS(GdiObject)); 5682 //if Cardinal(GdiObject)=$404826F4 then RaiseGDBException(''); 5683 {$ENDIF} 5684 if (GDIBrushPixmap <> nil) then 5685 gdk_pixmap_unref(GDIBrushPixmap); 5686 {$IFDEF DebugGDKTraps} 5687 EndGDKErrorTrap; 5688 {$ENDIF} 5689 5690 FreeGDIColor(@GDIBrushColor); 5691 end; 5692 gdiBitmap: 5693 begin 5694 {$IFDEF DebugGDKTraps} 5695 BeginGDKErrorTrap; 5696 {$ENDIF} 5697 case GDIBitmapType of 5698 gbBitmap: 5699 begin 5700 if GDIBitmapObject <> nil then 5701 gdk_bitmap_unref(GDIBitmapObject); 5702 end; 5703 gbPixmap: 5704 begin 5705 if GDIPixmapObject.Image <> nil then 5706 gdk_pixmap_unref(GDIPixmapObject.Image); 5707 if GDIPixmapObject.Mask <> nil then 5708 gdk_bitmap_unref(GDIPixmapObject.Mask); 5709 end; 5710 gbPixbuf: 5711 begin 5712 if GDIPixbufObject <> nil then 5713 gdk_pixbuf_unref(GDIPixbufObject); 5714 end; 5715 end; 5716 5717 if (Visual <> nil) and (not SystemVisual) then 5718 gdk_visual_unref(Visual); 5719 if Colormap <> nil then 5720 gdk_colormap_unref(Colormap); 5721 {$IFDEF DebugGDKTraps} 5722 EndGDKErrorTrap; 5723 {$ENDIF} 5724 end; 5725 gdiPen: 5726 begin 5727 FreeGDIColor(@GDIPenColor); 5728 FreeMem(GDIPenDashes); 5729 end; 5730 gdiRegion: 5731 begin 5732 if (GDIRegionObject <> nil) then 5733 gdk_region_destroy(GDIRegionObject); 5734 end; 5735 gdiPalette: 5736 begin 5737 {$IFDEF DebugGDKTraps} 5738 BeginGDKErrorTrap; 5739 {$ENDIF} 5740 If PaletteVisual <> nil then 5741 gdk_visual_unref(PaletteVisual); 5742 If PaletteColormap <> nil then 5743 gdk_colormap_unref(PaletteColormap); 5744 {$IFDEF DebugGDKTraps} 5745 EndGDKErrorTrap; 5746 {$ENDIF} 5747 5748 FreeAndNil(RGBTable); 5749 FreeAndNil(IndexTable); 5750 end; 5751 else begin 5752 Result:= false; 5753 DebugLn('[TGtk2WidgetSet.DeleteObject] TODO : Unimplemented GDI type'); 5754 //DebugLn('Trace:TODO : Unimplemented GDI object in delete object'); 5755 end; 5756 end; 5757 end; 5758 5759 { Dispose of the GDI object } 5760 //DebugLn('[TGtk2WidgetSet.DeleteObject] ',Result,' ',DbgS(GDIObject,8),' ',FGDIObjects.Count); 5761 DisposeGDIObject(PGDIObject(GDIObject)); 5762end; 5763 5764procedure TGtk2WidgetSet.ReferenceGDIObject(GdiObject: PGdiObject); 5765begin 5766 inc(GdiObject^.RefCount); 5767end; 5768 5769{------------------------------------------------------------------------------ 5770 Function: CreateDefaultBrush 5771 Params: none 5772 Returns: a Brush GDIObject 5773 5774 Creates an default brush, used for initial values 5775 ------------------------------------------------------------------------------} 5776function TGtk2WidgetSet.CreateDefaultBrush: PGdiObject; 5777begin 5778//debugln(' TGtk2WidgetSet.CreateDefaultBrush ->'); 5779 Result := NewGDIObject(gdiBrush); 5780 {$IFDEF DebugGDIBrush} 5781 debugln('TGtk2WidgetSet.CreateDefaultBrush Created: ',DbgS(Result)); 5782 {$ENDIF} 5783 Result^.GDIBrushFill := GDK_SOLID; 5784 Result^.GDIBrushColor.ColorRef := 0; 5785 Result^.GDIBrushColor.Colormap := gdk_colormap_get_system; 5786 gdk_color_white(Result^.GDIBrushColor.Colormap, @Result^.GDIBrushColor.Color); 5787 BuildColorRefFromGDKColor(Result^.GDIBrushColor); 5788end; 5789 5790{------------------------------------------------------------------------------ 5791 Function: CreateDefaultFont 5792 Params: none 5793 Returns: a Font GDIObject 5794 5795 Creates an default font, used for initial values 5796 ------------------------------------------------------------------------------} 5797function TGtk2WidgetSet.CreateDefaultFont: PGdiObject; 5798var 5799 CachedFont: TGtkFontCacheDescriptor; 5800begin 5801 Result := NewGDIObject(gdiFont); 5802 Result^.UntransfFontHeight := 0; 5803 Result^.GDIFontObject:=GetDefaultGtkFont(false); 5804 CachedFont:=FontCache.FindADescriptor(Result^.GDIFontObject); 5805 if CachedFont<>nil then 5806 FontCache.Reference(Result^.GDIFontObject) 5807 else 5808 FontCache.Add(Result^.GDIFontObject,DefaultLogFont,''); 5809end; 5810 5811{------------------------------------------------------------------------------ 5812 Function: CreateDefaultPen 5813 Params: none 5814 Returns: a Pen GDIObject 5815 5816 Creates an default pen, used for initial values 5817 ------------------------------------------------------------------------------} 5818function TGtk2WidgetSet.CreateDefaultPen: PGdiObject; 5819begin 5820 //write(' TGtk2WidgetSet.CreateDefaultPen ->'); 5821 Result := NewGDIObject(gdiPen); 5822 Result^.UnTransfPenWidth := 0; 5823 Result^.GDIPenStyle := PS_SOLID; 5824 Result^.GDIPenColor.ColorRef := 0; 5825 Result^.GDIPenColor.Colormap := gdk_colormap_get_system; 5826 gdk_color_black(Result^.GDIPenColor.Colormap, @Result^.GDIPenColor.Color); 5827 BuildColorRefFromGDKColor(Result^.GDIPenColor); 5828end; 5829 5830function TGtk2WidgetSet.CreateDefaultGDIBitmap: PGdiObject; 5831begin 5832 Result := NewGDIObject(gdiBitmap); 5833end; 5834 5835{------------------------------------------------------------------------------ 5836 procedure TGtk2WidgetSet.UpdateDCTextMetric(DC: TGtkDeviceContext); 5837 5838 Sets the gtk resource file and parses it. 5839 ------------------------------------------------------------------------------} 5840procedure TGtk2WidgetSet.UpdateDCTextMetric(DC: TGtkDeviceContext); 5841const 5842 TestString: array[boolean] of string = ( 5843 // single byte char font 5844 '{ABCDEFGHIJKLMNOPQRSTUVWXYZXYZabcdefghijklmnopqrstuvwxyz|_}', 5845 // double byte char font 5846 #0'{'#0'A'#0'B'#0'C'#0'D'#0'E'#0'F'#0'G'#0'H'#0'I'#0'J'#0'K'#0'L'#0'M'#0'N' 5847 +#0'O'#0'P'#0'Q'#0'R'#0'S'#0'T'#0'U'#0'V'#0'W'#0'X'#0'Y'#0'Z'#0'X'#0'Y'#0'Z' 5848 +#0'a'#0'b'#0'c'#0'd'#0'e'#0'f'#0'g'#0'h'#0'i'#0'j'#0'k'#0'l'#0'm'#0'n'#0'o' 5849 +#0'p'#0'q'#0'r'#0's'#0't'#0'u'#0'v'#0'w'#0'x'#0'y'#0'z'#0'|'#0'_'#0'}' 5850 ); 5851var 5852 UseFont : TGtkIntfFont; 5853 CachedFont: TGtkFontCacheItem; 5854 IsDefault: Boolean; 5855 AWidget: PGtkWidget; 5856 APangoContext: PPangoContext; 5857 APangoLanguage: PPangoLanguage; 5858 Desc: TGtkFontCacheDescriptor; 5859 APangoFontDescription: PPangoFontDescription; 5860 APangoMetrics: PPangoFontMetrics; 5861 aRect: TPangoRectangle; 5862begin 5863 with TGtkDeviceContext(DC) do begin 5864 if dcfTextMetricsValid in Flags then begin 5865 // cache valid 5866 exit; 5867 end; 5868 UseFont:=GetGtkFont(TGtkDeviceContext(DC)); 5869 FillChar(DCTextMetric, SizeOf(DCTextMetric), 0); 5870 CachedFont:=FontCache.FindGTKFont(UseFont); 5871 IsDefault:=UseFont = GetDefaultGtkFont(false); 5872 if (CachedFont=nil) and (not IsDefault) then begin 5873 DebugLn(['TGtk2WidgetSet.UpdateDCTextMetric no CachedFont UseFont=',dbgs(UseFont)]); 5874 DumpStack; 5875 end; 5876 //DebugLn(['TGtk2WidgetSet.UpdateDCTextMetric IsDefault=',UseFont = GetDefaultGtkFont(false)]); 5877 5878 if (CachedFont<>nil) and (CachedFont.MetricsValid) then begin 5879 DCTextMetric.lBearing:=CachedFont.lBearing; 5880 DCTextMetric.rBearing:=CachedFont.rBearing; 5881 DCTextMetric.IsDoubleByteChar:=CachedFont.IsDoubleByteChar; 5882 DCTextMetric.IsMonoSpace:=CachedFont.IsMonoSpace; 5883 DCTextMetric.TextMetric:=CachedFont.TextMetric; 5884 end 5885 else with DCTextMetric do begin 5886 IsDoubleByteChar:=FontIsDoubleByteCharsFont(UseFont); 5887 IsMonoSpace:=FontIsMonoSpaceFont(UseFont); 5888 5889 // get pango context (= association to a widget) 5890 AWidget:=Widget; 5891 if AWidget=nil then 5892 AWidget:=GetStyleWidget(lgsLabel); 5893 APangoContext := gtk_widget_get_pango_context(AWidget); 5894 if APangoContext=nil then 5895 DebugLn(['TGtk2WidgetSet.UpdateDCTextMetric WARNING: no pango context']); 5896 // get pango language (e.g. de_DE) 5897 APangoLanguage := pango_context_get_language(APangoContext); 5898 if APangoLanguage=nil then 5899 DebugLn(['TGtk2WidgetSet.UpdateDCTextMetric WARNING: no pango language']); 5900 // get pango font description (e.g. 'sans 12') 5901 APangoFontDescription := nil; 5902 if (not IsDefault) and (CachedFont<>nil) then begin 5903 Desc:=FontCache.FindADescriptor(UseFont); 5904 if Desc<>nil then 5905 APangoFontDescription := Desc.PangoFontDescription; 5906 //DebugLn(['TGtk2WidgetSet.UpdateDCTextMetric CachedFont Desc.PangoFontDescription=',GetPangoDescriptionReport(APangoFontDescription),' Desc.LongFontName=',Desc.LongFontName]); 5907 end; 5908 if APangoFontDescription=nil then 5909 APangoFontDescription:=pango_context_get_font_description(APangoContext); 5910 if APangoFontDescription=nil then 5911 APangoFontDescription:=GetDefaultFontDesc(false); 5912 if APangoFontDescription=nil then 5913 DebugLn(['TGtk2WidgetSet.UpdateDCTextMetric WARNING: no pango font description']); 5914 //DebugLn(['TGtk2WidgetSet.UpdateDCTextMetric APangoFontDescription=',GetPangoDescriptionReport(APangoFontDescription)]); 5915 // get pango metrics (e.g. ascent, descent) 5916 APangoMetrics := pango_context_get_metrics(APangoContext, 5917 APangoFontDescription, APangoLanguage); 5918 if APangoMetrics=nil then 5919 DebugLn(['TGtk2WidgetSet.UpdateDCTextMetric WARNING: no pango metrics']); 5920 5921 TextMetric.tmAveCharWidth := Max(1, 5922 pango_font_metrics_get_approximate_char_width(APangoMetrics) 5923 div PANGO_SCALE); 5924 TextMetric.tmAscent := pango_font_metrics_get_ascent(APangoMetrics) div PANGO_SCALE; 5925 TextMetric.tmDescent := pango_font_metrics_get_descent(APangoMetrics) div PANGO_SCALE; 5926 TextMetric.tmHeight := TextMetric.tmAscent+TextMetric.tmDescent; 5927 5928 pango_layout_set_text(UseFont, PChar(TestString[IsDoubleByteChar]), 5929 length(PChar(TestString[IsDoubleByteChar]))); 5930 pango_layout_get_extents(UseFont, nil, @aRect); 5931 5932 lBearing := PANGO_LBEARING(aRect) div PANGO_SCALE; 5933 rBearing := PANGO_RBEARING(aRect) div PANGO_SCALE; 5934 5935 pango_layout_set_text(UseFont, 'M', 1); 5936 pango_layout_get_pixel_size(UseFont, @aRect.width, @aRect.height); 5937 TextMetric.tmMaxCharWidth := Max(1,aRect.width); 5938 pango_layout_set_text(UseFont, 'W', 1); 5939 pango_layout_get_pixel_size(UseFont, @aRect.width, @aRect.height); 5940 TextMetric.tmMaxCharWidth := Max(TextMetric.tmMaxCharWidth,aRect.width); 5941 5942 pango_font_metrics_unref(APangoMetrics); 5943 5944 (*debugln('TGtk2WidgetSet.UpdateDCTextMetric A IsDoubleByteChar=',dbgs(IsDoubleByteChar), 5945 ' lbearing=',dbgs(lBearing),' rbearing=',dbgs(rBearing), 5946 ' tmAscent='+dbgs(TextMetric.tmAscent), 5947 ' tmDescent='+dbgs(TextMetric.tmdescent), 5948 ' tmHeight='+dbgs(TextMetric.tmHeight), 5949 ' tmMaxCharWidth='+dbgs(TextMetric.tmMaxCharWidth), 5950 ' tmAveCharWidth='+dbgs(TextMetric.tmAveCharWidth));*) 5951 if (CachedFont<>nil) then begin 5952 CachedFont.lBearing:=lBearing; 5953 CachedFont.rBearing:=rBearing; 5954 CachedFont.IsDoubleByteChar:=IsDoubleByteChar; 5955 CachedFont.IsMonoSpace:=IsMonoSpace; 5956 CachedFont.TextMetric:=TextMetric; 5957 CachedFont.MetricsValid:=true; 5958 end; 5959 end; 5960 Flags := Flags + [dcfTextMetricsValid]; 5961 end; 5962end; 5963 5964{------------------------------------------------------------------------------ 5965 function TGtk2WidgetSet.GetDefaultFontDesc(IncreaseReferenceCount: boolean 5966 ): PPangoFontDescription; 5967 ------------------------------------------------------------------------------} 5968function TGtk2WidgetSet.GetDefaultFontDesc(IncreaseReferenceCount: boolean 5969 ): PPangoFontDescription; 5970begin 5971 if FDefaultFontDesc = nil then begin 5972 FDefaultFontDesc:=LoadDefaultFontDesc; 5973 if FDefaultFontDesc = nil then 5974 raise EOutOfResources.Create(rsUnableToLoadDefaultFont); 5975 end; 5976 Result:=FDefaultFontDesc; 5977 if IncreaseReferenceCount then 5978 Result := pango_font_description_copy(Result); 5979end; 5980 5981{------------------------------------------------------------------------------ 5982 function TGtk2WidgetSet.GetDefaultGtkFont(IncreaseReferenceCount: boolean 5983 ): TGtkIntfFont; 5984 ------------------------------------------------------------------------------} 5985function TGtk2WidgetSet.GetDefaultGtkFont(IncreaseReferenceCount: boolean 5986 ): TGtkIntfFont; 5987begin 5988 if FDefaultFont = nil then begin 5989 FDefaultFont:=LoadDefaultFont; 5990 if FDefaultFont = nil then 5991 raise EOutOfResources.Create(rsUnableToLoadDefaultFont); 5992 ReferenceGtkIntfFont(FDefaultFont); // mark as used globally 5993 end; 5994 Result:=FDefaultFont; 5995 if IncreaseReferenceCount then 5996 ReferenceGtkIntfFont(Result); // mark again 5997end; 5998 5999function TGtk2WidgetSet.GetGtkFont(DC: TGtkDeviceContext): TGtkIntfFont; 6000begin 6001 // create font if needed 6002 Result:=DC.GetFont^.GDIFontObject; 6003end; 6004 6005function TGtk2WidgetSet.CreateRegionCopy(SrcRGN: hRGN): hRGN; 6006var 6007 GDIObject: PGDIObject; 6008begin 6009 GDIObject := NewGDIObject(gdiRegion); 6010 GDIObject^.GDIRegionObject:=gdk_region_copy({%H-}PGdiObject(SrcRGN)^.GDIRegionObject); 6011 Result := hRgn({%H-}PtrUInt(GDIObject)); 6012end; 6013 6014function TGtk2WidgetSet.DCClipRegionValid(DC: HDC): boolean; 6015var 6016 CurClipRegion: hRGN; 6017begin 6018 Result:=false; 6019 if not IsValidDC(DC) then exit; 6020 CurClipRegion:=HRGN({%H-}PtrUInt(TGtkDeviceContext(DC).ClipRegion)); 6021 if (CurClipRegion<>0) and (not IsValidGDIObject(CurClipRegion)) then exit; 6022 Result:=true; 6023end; 6024 6025function TGtk2WidgetSet.CreateEmptyRegion: hRGN; 6026var 6027 GObject: PGdiObject; 6028begin 6029 GObject := NewGDIObject(gdiRegion); 6030 GObject^.GDIRegionObject := gdk_region_new; 6031 Result := HRGN({%H-}PtrUInt(GObject)); 6032 //DebugLn('TGtk2WidgetSet.CreateEmptyRgn A RGN=',DbgS(Result)); 6033end; 6034 6035{------------------------------------------------------------------------------ 6036 Function: SetRCFilename 6037 Params: const AValue: string 6038 Returns: none 6039 6040 Sets the gtk resource file and parses it. 6041 ------------------------------------------------------------------------------} 6042procedure TGtk2WidgetSet.SetRCFilename(const AValue: string); 6043begin 6044 if (FRCFilename=AValue) then exit; 6045 FRCFilename:=AValue; 6046 FRCFileParsed:=false; 6047 ParseRCFile; 6048end; 6049 6050{------------------------------------------------------------------------------ 6051 procedure TGtk2WidgetSet.CheckRCFilename; 6052 6053 Sets the gtk resource file and parses it. 6054 ------------------------------------------------------------------------------} 6055procedure TGtk2WidgetSet.CheckRCFilename; 6056begin 6057 if FRCFileParsed and (FRCFilename<>'') and FileExistsUTF8(FRCFilename) 6058 and (FileAgeUTF8(FRCFilename)<>FRCFileAge) then 6059 FRCFileParsed:=false; 6060end; 6061 6062{------------------------------------------------------------------------------ 6063 Function: ParseRCFile 6064 Params: const AValue: string 6065 Returns: none 6066 6067 Sets the gtk resource file and parses it. 6068 ------------------------------------------------------------------------------} 6069procedure TGtk2WidgetSet.ParseRCFile; 6070begin 6071 if (not FRCFileParsed) 6072 and (FRCFilename<>'') and FileExistsUTF8(FRCFilename) then 6073 begin 6074 gtk_rc_parse(PChar(FRCFilename)); 6075 FRCFileParsed:=true; 6076 FRCFileAge:=FileAgeUTF8(FRCFilename); 6077 end; 6078end; 6079 6080{------------------------------------------------------------------------------ 6081 Function: SetClipboardWidget 6082 Params: TargetWidget: PGtkWidget - This widget will be connected to all 6083 clipboard signals which are all handled by the TGtkWidgetSet 6084 itself. 6085 Returns: none 6086 6087 All supported targets are added to the new widget. This way, no one, 6088 especially not the lcl, will notice the change. ;) 6089 ------------------------------------------------------------------------------} 6090procedure TGtk2WidgetSet.SetClipboardWidget(TargetWidget: PGtkWidget); 6091{$IFDEF DEBUG_CLIPBOARD} 6092type 6093 TGtkTargetSelectionList = record 6094 Selection: Cardinal; 6095 List: PGtkTargetList; 6096 end; 6097 PGtkTargetSelectionList = ^TGtkTargetSelectionList; 6098{$ENDIF} 6099const 6100 gtk_selection_handler_key: PChar = 'gtk-selection-handlers'; 6101 6102 {$IFDEF DEBUG_CLIPBOARD} 6103 function gtk_selection_target_list_get(Widget: PGtkWidget; 6104 ClipboardType: TClipboardType): PGtkTargetList; 6105 var 6106 SelectionLists, CurSelList: PGList; 6107 TargetSelList: PGtkTargetSelectionList; 6108 begin 6109 SelectionLists := g_object_get_data (PGObject(Widget), 6110 gtk_selection_handler_key); 6111 CurSelList := SelectionLists; 6112 while (CurSelList<>nil) do begin 6113 TargetSelList := CurSelList^.Data; 6114 if (TargetSelList^.Selection = ClipboardTypeAtoms[ClipboardType]) then 6115 begin 6116 Result:=TargetSelList^.List; 6117 exit; 6118 end; 6119 CurSelList := CurSelList^.Next; 6120 end; 6121 Result:=nil; 6122 end; 6123 6124 procedure WriteTargetLists(Widget: PGtkWidget); 6125 var c: TClipboardType; 6126 TargetList: PGtkTargetList; 6127 TmpList: PGList; 6128 Pair: PGtkTargetPair; 6129 begin 6130 DebugLn(' WriteTargetLists WWW START'); 6131 for c:=Low(TClipboardType) to High(TClipboardType) do begin 6132 TargetList:=gtk_selection_target_list_get(Widget,c); 6133 DebugLn(' WriteTargetLists WWW ',ClipboardTypeName[c],' ',dbgs(TargetList<>nil)); 6134 if TargetList<>nil then begin 6135 TmpList:=TargetList^.List; 6136 while TmpList<>nil do begin 6137 Pair:=PGtkTargetPair(TmpList^.Data); 6138 DebugLn(' WriteTargetLists BBB ',dbgs(Pair^.Target),' ',GdkAtomToStr(Pair^.Target)); 6139 TmpList:=TmpList^.Next; 6140 end; 6141 end; 6142 end; 6143 DebugLn(' WriteTargetLists WWW END'); 6144 end; 6145 {$ENDIF} 6146 6147 procedure ClearTargetLists(Widget: PGtkWidget); 6148 // MG: Reading in gtk internals is dirty, but there seems to be no other way 6149 // to clear the old target lists 6150 var 6151 SelectionLists: PGList; 6152 CurClipboard: TClipboardType; 6153 begin 6154 {$IFDEF DEBUG_CLIPBOARD} 6155 DebugLn(' ClearTargetLists WWW START'); 6156 {$ENDIF} 6157 // clear 3 selections 6158 for CurClipboard := Low(TClipboardType) to High(CurClipboard) do 6159 gtk_selection_clear_targets(Widget, ClipboardTypeAtoms[CurClipboard]); 6160 6161 SelectionLists := g_object_get_data(PGObject(Widget), 6162 gtk_selection_handler_key); 6163 if SelectionLists <> nil then 6164 g_list_free(SelectionLists); 6165 g_object_set_data (PGObject(Widget), gtk_selection_handler_key, GtkNil); 6166 {$IFDEF DEBUG_CLIPBOARD} 6167 DebugLn(' ClearTargetLists WWW END'); 6168 {$ENDIF} 6169 end; 6170 6171var c: TClipboardType; 6172begin 6173 if ClipboardWidget=TargetWidget then exit; 6174 {$IFDEF DEBUG_CLIPBOARD} 6175 DebugLn('[TGtk2WidgetSet.SetClipboardWidget] ',dbgs(ClipboardWidget<>nil),' -> ',dbgs(TargetWidget<>nil),' ',GetWidgetDebugReport(TargetWidget)); 6176 {$ENDIF} 6177 if ClipboardWidget<>nil then begin 6178 {$IFDEF DEBUG_CLIPBOARD} 6179 WriteTargetLists(ClipboardWidget); 6180 {$ENDIF} 6181 ClearTargetLists(ClipboardWidget); 6182 {$IFDEF DEBUG_CLIPBOARD} 6183 WriteTargetLists(ClipboardWidget); 6184 {$ENDIF} 6185 end; 6186 6187 ClipboardWidget:=TargetWidget; 6188 if ClipboardWidget<>nil then begin 6189 // connect widget to all clipboard signals 6190 g_signal_connect(PGtkObject(ClipboardWidget),'selection_received', 6191 TGTKSignalFunc(@ClipboardSelectionReceivedHandler),GtkNil); 6192 g_signal_connect(PGtkObject(ClipboardWidget),'selection_get', 6193 TGTKSignalFunc(@ClipboardSelectionRequestHandler),GtkNil); 6194 g_signal_connect(PGtkObject(ClipboardWidget),'selection_clear_event', 6195 TGTKSignalFunc(@ClipboardSelectionLostOwnershipHandler),GtkNil); 6196 // add all supported targets for all clipboard types 6197 for c:=Low(TClipboardType) to High(TClipboardType) do begin 6198 if (ClipboardTargetEntries[c]<>nil) then begin 6199 //DebugLn('TGtk2WidgetSet.SetClipboardWidget ',GdkAtomToStr(ClipboardTypeAtoms[c]),' Entries=',dbgs(ClipboardTargetEntryCnt[c])); 6200 gtk_selection_add_targets(ClipboardWidget,ClipboardTypeAtoms[c], 6201 ClipboardTargetEntries[c],ClipboardTargetEntryCnt[c]); 6202 end; 6203 end; 6204 {$IFDEF DEBUG_CLIPBOARD} 6205 WriteTargetLists(ClipboardWidget); 6206 {$ENDIF} 6207 end; 6208end; 6209 6210{------------------------------------------------------------------------------ 6211 procedure TGtk2WidgetSet.WordWrap(AText: PChar; MaxWidthInPixel: integer; 6212 var Lines: PPChar; var LineCount: integer); virtual; 6213 6214 Breaks AText into several lines and creates a list of PChar. The last entry 6215 will be nil. 6216 Lines break at new line chars and at spaces if a line is longer than 6217 MaxWidthInPixel or in a word. 6218 Lines will be one memory block so that you can free the list and all lines 6219 with FreeMem(Lines). 6220------------------------------------------------------------------------------} 6221procedure TGtk2WidgetSet.WordWrap(DC: HDC; AText: PChar; 6222 MaxWidthInPixel: integer; out Lines: PPChar; out LineCount: integer); 6223var 6224 UseFont: TGtkIntfFont; 6225 6226 function GetLineWidthInPixel(LineStart, LineLen: integer): integer; 6227 var 6228 width: LongInt; 6229 begin 6230 GetTextExtentIgnoringAmpersands(UseFont, @AText[LineStart], LineLen, 6231 nil, nil, @width, nil, nil); 6232 Result:=Width; 6233 end; 6234 6235 function FindLineEnd(LineStart: integer): integer; 6236 var 6237 CharLen, 6238 LineStop, 6239 LineWidth, WordWidth, WordEnd, CharWidth: integer; 6240 begin 6241 // first search line break or text break 6242 Result:=LineStart; 6243 while not (AText[Result] in [#0,#10,#13]) do inc(Result); 6244 if Result<=LineStart+1 then exit; 6245 lineStop:=Result; 6246 6247 // get current line width in pixel 6248 LineWidth:=GetLineWidthInPixel(LineStart,Result-LineStart); 6249 if LineWidth>MaxWidthInPixel then begin 6250 // line too long 6251 // -> add words till line size reached 6252 LineWidth:=0; 6253 WordEnd:=LineStart; 6254 WordWidth:=0; 6255 repeat 6256 Result:=WordEnd; 6257 inc(LineWidth,WordWidth); 6258 // find word start 6259 while AText[WordEnd] in [' ',#9] do inc(WordEnd); 6260 // find word end 6261 while not (AText[WordEnd] in [#0,' ',#9,#10,#13]) do inc(WordEnd); 6262 // calculate word width 6263 WordWidth:=GetLineWidthInPixel(Result,WordEnd-Result); 6264 until LineWidth+WordWidth>MaxWidthInPixel; 6265 if LineWidth=0 then begin 6266 // the first word is longer than the maximum width 6267 // -> add chars till line size reached 6268 Result:=LineStart; 6269 LineWidth:=0; 6270 repeat 6271 charLen:=UTF8CodepointSize(@AText[result]); 6272 CharWidth:=GetLineWidthInPixel(Result,charLen); 6273 inc(LineWidth,CharWidth); 6274 if LineWidth>MaxWidthInPixel then break; 6275 if result>=lineStop then break; 6276 inc(Result,charLen); 6277 until false; 6278 // at least one char 6279 if Result=LineStart then begin 6280 charLen:=UTF8CodepointSize(@AText[result]); 6281 inc(Result,charLen); 6282 end; 6283 end; 6284 end; 6285 end; 6286 6287 function IsEmptyText: boolean; 6288 begin 6289 if (AText=nil) or (AText[0]=#0) then begin 6290 // no text 6291 GetMem(Lines,SizeOf(PChar)); 6292 Lines[0]:=nil; 6293 LineCount:=0; 6294 Result:=true; 6295 end else 6296 Result:=false; 6297 end; 6298 6299 procedure InitFont; 6300 begin 6301 UseFont:=GetGtkFont(TGtkDeviceContext(DC)); 6302 end; 6303 6304var 6305 LinesList: TIntegerList; 6306 LineStart, LineEnd, LineLen: integer; 6307 ArraySize, TotalSize: integer; 6308 i: integer; 6309 CurLineEntry: PPChar; 6310 CurLineStart: PChar; 6311begin 6312 if IsEmptyText then begin 6313 Lines:=nil; 6314 LineCount:=0; 6315 exit; 6316 end; 6317 InitFont; 6318 LinesList:=TIntegerList.Create; 6319 LineStart:=0; 6320 6321 // find all line starts and line ends 6322 repeat 6323 LinesList.Add(LineStart); 6324 // find line end 6325 LineEnd:=FindLineEnd(LineStart); 6326 LinesList.Add(LineEnd); 6327 // find next line start 6328 LineStart:=LineEnd; 6329 if AText[LineStart] in [#10,#13] then begin 6330 // skip new line chars 6331 inc(LineStart); 6332 if (AText[LineStart] in [#10,#13]) 6333 and (AText[LineStart]<>AText[LineStart-1]) then 6334 inc(LineStart); 6335 end else if AText[LineStart] in [' ',#9] then begin 6336 // skip space 6337 while AText[LineStart] in [' ',#9] do 6338 inc(LineStart); 6339 end; 6340 until AText[LineStart]=#0; 6341 6342 // create mem block for 'Lines': array of PChar + all lines 6343 LineCount:=LinesList.Count shr 1; 6344 ArraySize:=(LineCount+1)*SizeOf(PChar); 6345 TotalSize:=ArraySize; 6346 i:=0; 6347 while i<LinesList.Count do begin 6348 // add LineEnd - LineStart + 1 for the #0 6349 LineLen:=LinesList[i+1]-LinesList[i]+1; 6350 inc(TotalSize,LineLen); 6351 inc(i,2); 6352 end; 6353 GetMem(Lines,TotalSize); 6354 FillChar(Lines^,TotalSize,0); 6355 6356 // create Lines 6357 CurLineEntry:=Lines; 6358 CurLineStart:=PChar(CurLineEntry)+ArraySize; 6359 i:=0; 6360 while i<LinesList.Count do begin 6361 // set the pointer to the start of the current line 6362 CurLineEntry[i shr 1]:=CurLineStart; 6363 // copy the line 6364 LineStart:=LinesList[i]; 6365 LineEnd:=LinesList[i+1]; 6366 LineLen:=LineEnd-LineStart; 6367 if LineLen>0 then 6368 Move(AText[LineStart],CurLineStart^,LineLen); 6369 inc(CurLineStart,LineLen); 6370 // add #0 as line end 6371 CurLineStart^:=#0; 6372 inc(CurLineStart); 6373 // next line 6374 inc(i,2); 6375 end; 6376 if {%H-}PtrUInt(CurLineStart)-{%H-}PtrUInt(Lines)<>TotalSize then 6377 RaiseGDBException('TGtk2WidgetSet.WordWrap Consistency Error:' 6378 +' Lines+TotalSize<>CurLineStart'); 6379 CurLineEntry[i shr 1]:=nil; 6380 6381 LinesList.Free; 6382end; 6383 6384function TGtk2WidgetSet.ForceLineBreaks(DC: hDC; Src: PChar; 6385 MaxWidthInPixels: Longint; 6386 ConvertAmpersandsToUnderScores: Boolean) : PChar; 6387var 6388 Lines : PPChar; 6389 I, NumLines : Longint; 6390 TmpStr : PGString; 6391 Line : PgChar; 6392begin 6393 TmpStr := nil; 6394 WordWrap(DC, Src, MaxWidthInPixels, Lines, NumLines); 6395 For I := 0 to NumLines - 1 do begin 6396 If TmpStr <> nil then 6397 g_string_append_c(TmpStr, #10); 6398 6399 If ConvertAmpersandsToUnderScores then begin 6400 Line := Ampersands2Underscore(Lines[I]); 6401 If Line <> nil then begin 6402 If TmpStr <> nil then begin 6403 g_string_append(TmpStr, Line); 6404 end 6405 else 6406 TmpStr := g_string_new(Line); 6407 StrDispose(Line); 6408 end; 6409 end 6410 else begin 6411 If Lines[I] <> nil then 6412 If TmpStr <> nil then 6413 g_string_append(TmpStr, Lines[I]) 6414 else 6415 TmpStr := g_string_new(Lines[I]); 6416 end; 6417 end; 6418 ReallocMem(Lines, 0); 6419 If TmpStr <> nil then 6420 begin 6421 Result := StrNew(TmpStr^.str); 6422 g_string_free(TmpStr, True); 6423 end 6424 else 6425 Result:=nil; 6426end; 6427 6428{$IFDEF ASSERT_IS_ON} 6429 {$UNDEF ASSERT_IS_ON} 6430 {$C-} 6431{$ENDIF} 6432