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