{%MainUnit gtk2proc.pp} { ***************************************************************************** * * * This file is part of the Lazarus Component Library (LCL) * * * * See the file COPYING.modifiedLGPL.txt, included in this distribution, * * for details about the copyright. * * * * This program is distributed in the hope that it will be useful, * * but WITHOUT ANY WARRANTY; without even the implied warranty of * * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. * * * ***************************************************************************** } function DoDeliverPaintMessage(const Target: TObject; var PaintMsg: TLMPaint): PtrInt; var WidgetInfo: PWidgetInfo; begin { erase backgound of custom controls use only for real custom controls for gtk1 - that are GTKAPIWidget } if (TObject(Target) is TCustomControl) then begin Include(TWinControlAccess(Target).FWinControlFlags, wcfEraseBackground); TWinControl(Target).Perform(LM_ERASEBKGND, PtrInt(PaintMsg.DC), 0); Exclude(TWinControlAccess(Target).FWinControlFlags, wcfEraseBackground); end; Result := DeliverMessage(Target, PaintMsg); if (TObject(Target) is TCustomControl) then begin WidgetInfo := GetWidgetInfo(PGtkWidget(TCustomControl(Target).Handle), False); if WidgetInfo <> nil then WidgetInfo^.UpdateRect := Rect(0,0,0,0); end; end; function DeliverPaintMessage(const Target: Pointer; var TheMessage): GBoolean; var PaintMsg: TLMPaint; begin if TLMessage(TheMessage).Msg = LM_GTKPAINT then PaintMsg := GtkPaintMessageToPaintMessage(TLMGtkPaint(TheMessage), True) else PaintMsg := TLMPaint(TheMessage); Result := DoDeliverPaintMessage(TObject(Target), PaintMsg) = 0; FinalizePaintMessage(PLMessage(@PaintMsg)); end; {------------------------------------------------------------------------------- function DeliverPostMessage(const Target: Pointer; var TheMessage): GBoolean; 'TheMessage' is in TLMessage format. Don't confuse this with tagMsg. --------------------------------------------------------------------------------} function DeliverPostMessage(const Target: Pointer; var TheMessage): GBoolean; begin if TObject(Target) is TWinControl then begin // convert TLMessage into a tagMsg and push on the message queue Result := PostMessage(TWinControl(Target).Handle, TLMessage(TheMessage).Msg, TLMessage(TheMessage).WParam, TLMessage(TheMessage).LParam ); end else begin if TLMessage(TheMessage).Msg <> LM_GTKPAINT then Result := DeliverMessage(Target, TheMessage) = 0 else Result := DeliverPaintMessage(Target, TheMessage); end; end; function DeliverGtkPaintMessage(Target: Pointer; Widget: PGtkWidget; Area: PGDKRectangle; RepaintAll, IsAfterGtk: boolean): GBoolean; var Msg: TLMGtkPaint; begin //DebugLn(['DeliverGtkPaintMessage ',DbgSName(TObject(Target)),' Widget=',GetWidgetDebugReport(Widget),' RepaintAll=',RepaintAll,' AfterGtk=',IsAfterGtk,' Area=',dbgs(Area)]); // default is, that a control receives the paint message after gtk (including the child paints) // In case of TCustomControl, there is no gtk painting only the // child paintings. Let the TCustomControl paint the background. // ToDo: Eventually there must be a 'before paint message'. if IsAfterGtk then begin if TObject(Target) is TCustomControl then exit(false); end else begin if not (TObject(Target) is TCustomControl) then exit(false); end; if (not RepaintAll) and ((Area^.Width<1) or (Area^.Height<1)) then exit(false); Msg.Msg := LM_GTKPAINT; Msg.Data := TLMGtkPaintData.Create; Msg.Data.Widget := Widget; Msg.Data.State := GtkPaint_LCLWidget; Msg.Data.Rect := Bounds(Area^.x, Area^.y, Area^.Width, Area^.Height); Msg.Data.RepaintAll := RepaintAll; // the gtk2 has a working double buffering and expose event area Result := DeliverPaintMessage(Target, Msg); end; procedure EventTrace(const TheMessage : string; data : pointer); begin if Data = nil then Assert(False, Format('Trace:Event [%s] fired',[Themessage])) else Assert(False, Format('Trace:Event [%s] fired for %s', [TheMessage, TObject(data).Classname])); end; {*************************************************************} { callback routines } {*************************************************************} {------------------------------------------------------------------------------- function gtkNoteBookCloseBtnClicked Params: Widget: PGtkWidget; Data: Pointer Result: GBoolean gtkNoteBookCloseBtnClicked is called by the gtk, whenever a close button in the tab of a notebook page is clicked. -------------------------------------------------------------------------------} function gtkNoteBookCloseBtnClicked(Widget: PGtkWidget; Data: Pointer): GBoolean; cdecl; var APage: TCustomPage; begin Result:=true; // handled = true if Widget=nil then ; if ComponentIsDestroyingHandle(TWinControl(Data)) then exit; APage:=TCustomPage(Data); TCustomNoteBook(APage.Parent).DoCloseTabClicked(APage); end; function FilterFuc(xevent: PGdkXEvent; event: PGdkEvent; data: gpointer): TGdkFilterReturn; cdecl; var AForm: TCustomForm absolute data; begin Result := GDK_FILTER_CONTINUE; {$ifdef windows} if (PMSG(xevent)^.message = WM_NCLBUTTONDOWN) and (PMSG(xevent)^.wParam = HTCAPTION) and not (csDesigning in AForm.ComponentState) and (TWinControlAccess(TWinControl(AForm)).DragKind = dkDock) and (TWinControlAccess(TWinControl(AForm)).DragMode = dmAutomatic) then begin AForm.BeginDrag(True); Result := GDK_FILTER_REMOVE; end; {$endif} end; {------------------------------------------------------------------------------- function GTKRealizeCB Params: Widget: PGtkWidget; Data: Pointer Result: GBoolean GTKRealizeCB is called by the gtk, whenever a widget is realized (ie mapped), but before the widget itself gets the realize signal. That means that the gdk window on the xserver has been created. -------------------------------------------------------------------------------} function gtkRealizeCB(Widget: PGtkWidget; Data: Pointer): GBoolean; cdecl; var decor,Func : Longint; TheWindow: PGdkWindow; TheForm: TCustomForm; begin Result := CallBackDefaultReturn; {$IFDEF EventTrace} EventTrace('realize', nil); {$ENDIF} if (Data<>nil) then begin if TObject(Data) is TCustomForm then begin TheForm:=TCustomForm(Data); if TheForm.Parent=nil then begin TheWindow:=gtk_widget_get_toplevel(Widget)^.window; //apart from none and sizeable, this will //only work if WM supports motif flags //properly, which very few actually do. Decor := GetWindowDecorations(TheForm); Func := GetWindowFunction(TheForm); gdk_window_set_decorations(TheWindow, decor); gdk_window_set_functions(TheWindow, func); {$ifdef windows} // for drag/dock gdk_window_add_filter(TheWindow, @FilterFuc, TheForm) {$endif} end; end; if (csDesigning in TComponent(Data).ComponentState) then begin //DebugLn(['gtkRealizeCB ',dbgsName(TComponent(Data)),' ',GetWidgetDebugReport(Widget)]); end else begin RealizeAccelerator(TComponent(Data),Widget); end; end; end; {------------------------------------------------------------------------------- function GTKRealizeAfterCB Params: Widget: PGtkWidget; Data: Pointer Result: GBoolean GTKRealizeAfterCB is called by the gtk, whenever a widget is realized (ie mapped), and after the widget itself got the realize signal. That means that the gdk window on the xserver has been created and the widget initialized the gdkwindow. This function is used for the second part of the initialization of a widget. -------------------------------------------------------------------------------} function gtkRealizeAfterCB(Widget: PGtkWidget; Data: Pointer): GBoolean; cdecl; var WinWidgetInfo: PWidgetInfo; HiddenLCLObject, LCLObject: TObject; NewEventMask: TGdkEventMask; TheWinControl: TWinControl; ClientWidget: PGtkWidget; MainWidget: PGtkWidget; begin Result := CallBackDefaultReturn; //DebugLn(['gtkRealizeAfterCB ',GetWidgetDebugReport(Widget)]); if Data=nil then ; {$IFDEF EventTrace} EventTrace('realizeafter', nil); {$ENDIF} HiddenLCLObject:=GetHiddenLCLObject(Widget); if HiddenLCLObject=nil then begin // this is a normal lcl wigdet MainWidget:=GetMainWidget(Widget); if MainWidget=nil then MainWidget:=Widget; WinWidgetInfo:=GetWidgetInfo(MainWidget,true); LCLObject:=GetLCLObject(MainWidget); if (LCLObject<>nil) and (WinWidgetInfo<>nil) then begin ClientWidget:=GetFixedWidget(Widget); if (LCLObject is TWinControl) then TheWinControl:=TWinControl(LCLObject) else TheWinControl:=nil; // set extra signal masks after the widget window is created // define extra events we're interrested in //write('GTKRealizeAfterCB '); //if TheWinControl<>nil then DbgOut(' ',TheWinControl.Name,':',TheWinControl.ClassName,' ',DbgS(TheWinControl.Handle)); //DebugLn(' Widget=',DbgS(Widget),' Fixed=',DbgS(GetFixedWidget(Widget)),' Main=',DbgS(GetMainWidget(Widget))); if (TheWinControl<>nil) then begin //DebugLn(['gtkRealizeAfterCB ',GetWidgetDebugReport(Widget)]); {$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF} NewEventMask:=gdk_window_get_events(GetControlWindow(Widget)) or WinWidgetInfo^.EventMask; gtk_widget_add_events(Widget,NewEventMask); gdk_window_set_events(GetControlWindow(Widget),NewEventMask); if (ClientWidget<>nil) and (GetControlWindow(ClientWidget)<>nil) and (GetControlWindow(ClientWidget)<>GetControlWindow(Widget)) then begin //DebugLn(['gtkRealizeAfterCB ClientWindow<>Window']); NewEventMask:=gdk_window_get_events(GetControlWindow(ClientWidget)) or WinWidgetInfo^.EventMask; gtk_widget_add_events(ClientWidget,WinWidgetInfo^.EventMask); gdk_window_set_events(GetControlWindow(ClientWidget),NewEventMask); end; //DebugLn('BBB1 ',DbgS(NewEventMask),8),' ',DbgS(Cardinal(gdk_window_get_events(Widget^.Window))); {$IFDEF DebugGDK}EndGDKErrorTrap;{$ENDIF} end; if TheWinControl<>nil then begin TheWinControl.CNPreferredSizeChanged; TGtkPrivateWidgetClass(TheWinControl.WidgetSetClass.WSPrivate).UpdateCursor(WinWidgetInfo); ConnectInternalWidgetsSignals(MainWidget,TheWinControl); if TheWinControl is TCustomPage then UpdateNotebookPageTab(nil,TheWinControl); if TheWinControl is TCustomForm then SetFormShowInTaskbar(TCustomForm(TheWinControl), TCustomForm(TheWinControl).ShowInTaskbar); end; end; end else begin // this is a hidden child widget of a lcl widget if HiddenLCLObject is TWinControl then ConnectInternalWidgetsSignals(Widget,TWinControl(HiddenLCLObject)); end; end; function gtkshowCB( widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var Mess : TLMShowWindow; begin Result := True; {$IFDEF EventTrace} EventTrace('show', data); {$ENDIF} if Widget=nil then ; FillChar(Mess,SizeOf(Mess),0); Mess.Msg := LM_SHOWWINDOW; Mess.Show := True; Result := DeliverMessage(Data, Mess) = 0; end; function gtkHideCB( widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var Mess : TLMShowWindow; begin Result := True; {$IFDEF EventTrace} EventTrace('hide', data); {$ENDIF} if Widget=nil then ; FillChar(Mess,SizeOf(Mess),0); Mess.Msg := LM_SHOWWINDOW; Mess.Show := False; Result := DeliverMessage(Data, Mess) = 0; end; function gtkactivateCB(widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var Mess: TLMActivate; begin Result:= True; {$IFDEF EventTrace} EventTrace('activate', data); {$ENDIF} ResetDefaultIMContext; if LockOnChange(PgtkObject(Widget),0) > 0 then Exit; FillChar(Mess,SizeOf(Mess),#0); Mess.Msg := LM_ACTIVATE; Mess.Active:=true; Mess.Minimized:=false; Mess.ActiveWindow:=0; if GtkWidgetIsA(Widget, gtk_window_get_type) then Mess.ActiveWindow:=HWnd(PtrUInt(PGTKWindow(Widget)^.focus_widget)); Mess.Result := 0; //DebugLn('gtkactivateCB ',DbgSName(TObject(Data))); DeliverMessage(Data, Mess); Result := CallBackDefaultReturn; end; function GTKCheckMenuToggeledCB(AMenuItem: PGTKCheckMenuItem; AData: gPointer): GBoolean; cdecl; // AData --> LCLMenuItem var LCLMenuItem: TMenuItem; begin Result := CallBackDefaultReturn; {$IFDEF EventTrace} EventTrace('toggled', AData); {$ENDIF} LCLMenuItem := TMenuItem(AData); // some sanity checks if LCLMenuItem = nil then Exit; if not LCLMenuItem.IsCheckItem then Exit; // ??? // the gtk always toggles the check flag // -> restore 'checked' flag if needed if gtk_check_menu_item_get_active(AMenuItem) = LCLMenuItem.Checked then Exit; if LCLMenuItem.AutoCheck then Exit; // restore it LockOnChange(PgtkObject(AMenuItem), +1); gtk_check_menu_item_set_active(AMenuItem, LCLMenuItem.Checked); LockOnChange(PgtkObject(AMenuItem), -1); end; function gtkchangedCB( widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var Mess : TLMessage; begin Result := CallBackDefaultReturn; if ComponentIsDestroyingHandle(TWinControl(Data)) or (LockOnChange(PgtkObject(Widget),0)>0) then exit; {$IFDEF EventTrace} EventTrace('changed', data); {$ENDIF} FillChar(Mess, SizeOf(Mess), 0); Mess.Msg := LM_CHANGED; DeliverMessage(Data, Mess); end; function gtkchanged_editbox( widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var Mess : TLMessage; GStart, GEnd: gint; Info: PWidgetInfo; EntryText: PgChar; NeedCursorCheck: Boolean; begin Result := CallBackDefaultReturn; if LockOnChange(PgtkObject(Widget),0)>0 then exit; {$IFDEF EventTrace} EventTrace('changed_editbox', data); {$ENDIF} NeedCursorCheck := False; if GTK_IS_ENTRY(Widget) then begin {cheat GtkEditable to update cursor pos in gtkEntry. issue #7243} gtk_editable_get_selection_bounds(PGtkEditable(Widget), @GStart, @GEnd); EntryText := gtk_entry_get_text(PGtkEntry(Widget)); if (GStart = GEnd) and (UTF8Length(EntryText) >= PGtkEntry(Widget)^.text_length) then begin Info := GetWidgetInfo(Widget, False); {do not update position if backspace or delete pressed} if wwiInvalidEvent in Info^.Flags then exclude(Info^.Flags, wwiInvalidEvent) else begin // if we change selstart in OnChange event new cursor pos need to // be postponed in TGtk2WSCustomEdit.SetSelStart NeedCursorCheck := True; gtk_editable_set_position(PGtkEditable(Widget), GStart + 1); end; end; end; if NeedCursorCheck then LockOnChange(PgtkObject(Widget), +1); FillByte(Mess,SizeOf(Mess),0); Mess.Msg := CM_TEXTCHANGED; DeliverMessage(Data, Mess); if NeedCursorCheck then LockOnChange(PgtkObject(Widget), -1); end; function gtkchanged_spinbox(widget: PGtkWidget; data: gPointer): GBoolean; cdecl; begin Result := CallBackDefaultReturn; if LockOnChange(PgtkObject(Widget),0) > 0 then exit; if GTK_IS_SPIN_BUTTON(Widget) then gtk_spin_button_update(PGtkSpinButton(Widget)); end; function gtkchanged_editbox_backspace(widget: PGtkWidget; data: gPointer): GBoolean; cdecl; var GStart, GEnd: gint; Info: PWidgetInfo; EntryText: PgChar; begin Result := CallBackDefaultReturn; if GTK_IS_ENTRY(Widget) then begin gtk_editable_get_selection_bounds(PGtkEditable(Widget), @GStart, @GEnd); EntryText := gtk_entry_get_text(PGtkEntry(Widget)); if (GStart = GEnd) and (GStart > 0) and (UTF8Length(EntryText) = PGtkEntry(Widget)^.text_length) then begin {mark as invalid event for gtkchanged_editbox, so it doesn't update cursor pos or we have a mess.} if (gtk_major_version = 2) and (gtk_minor_version < 17) then begin Info := GetWidgetInfo(Widget, False); include(Info^.Flags, wwiInvalidEvent); end; PGtkEntry(Widget)^.current_pos := GStart - 1; end; end; end; function gtkchanged_editbox_delete(widget: PGtkWidget; AType: TGtkDeleteType; APos: gint; data: gPointer): GBoolean; cdecl; var Info: PWidgetInfo; begin Result := CallBackDefaultReturn; Info := GetWidgetInfo(Widget, False); include(Info^.Flags, wwiInvalidEvent); end; function gtkdaychanged(Widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var MSG: TLMessage; begin Result := CallBackDefaultReturn; if LockOnChange(PgtkObject(Widget),0)>0 then exit; EventTrace('day changed', data); MSG.Msg := LM_DAYCHANGED; DeliverPostMessage(Data, MSG); Result := CallBackDefaultReturn; end; function gtktoggledCB( widget: PGtkWidget; data: gPointer): GBoolean; cdecl; var Mess : TLMessage; procedure ChangeCheckbox(AGrayed,AChecked: boolean); begin LockOnChange(PgtkObject(Widget),1); gtk_toggle_button_set_Inconsistent(PGtkToggleButton(Widget), AGrayed); gtk_toggle_button_set_active(PGtkToggleButton(Widget), AChecked); LockOnChange(PgtkObject(Widget),-1); end; begin //DebugLn('gtktoggledCB ',DbgSName(TObject(Data))); Result := CallBackDefaultReturn; {$IFDEF EventTrace} EventTrace('toggled', data); {$ENDIF} if LockOnChange(PgtkObject(Widget),0) > 0 then Exit; if GtkWidgetIsA(Widget,gtk_toggle_button_get_type) then begin if TObject(Data) is TCustomCheckbox then begin if gtk_toggle_button_get_inconsistent(PGtkToggleButton(Widget)) then ChangeCheckbox(false, true) else if TCustomCheckbox(Data).AllowGrayed and gtk_toggle_button_get_active(PGtkToggleButton(Widget)) then ChangeCheckbox(true, false); end; end; Mess.Msg := LM_CHANGED; Mess.Result := 0; DeliverMessage(Data, Mess); //DebugLn('gtktoggledCB END ',DbgSName(TObject(Data))); end; function gtkExposeEvent(Widget: PGtkWidget; Event : PGDKEventExpose; Data: gPointer): GBoolean; cdecl; var DesignOnlySignal: boolean; begin Result := CallBackDefaultReturn; {$IFDEF EventTrace} EventTrace('ExposeAfter', data); {$ENDIF} //DebugLn(['gtkExposeEvent ',GetWidgetDebugReport(Widget),' Event^.Count=',Event^.Count]); if (Event^.Count > 0) then exit; if not (csDesigning in TComponent(Data).ComponentState) then begin DesignOnlySignal:=GetDesignOnlySignalFlag(Widget,dstExposeAfter); if DesignOnlySignal then exit; end else begin {$IFDEF VerboseDesignerDraw} DebugLn('gtkExpose', ' Widget=',DbgS(Widget),'=',GetWidgetClassName(Widget), ' ',TComponent(Data).Name, ' ',dbgs(Event^.area.x),',',dbgs(Event^.area.y),',',dbgs(Event^.area.width),',',dbgs(Event^.area.height), ''); {$ENDIF} end; //DebugLn(['gtkExposeEvent ',GetWidgetDebugReport(Widget),' ',dbgGRect(@Event^.Area)]); DeliverGtkPaintMessage(Data, Widget, @Event^.Area, False, False); end; function gtkExposeEventAfter(Widget: PGtkWidget; Event : PGDKEventExpose; Data: gPointer): GBoolean; cdecl; var DesignOnlySignal: boolean; //children: PGList; begin Result := CallBackDefaultReturn; {$IFDEF EventTrace} EventTrace('ExposeAfter', data); {$ENDIF} //DebugLn(['gtkExposeEventAfter ',GetWidgetDebugReport(Widget),' Event^.Count=',Event^.Count]); if (Event^.Count > 0) then exit; if not (csDesigning in TComponent(Data).ComponentState) then begin DesignOnlySignal:=GetDesignOnlySignalFlag(Widget,dstExposeAfter); if DesignOnlySignal then exit; end else begin {$IFDEF VerboseDesignerDraw} DebugLn('gtkExposeAfter', ' Widget=',DbgS(Widget),'=',GetWidgetClassName(Widget), ' ',TComponent(Data).Name, ' ',dbgs(Event^.area.x),',',dbgs(Event^.area.y),',',dbgs(Event^.area.width),',',dbgs(Event^.area.height), ''); {$ENDIF} end; //DebugLn(['gtkExposeEventAfter ',GetWidgetDebugReport(Widget),' ',dbgGRect(@Event^.Area)]); DeliverGtkPaintMessage(Data,Widget,@Event^.Area,false,true); // Some widgets in gtk2 don't have their own exclusive "windows" so a synthetic event must be sent // MG: That is already done by the gtk2. For which widgets does this not work? // Enabling this results in double painting, which is slower and // wrong for anitaliased text. {if GTK_IS_FIXED(Widget) then begin children := gtk_container_get_children(PGtkContainer(Widget)); while children <> nil do begin if (children^.data <> nil) then begin if GTK_WIDGET_NO_WINDOW(PGtkWidget(children^.data)) then gtk_container_propagate_expose(PGtkContainer(Widget), PGtkWidget(children^.data), Event); if children^.next = nil then break; children := children^.next; end; end; g_list_free(children); end;} end; function gtkfrmactivateAfter(widget: PGtkWidget; Event : PgdkEventFocus; data: gPointer) : GBoolean; cdecl; var Mess: TLMActivate; Info: PWidgetInfo; {$IFDEF VerboseFocus} LCLObject: TObject; CurFocusWidget: PGtkWidget; {$ENDIF} begin {$IFDEF EventTrace} EventTrace('activate after', data); {$ENDIF} if (Widget=nil) or (Event=nil) then ; ResetDefaultIMContext; UpdateMouseCaptureControl; FillChar(Mess,SizeOf(Mess),#0); {$IFDEF VerboseFocus} write('gtkfrmactivateAfter Widget=',DbgS(Widget),' Event^.theIn=',Event^._in); LCLObject:=TObject(data); if LCLObject<>nil then begin if LCLObject is TComponent then begin write(' LCLObject=',TComponent(LCLObject).Name,':',LCLObject.ClassName) end else begin write(' LCLObject=',LCLObject.ClassName) end; end else write(' LCLObject=nil'); DebugLn(''); DbgOut(' '); CurFocusWidget:=PGtkWidget(GetFocus); if CurFocusWidget<>nil then begin write(' GetFocus=',DbgS(CurFocusWidget)); LCLObject:=GetNearestLCLObject(CurFocusWidget); if LCLObject<>nil then begin if LCLObject is TComponent then begin DbgOut(' ParentLCLFocus=',TComponent(LCLObject).Name,':',LCLObject.ClassName) end else begin DbgOut(' ParentLCLFocus=',LCLObject.ClassName) end; end else DbgOut(' LCLObject=nil'); end else begin DbgOut(' GetFocus=nil'); end; DebugLn(''); {$ENDIF} Info := GetWidgetInfo(Widget, false); try if (Info <> nil) then Include(Info^.Flags, wwiActivating); Mess.Msg := LM_ACTIVATE; Mess.Active := True; Mess.Minimized := False; Mess.ActiveWindow := 0; if GtkWidgetIsA(Widget, gtk_window_get_type) then Mess.ActiveWindow := HWnd(PtrUInt(PGTKWindow(Widget)^.focus_widget)); Mess.Result := 0; DeliverMessage(Data, Mess); // send message directly (not Post) finally if Info <> nil then Exclude(Info^.Flags, wwiActivating); end; Result := CallBackDefaultReturn; end; function gtkfrmdeactivateAfter( widget: PGtkWidget; Event : PgdkEventFocus; data: gPointer) : GBoolean; cdecl; var Mess: TLMActivate; Info: PWidgetInfo; {$IFDEF VerboseFocus} LCLObject: TControl; {$ENDIF} begin {$IFDEF EventTrace} EventTrace('deactivate after', data); {$ENDIF} if (Widget=nil) or (Event=nil) then ; {$IFDEF VerboseFocus} write('gtkfrmdeactivate Widget=',DbgS(Widget),' ',Event^._in, ' GetFocus=',DbgS(Widget)); LCLObject:=TControl(GetLCLObject(Widget)); if LCLObject<>nil then DebugLn(' LCLObject=',LCLObject.Name,':',LCLObject.ClassName) else DebugLn(' LCLObject=nil'); {$ENDIF} ResetDefaultIMContext; UpdateMouseCaptureControl; Info:=GetWidgetInfo(Widget,false); try if (Info<>nil) then Include(Info^.Flags,wwiDeactivating); Mess.Msg := LM_DEACTIVATE; DeliverMessage(Data, Mess); finally if Info<>nil then Exclude(Info^.Flags,wwiDeactivating); end; Result := CallBackDefaultReturn; end; function GTKMap(Widget: PGTKWidget; Data: gPointer): GBoolean; cdecl; begin Result := CallBackDefaultReturn; if (Widget=nil) then ; EventTrace('map', data); end; function GTKKeyPress(Widget: PGtkWidget; Event: PGdkEventKey; Data: gPointer) : GBoolean; cdecl; begin Result := HandleGtkKeyUpDown(Widget,Event,Data,true,True,'key-press-event'); end; function GTKKeyPressAfter(Widget: PGtkWidget; Event: pgdkeventkey; Data: gPointer): GBoolean; cdecl; begin Result := HandleGtkKeyUpDown(Widget,Event,Data,false,True,'key-press-event'); end; function GTKKeyRelease(Widget: PGtkWidget; Event: PGdkEventKey; Data: gPointer) : GBoolean; cdecl; begin Result := HandleGtkKeyUpDown(Widget,Event,Data,true,False,'key-release-event'); end; function GTKKeyReleaseAfter(Widget: PGtkWidget; Event: pgdkeventkey; Data: gPointer): GBoolean; cdecl; begin Result := HandleGtkKeyUpDown(Widget,Event,Data,false,False,'key-release-event'); end; function GTKFocusCB(widget: PGtkWidget; event: PGdkEventFocus; data: gPointer): GBoolean; cdecl; var Mess : TLMessage; LCLObject: TObject; AForm: TCustomForm; {$IFDEF VerboseFocus} CurFocusWidget: PGtkWidget; {$ENDIF} begin {$IFDEF EventTrace} EventTrace('focus', data); {$ENDIF} if (Widget=nil) or (Event=nil) then ; //DebugLn('GTKFocusCBAfter ',DbgSName(TObject(Data)),' ',GetWidgetDebugReport(Widget)); LCLObject:=TObject(data); {$IFDEF VerboseFocus} write('GTKFocusCBAfter Widget=',DbgS(Widget),' Event^.theIn=',Event^._in); if LCLObject<>nil then begin if LCLObject is TComponent then begin write(' LCLObject=',TComponent(LCLObject).Name,':',LCLObject.ClassName) end else begin write(' LCLObject=',LCLObject.ClassName) end; end else write(' LCLObject=nil'); DebugLn(''); DbgOut(' '); CurFocusWidget:=PGtkWidget(GetFocus); if CurFocusWidget<>nil then begin write(' GetFocus=',DbgS(CurFocusWidget)); LCLObject:=GetNearestLCLObject(CurFocusWidget); if LCLObject<>nil then begin if LCLObject is TComponent then begin write(' ParentLCLFocus=',TComponent(LCLObject).Name,':',LCLObject.ClassName) end else begin write(' ParentLCLFocus=',LCLObject.ClassName); {$IFDEF VerboseSizeMsg} DebugLn(['GTKWindowStateEventCB ',DbgSName(TheForm), ' GTK=',GtkWidth,'x',GtkHeight, ' LCL=',TheForm.Width,'x',TheForm.Height, ' SizeType=',SizeMsg.SizeType-Size_SourceIsInterface,'+Size_SourceIsInterface' ]); {$ENDIF} // DeliverMessage(TheForm, SizeMsg); end; end else write(' LCLObject=nil'); end else begin write(' GetFocus=nil'); end; DebugLn(''); {$ENDIF} if LCLObject is TCustomForm then begin // a form became active // it does not mean: the control focus is switch to the form AForm:=TCustomForm(LCLObject); //debugln(['GTKFocusCBAfter ',DbgSName(AForm),' ',DbgSName(AForm.ActiveControl)]); // the PGtkWindow(Data)^.focus_widget shows the last focus call for this // window. If there is a sub window (e.g. docking), then the focus_widget // of the parent window was not updated, so it can not be used. // The gtk will use, if we let it, which will not follow the LCL focus logic. // Follow the LCL logic: if AForm.ActiveControl<>nil then begin Data:=AForm.ActiveControl; //debugln(['GTKFocusCBAfter ',DbgSName(LCLObject),' send=',event^.send_event,' window=',dbgs(event^.window),' in=',event^._in,' type=',event^._type,' Data=',dbgsname(TObject(Data))]); end; end; ResetDefaultIMContext; UpdateMouseCaptureControl; //TODO: fill in old focus FillChar(Mess, SizeOf(Mess), 0); Mess.msg := LM_SETFOCUS; DeliverMessage(Data, Mess); Result := CallBackDefaultReturn; end; function GTKKillFocusCB(widget: PGtkWidget; event:PGdkEventFocus; data: gPointer) : GBoolean; cdecl; {$IFDEF VerboseFocus} var LCLObject: TObject; CurFocusWidget: PGtkWidget; {$ENDIF} begin {$IFDEF EventTrace} EventTrace('killfocusCB', data); {$ENDIF} if (Widget=nil) or (Event=nil) then ; //DebugLn('GTKKillFocusCB ',DbgSName(TObject(Data)),' ',GetWidgetDebugReport(Widget)); {$IFDEF VerboseFocus} write('GTKillFocusCB Widget=',DbgS(Widget),' Event^.theIn=',Event^._in); LCLObject:=TObject(data); if LCLObject<>nil then begin if LCLObject is TComponent then begin write(' LCLObject=',TComponent(LCLObject).Name,':',LCLObject.ClassName) end else begin write(' LCLObject=',LCLObject.ClassName) end; end else write(' LCLObject=nil'); DebugLn(''); DbgOut(' '); CurFocusWidget:=PGtkWidget(GetFocus); if CurFocusWidget<>nil then begin write(' GetFocus=',DbgS(CurFocusWidget)); LCLObject:=GetNearestLCLObject(CurFocusWidget); if LCLObject<>nil then begin if LCLObject is TComponent then begin write(' ParentLCLFocus=',TComponent(LCLObject).Name,':',LCLObject.ClassName) end else begin write(' ParentLCLFocus=',LCLObject.ClassName) end; end else write(' LCLObject=nil'); end else begin write(' GetFocus=nil'); end; DebugLn(''); {$ENDIF} // do not release capture widget here, as this will interfere //ReleaseCaptureWidget(Widget); Result:=CallBackDefaultReturn; end; function GTKKillFocusCBAfter(widget: PGtkWidget; event:PGdkEventFocus; data: gPointer) : GBoolean; cdecl; var Mess : TLMessage; {$IFDEF VerboseFocus} LCLObject: TObject; CurFocusWidget: PGtkWidget; {$ENDIF} begin if (Widget=nil) or (Event=nil) then ; {$IFDEF EventTrace} EventTrace('killfocusCBAfter', data); {$ENDIF} //DebugLn('GTKKillFocusCBAfter ',DbgSName(TObject(Data)),' ',GetWidgetDebugReport(Widget)); {$IFDEF VerboseFocus} write('GTKillFocusCBAfter Widget=',DbgS(Widget),' Event^.theIn=',Event^._in); LCLObject:=TObject(data); if LCLObject<>nil then begin if LCLObject is TComponent then begin write(' LCLObject=',TComponent(LCLObject).Name,':',LCLObject.ClassName) end else begin write(' LCLObject=',LCLObject.ClassName) end; end else write(' LCLObject=nil'); DebugLn(''); DbgOut(' '); CurFocusWidget:=PGtkWidget(GetFocus); if CurFocusWidget<>nil then begin write(' GetFocus=',DbgS(CurFocusWidget)); LCLObject:=GetNearestLCLObject(CurFocusWidget); if LCLObject<>nil then begin if LCLObject is TComponent then begin write(' ParentLCLFocus=',TComponent(LCLObject).Name,':',LCLObject.ClassName) end else begin write(' ParentLCLFocus=',LCLObject.ClassName) end; end else write(' LCLObject=nil'); end else begin write(' GetFocus=nil'); end; DebugLn(''); {$ENDIF} ResetDefaultIMContext; UpdateMouseCaptureControl; FillChar(Mess,SizeOf(Mess),0); Mess.msg := LM_KILLFOCUS; // do not release the capture widget here //TODO: fill in new focus Assert(False, Format('Trace:TODO: [gtkkillfocusCB] %s finish', [TObject(Data).ClassName])); DeliverMessage(Data, Mess); Result:=true; end; function GTKWindowStateEventCB(widget: PGtkWidget; state: PGdkEventWindowState; data: gpointer): gboolean; cdecl; var TheForm: TCustomForm; SizeMsg: TLMSize; GtkWidth: LongInt; GtkHeight: LongInt; {$IFDEF HasX} NetAtom: TGdkAtom; AtomType: TGdkAtom; AIndex, ADesktop: pguint; AFormat: gint; ALength: gint; {$ENDIF} begin Result := CallBackDefaultReturn; // if iconified in changed then OnIconify... if GTK_WIDGET_REALIZED(Widget) then begin if (GDK_WINDOW_STATE_WITHDRAWN and state^.changed_mask) = 1 then // visibility changed - this is another message block exit; if TObject(Data) is TCustomForm then begin TheForm := TCustomForm(Data); //DebugLn(['GTKWindowStateEventCB ',DbgSName(TheForm),' new_window_state=',state^.new_window_state,' changed_mask=',state^.changed_mask]); if TheForm.Parent = nil then begin // toplevel window // send a WMSize Message (see TCustomForm.WMSize) // ToDo: this might be too early to use the Widget^.Allocation // Either send this message later or find a better way to determine the size (including the client area) GtkWidth:=Widget^.Allocation.Width; if GtkWidth<0 then GtkWidth:=0; GtkHeight:=Widget^.Allocation.Height; if GtkHeight<0 then GtkHeight:=0; //debugln('GTKWindowStateEventCB ',DbgSName(TObject(Data)),' ',dbgs(state^.new_window_state),' ',WidgetFlagsToString(Widget)); if ((GDK_WINDOW_STATE_ICONIFIED and state^.new_window_state)>0) then begin if (TheForm = Application.MainForm) and (TheForm.WindowState <> wsMinimized) then Application.IntfAppMinimize; {$IFDEF HasX} NetAtom := gdk_atom_intern('_NET_WM_DESKTOP', True); if NetAtom > 0 then begin if gdk_property_get(Widget^.window, NetAtom, XA_CARDINAL, 0, 4, 0, @AtomType, @AFormat, @ALength, @AIndex) then begin NetAtom := gdk_atom_intern('_NET_CURRENT_DESKTOP', True); if gdk_property_get(gdk_get_default_root_window, NetAtom, XA_CARDINAL,0, 4, 0, @AtomType, @AFormat, @ALength, @ADesktop) then if ADesktop^ <> AIndex^ then begin // form is not on active desktop => ignore g_free(ADesktop); g_free(AIndex); exit; end else begin g_free(ADesktop); g_free(AIndex); end; end; end; {$ENDIF} SizeMsg.SizeType := SIZEICONIC; end else if (GDK_WINDOW_STATE_MAXIMIZED and state^.new_window_state)>0 then begin // it can be both maximized + iconified and just loose iconified state if (state^.changed_mask and (GDK_WINDOW_STATE_MAXIMIZED or GDK_WINDOW_STATE_ICONIFIED)) = 0 then Exit; SizeMsg.SizeType := SIZEFULLSCREEN; end else SizeMsg.SizeType := SIZENORMAL; if (TheForm = Application.MainForm) and (SizeMsg.SizeType <> SIZEICONIC) and (TheForm.WindowState = wsMinimized) then Application.IntfAppRestore; // don't bother the LCL if nothing changed case SizeMsg.SizeType of SIZENORMAL: if TheForm.WindowState=wsNormal then exit; SIZEICONIC: if TheForm.WindowState=wsMinimized then exit; SIZEFULLSCREEN: if TheForm.WindowState=wsMaximized then exit; end; with SizeMsg do begin Result := 0; Msg := LM_SIZE; SizeType := SizeType+Size_SourceIsInterface; Width := SmallInt(GtkWidth); Height := SmallInt(GtkHeight); end; {$IFDEF VerboseSizeMsg} DebugLn(['GTKWindowStateEventCB ',DbgSName(TheForm), ' GTK=',GtkWidth,'x',GtkHeight, ' LCL=',TheForm.Width,'x',TheForm.Height, ' SizeType=',SizeMsg.SizeType-Size_SourceIsInterface,'+Size_SourceIsInterface' ]); {$ENDIF} DeliverMessage(TheForm, SizeMsg); if (gtk_major_version = 2) and (gtk_minor_version <= 8) and (TheForm.WindowState = wsMaximized) then gtk_widget_queue_draw(PGtkWidget(TheForm.Handle)); end; end; end; end; function gtkdestroyCB(widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var Mess: TLMessage; Info: PWidgetInfo; begin Result := CallBackDefaultReturn; //DebugLn(['gtkdestroyCB ',GetWidgetDebugReport(Widget)]); Info:=GetWidgetInfo(Widget,false); if Info = nil then // this widget is already destroyed Exit; if (Data = nil) or (Info^.LCLObject <> TObject(Data)) then // this LCLObject does not use this widget anymore Exit; if (TObject(Data) is TWinControl) then begin if (not TWinControl(Data).HandleAllocated) then begin FreeWidgetInfo(Widget); Exit; end else if (PGtkWidget(TWinControl(Data).Handle) <> Widget) then // the TWinControl does not use this widget anymore. Exit; end; {$IFDEF EventTrace} EventTrace('destroyCB', data); {$ENDIF} //DebugLn('gtkdestroyCB Data="',DbgSName(TObject(Data)),'" LCLObject="',DbgSName(Info^.LCLObject),'" ',GetWidgetDebugReport(Widget)); FillChar(Mess, SizeOf(Mess), 0); Mess.msg := LM_DESTROY; DeliverMessage(Data, Mess); // NOTE: if the destroy message is posted // we should post an info destroy message as well FreeWidgetInfo(Widget); end; procedure DestroyWindowFromPointCB(Widget: PGtkWidget; data: gPointer); cdecl; begin if PGtkWidget(LastWFPResult) <> Widget then Exit; LastWFPResult := 0; LastWFPMousePos := Point(High(Integer), High(Integer)); end; function gtkdeleteCB( widget : PGtkWidget; event : PGdkEvent; data : gPointer) : GBoolean; cdecl; var Mess : TLMessage; begin FillChar(Mess,SizeOf(Mess),0); if (Widget=nil) or (Event=nil) then ; Mess.Msg:= LM_CLOSEQUERY; { Message results : True - do nothing, False - destroy or hide window } Result:= DeliverMessage(Data, Mess) = 0; end; function gtkresizeCB( widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; //var // Mess : TLMessage; begin Result := CallBackDefaultReturn; if (Widget=nil) then ; {$IFDEF EventTrace} EventTrace('resize', data); {$ENDIF} // Mess.msg := LM_RESIZE; // TControl(data).WindowProc(TLMessage(Mess)); Assert(False, 'Trace:TODO: [gtkresizeCB] fix (or remove) to new LM_SIZE'); //TObject(data).Dispatch(Mess); end; function gtkMonthChanged(Widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var Mess: TLMessage; begin Result := CallBackDefaultReturn; if (Widget=nil) then ; {$IFDEF EventTrace} EventTrace('month changed', data); {$ENDIF} FillChar(Mess,SizeOf(Mess),0); Mess.Msg := LM_MONTHCHANGED; DeliverPostMessage(Data, Mess); Result := CallBackDefaultReturn; end; {------------------------------------------------------------------------------- procedure DeliverMouseMoveMessage(Widget:PGTKWidget; Event: PGDKEventMotion; AWinControl: TWinControl); Translate a gdk mouse motion event into a LCL mouse move message and send it. Mouse coordinate mapping: Why mapping: An lcl control can consists of several gtk widgets, and any message to them is send to the lcl control. The gtk sends the coordinates relative to the emitting gdkwindow (not relative to the gtkwidget). And the area of a lcl control can belong to several gdkwindows. Therefore the mouse coordinates must be mapped. What the lcl expects: For Delphi compatibility the mouse coordinates must be relative to the client area of the control. That means for example if the mouse is over the top-left pixel of the client widget (mostly a gtkfixed widget), then 0,0 is send. If the mouse is on the top-left pixel of the container widget then the coordinates can be negative, if there is frame around the client area. -------------------------------------------------------------------------------} procedure DeliverMouseMoveMessage(Widget: PGTKWidget; Event: PGDKEventMotion; AWinControl: TWinControl); var Msg: TLMMouseMove; ShiftState: TShiftState; MappedXY: TPoint; begin MappedXY := TranslateGdkPointToClientArea(Event^.Window, Point(TruncToInt(Event^.X), TruncToInt(Event^.Y)), PGtkWidget(AWinControl.Handle)); MappedXY := SubtractScoll(PGtkWidget(AWinControl.Handle), MappedXY); ShiftState := GTKEventStateToShiftState(Event^.State); with Msg do begin Msg := LM_MouseMove; XPos := MappedXY.X; YPos := MappedXY.Y; Keys := ShiftStateToKeys(ShiftState); Result := 0; end; // send the message directly to the LCL // (Posting the message via queue // has the risk of getting out of sync with the gtk) NotifyApplicationUserInput(Msg.Msg); //DebugLn(['DeliverMouseMoveMessage ',dbgsName(AWinControl)]); DeliverMessage(AWinControl, Msg); end; {------------------------------------------------------------------------------- function ControlGetsMouseMoveBefore(AControl: TControl): boolean; Returns true, if mouse move event should be sent before the widget istelf reacts. -------------------------------------------------------------------------------} function ControlGetsMouseMoveBefore(AControl: TControl): boolean; begin if (AControl=nil) then ; // currently there are no controls, that need after events. Result:=true; end; procedure GTKGetDevicePointer(win: PGdkWindow; dev: PGdkDevice; x, y: pgdouble; mask: PGdkModifierType); var axes: pgdouble; i: Integer; begin axes := g_new(SizeOf(gdouble), dev^.num_axes); gdk_device_get_state(dev, win, axes, mask); for i := 0 to dev^.num_axes - 1 do if (x^ <> 0) and (dev^.axes[i].use = GDK_AXIS_X) then x^ := axes[i] else if (y^ <> 0) and (dev^.axes[i].use = GDK_AXIS_Y) then y^ := axes[i]; g_free(axes); end; {------------------------------------------------------------------------------- GTKMotionNotify Params: widget: PGTKWidget; event: PGDKEventMotion; data: gPointer Returns: GBoolean Called whenever the mouse is moved over a widget. The gtk event is translated into a lcl MouseMove message. -------------------------------------------------------------------------------} function gtkMotionNotify(Widget:PGTKWidget; Event: PGDKEventMotion; Data: gPointer): GBoolean; cdecl; var DesignOnlySignal: boolean; ShiftState: TShiftState; begin Result := CallBackDefaultReturn; if (Event^.is_hint <> 0) and (Event^._type = GDK_MOTION_NOTIFY) then GTKGetDevicePointer(Event^.window, Event^.device, @Event^.x, @Event^.y, @Event^.state); {$IFDEF VerboseMouseBugfix} DesignOnlySignal:=GetDesignOnlySignalFlag(Widget,dstMouseMotion); DebugLn('[GTKMotionNotify] ', DbgSName(TControl(Data)), ' Widget=',DbgS(Widget), ' DSO=',dbgs(DesignOnlySignal), ' Event^.X=',dbgs(TruncToInt(Event^.X)),' Event^.Y=',dbgs(TruncToInt(Event^.Y)) ); {$ENDIF} UpdateMouseCaptureControl; ShiftState := GTKEventStateToShiftState(Event^.State); if (MouseCaptureWidget = Widget) and (MouseCaptureType = mctGTK) and ([ssLeft,ssRight,ssMiddle]*ShiftState=[]) then begin {$IFDEF VerboseMouseCapture} DebugLn(['gtkMotionNotify gtk capture without mouse down: ',GetWidgetDebugReport(Widget)]); {$ENDIF} end; if not (csDesigning in TComponent(Data).ComponentState) then begin DesignOnlySignal := GetDesignOnlySignalFlag(Widget, dstMouseMotion); if DesignOnlySignal then exit; if not ControlGetsMouseMoveBefore(TControl(Data)) then exit; end else begin // stop the signal, so that the widget does not auto react g_signal_stop_emission_by_name(PGTKObject(Widget), 'motion-notify-event'); Result := CallBackDefaultReturn; // why not True if we want to stop it? end; DeliverMouseMoveMessage(Widget,Event,TWinControl(Data)); if TControl(Data).FCompStyle = csWinControl then Result := True; // stop signal end; {------------------------------------------------------------------------------- GTKMotionNotifyAfter Params: widget: PGTKWidget; event: PGDKEventMotion; data: gPointer Returns: GBoolean Called whenever the mouse is moved over a widget as last handler. -------------------------------------------------------------------------------} function GTKMotionNotifyAfter(widget:PGTKWidget; event: PGDKEventMotion; data: gPointer): GBoolean; cdecl; begin Result := true; // stop event propagation if (Event^.is_hint <> 0) and (Event^._type = GDK_MOTION_NOTIFY) then GTKGetDevicePointer(Event^.window, Event^.device, @Event^.x, @Event^.y, @Event^.state); {$IFDEF VerboseMouseBugfix} DebugLn('[GTKMotionNotifyAfter] ', DbgSName(TControl(Data))); {$ENDIF} // stop the signal, so that it is not sent to the parent widgets g_signal_stop_emission_by_name(PGTKObject(Widget),'motion-notify-event'); UpdateMouseCaptureControl; if (csDesigning in TComponent(Data).ComponentState) then exit; if ControlGetsMouseMoveBefore(TControl(Data)) then exit; DeliverMouseMoveMessage(Widget,Event, TWinControl(Data)); end; {------------------------------------------------------------------------------- function ControlGetsMouseDownBefore(AControl: TControl): boolean; Returns true, if mouse down event should be sent before the widget istelf reacts. -------------------------------------------------------------------------------} function ControlGetsMouseDownBefore(AControl: TControl; AWidget: PGtkWidget): boolean; begin Result:=true; if AControl=nil then exit; if GtkWidgetIsA(AWidget,gtk_toggle_button_get_type) then begin end; end; {------------------------------------------------------------------------------- We must stop delivery of events from scrollbars of GtkScrollable, otherwise if we make an double click on scollbar button, and after that click into our control client area we need 2 click to make it focused. gtk_signal_connect_after() is used, otherwise our scrollbar won't react on such event. -------------------------------------------------------------------------------} function gtk2ScrollBarMouseBtnPress(widget: PGtkWidget; event: pgdkEventButton; data: gPointer): GBoolean; cdecl; begin Result := True; end; {------------------------------------------------------------------------------- We must stop delivery of events from scrollbars of GtkScrollable, otherwise if we make an double click on scollbar button, and after that click into our control client area we need 2 click to make it focused. gtk_signal_connect_after() is used, otherwise our scrollbar won't react on such event. -------------------------------------------------------------------------------} function gtk2ScrollBarMouseBtnRelease(widget: PGtkWidget; event: pgdkEventButton; data: gPointer): GBoolean; cdecl; begin Result := True; end; {------------------------------------------------------------------------------- gtkMouseBtnPress Params: widget: PGTKWidget; event: PGDKEventMotion; data: gPointer Returns: GBoolean Called whenever the mouse is over a widget and a mouse button is pressed. -------------------------------------------------------------------------------} {------------------------------------------------------------------------------- gtkMouseBtnPress Params: widget: PGTKWidget; event: PGDKEventMotion; data: gPointer Returns: GBoolean Called whenever the mouse is over a widget and a mouse button is pressed. -------------------------------------------------------------------------------} function gtkMouseBtnPress(widget: PGtkWidget; event: pgdkEventButton; data: gPointer): GBoolean; cdecl; procedure CheckListSelection; var List: PGlist; ListWidget: PGtkList; R: TRect; Info: PWinWidgetInfo; begin // When in browse mode and a listbox is focused and nothing is selected, // the first item is focused. // Clicking with the mouse on this item won't select it. Info := GetWidgetInfo(Widget, false); if Info = nil then Exit; if Info^.CoreWidget = nil then Exit; if not GtkWidgetIsA(Info^.CoreWidget, gtk_list_get_type) then Exit; ListWidget := PGtkList(Info^.CoreWidget); // Check mode if selection_mode(ListWidget^) <> GTK_SELECTION_BROWSE then Exit; // Check selection List := ListWidget^.selection; if (List <> nil) and (List^.data <> nil) then Exit; // Check if there are children List := ListWidget^.children; if List = nil then Exit; if List^.Data = nil then Exit; // we need only to check the first with PGtkWidget(List^.Data)^.allocation do R := Bounds(X, Y, Width, Height); if not PtInRect(R, Point(Trunc(event^.X), Trunc(event^.Y))) then Exit; // Select it gtk_list_item_select(PGtkListItem(List^.Data)); end; var DesignOnlySignal: boolean; Msg: TLMContextMenu; x, y: gint; W: PGtkWidget; Info: PWidgetInfo; Old: TObject; Mess: TLMessage; {$IFDEF VerboseMouseBugfix} AWinControl: TWinControl; {$ENDIF} begin Result := CallBackDefaultReturn; {$IFDEF VerboseMouseBugfix} AWinControl := TWinControl(Data); DebugLn(''); DesignOnlySignal:=GetDesignOnlySignalFlag(Widget,dstMousePress); DebugLn('[gtkMouseBtnPress] ', DbgSName(AWinControl), ' Widget=',DbgS(Widget), ' ControlWidget=',DbgS(AWinControl.Handle), ' DSO='+dbgs(DesignOnlySignal), ' '+dbgs(TruncToInt(Event^.X)),',',dbgs(TruncToInt(Event^.Y)), ' Type='+dbgs(gdk_event_get_type(Event))); {$ENDIF} {$IFDEF EventTrace} EventTrace('Mouse button Press', data); {$ENDIF} ResetDefaultIMContext; UpdateMouseCaptureControl; if not (csDesigning in TComponent(Data).ComponentState) then begin // fix gtklist selection first CheckListSelection; DesignOnlySignal := GetDesignOnlySignalFlag(Widget, dstMousePress); if DesignOnlySignal then exit; if not ControlGetsMouseDownBefore(TControl(Data), Widget) then Exit; if Event^.button = 1 then begin //CaptureMouseForWidget(CaptureWidget,mctGTKIntf); end else // if LCL process LM_CONTEXTMENU then stop the event propagation if (Event^.button = 3) then begin W := Widget; gdk_display_get_pointer(gtk_widget_get_display(Widget), nil, @x, @y, nil); Old := nil; while W <> nil do begin Info := GetWidgetInfo(W); if (Info <> nil) and (Info^.LCLObject <> Old) then begin Old := Info^.LCLObject; FillChar(Msg, SizeOf(Msg), #0); Msg.Msg := LM_CONTEXTMENU; Msg.hWnd := HWND(W); Msg.XPos := x; Msg.YPos := y; Result := DeliverMessage(Old, Msg) <> 0; if Result then break; end; // check if widget has a standard popup menu if (W = widget) and Assigned(GTK_WIDGET_GET_CLASS(W)^.popup_menu) then break; W := gtk_widget_get_parent(W); end; {emit selection change when right mouse button pressed otherwise LCL is not updated since ChangeLock = 1 in case of pressing right mouse button and 'changed' signal never reach lcl. Issues #16972, #17888. } if Result and GTK_IS_TREE_VIEW(Widget) and (event^.button = 3) then begin Result := False; FillChar(Mess,SizeOf(Mess),0); Mess.msg := LM_SelChange; DeliverMessage(TWinControl(Data), Mess); end; end; end else begin if (event^.Button=1) and ((TControl(Data) is TCustomNoteBook) or (TControl(Data) is TCustomTabControl)) then begin // clicks on the notebook should be handled by the gtk (switching page) end else begin // stop the signal, so that the widget does not auto react //DebugLn(['gtkMouseBtnPress stop signal']); g_signal_stop_emission_by_name(PGTKObject(Widget), 'button-press-event'); end; end; //debugln('[gtkMouseBtnPress] calling DeliverMouseDownMessage Result=',dbgs(Result)); DeliverMouseDownMessage(Widget, Event, TWinControl(Data)); end; {------------------------------------------------------------------------------- procedure DeliverMouseDownMessage(widget: PGtkWidget; event : pgdkEventButton; AWinControl: TWinControl); Translate a gdk mouse press event into a LCL mouse down message and send it. -------------------------------------------------------------------------------} procedure DeliverMouseDownMessage(widget: PGtkWidget; event : pgdkEventButton; AWinControl: TWinControl); const WHEEL_DELTA : array[Boolean] of Integer = (-120, 120); var MessI : TLMMouse; MessE : TLMMouseEvent; ShiftState: TShiftState; MappedXY: TPoint; EventXY: TPoint; {off $DEFINE VerboseMouseBugfix} function CheckMouseButtonDown(var LastMouse: TLastMouseClick; BtnKey, MsgNormal, MsgDouble, MsgTriple, MsgQuad: longint): boolean; function LastClickInSameGdkWindow: boolean; begin Result:=(LastMouse.Window<>nil) and (LastMouse.Window=Event^.Window); end; function LastClickAtSamePosition: boolean; begin Result:= (Abs(EventXY.X-LastMouse.WindowPoint.X)<=DblClickThreshold) and (Abs(EventXY.Y-LastMouse.WindowPoint.Y)<=DblClickThreshold); end; function LastClickInTime: boolean; begin Result := ((now - LastMouse.TheTime) <= ((1/86400)*(DblClickTime/1000))); end; function TestIfMultiClick: boolean; begin Result:=LastClickInSameGdkWindow and LastClickAtSamePosition and LastClickInTime; end; var IsMultiClick: boolean; begin Result := False; if (LastMouse.Down) and (not (gdk_event_get_type(Event) in [gdk_2button_press, gdk_3button_press])) then begin {$IFDEF VerboseMouseBugfix} DebugLn(' NO CLICK: LastMouse.Down=',dbgs(LastMouse.Down), ' Event^.theType=',dbgs(gdk_event_get_type(Event))); {$ENDIF} Exit; end; MessI.Keys := MessI.Keys or BtnKey; IsMultiClick := TestIfMultiClick; case gdk_event_get_type(Event) of gdk_2button_press: // the gtk itself has detected a double click if (LastMouse.ClickCount>=2) and IsMultiClick then begin // the double click was already detected and sent to the LCL // -> skip this message exit; end else begin LastMouse.ClickCount:=2; end; gdk_3button_press: // the gtk itself has detected a triple click if (LastMouse.ClickCount>=3) and IsMultiClick then begin // the triple click was already detected and sent to the LCL // -> skip this message exit; end else begin LastMouse.ClickCount:=3; end; else begin inc(LastMouse.ClickCount); if (LastMouse.ClickCount<=4) and IsMultiClick then begin // multi click {$IFDEF VerboseMouseBugfix} DebugLn(' MULTI CLICK: ',dbgs(now),'-',dbgs(LastMouse.TheTime),'<= ', dbgs((1/86400)*(DblClickTime/1000))); {$ENDIF} end else begin // normal click LastMouse.ClickCount:=1; end; end; end; {$IFDEF VerboseMouseBugfix} DebugLn(' ClickCount=',dbgs(LastMouse.ClickCount)); {$ENDIF} LastMouse.TheTime := Now; LastMouse.Window := Event^.Window; LastMouse.WindowPoint := EventXY; LastMouse.Down := True; LastMouse.Component := AWinControl; //DebugLn('DeliverMouseDownMessage ',DbgSName(AWinControl),' Mapped=',dbgs(MappedXY.X),',',dbgs(MappedXY.Y),' Event=',dbgs(EventXY.X),',',dbgs(EventXY.Y),' ',dbgs(LastMouse.ClickCount)); case LastMouse.ClickCount of 1: MessI.Msg := MsgNormal; 2: MessI.Msg := MsgDouble; 3: MessI.Msg := MsgTriple; 4: MessI.Msg := MsgQuad; else MessI.Msg := LM_NULL; end; Result := True; end; begin EventXY := Point(TruncToInt(Event^.X), TruncToInt(Event^.Y)); ShiftState := GTKEventStateToShiftState(Event^.State); MappedXY := TranslateGdkPointToClientArea(Event^.Window, EventXY, PGtkWidget(AWinControl.Handle)); MappedXY := SubtractScoll(PGtkWidget(AWinControl.Handle), MappedXY); //DebugLn('DeliverMouseDownMessage ',DbgSName(AWinControl),' Mapped=',dbgs(MappedXY.X),',',dbgs(MappedXY.Y),' Event=',dbgs(EventXY.X),',',dbgs(EventXY.Y)); if event^.Button in [4, 5] then begin // this is a mouse wheel event MessE.Msg := LM_MOUSEWHEEL; MessE.WheelDelta := WHEEL_DELTA[event^.Button = 4]; MessE.X := MappedXY.X; MessE.Y := MappedXY.Y; MessE.State := ShiftState; MessE.UserData := AWinControl; MessE.Button := 0; // send the message directly to the LCL NotifyApplicationUserInput(MessE.Msg); DeliverMessage(AWinControl, MessE); end else begin // a normal mouse button is pressed MessI.Keys := 0; case event^.Button of 1: if not CheckMouseButtonDown(LastLeft, MK_LBUTTON, LM_LBUTTONDOWN, LM_LBUTTONDBLCLK, LM_LBUTTONTRIPLECLK, LM_LBUTTONQUADCLK) then Exit; 2: if not CheckMouseButtonDown(LastMiddle, MK_MBUTTON, LM_MBUTTONDOWN, LM_MBUTTONDBLCLK, LM_MBUTTONTRIPLECLK, LM_MBUTTONQUADCLK) then Exit; 3: if not CheckMouseButtonDown(LastRight, MK_RBUTTON, LM_RBUTTONDOWN, LM_RBUTTONDBLCLK, LM_RBUTTONTRIPLECLK, LM_RBUTTONQUADCLK) then Exit; else begin MessI.Msg := LM_NULL; exit; end; end; // case MessI.XPos := MappedXY.X; MessI.YPos := MappedXY.Y; MessI.Keys := MessI.Keys or ShiftStateToKeys(ShiftState); MessI.Result:=0; // send the message directly to the LCL NotifyApplicationUserInput(MessI.Msg); DeliverMessage(AWinControl, MessI); end; end; {------------------------------------------------------------------------------- gtkMouseBtnPressAfter Params: widget: PGTKWidget; event: PGDKEventMotion; data: gPointer Returns: GBoolean Called whenever the mouse is over a widget and a mouse button is pressed. This is the last handler. -------------------------------------------------------------------------------} function gtkMouseBtnPressAfter(widget: PGtkWidget; event : pgdkEventButton; data: gPointer) : GBoolean; cdecl; begin Result := True; {$IFDEF VerboseMouseBugfix} debugln('[gtkMouseBtnPressAfter] ', DbgSName(TObject(Data)), ' Widget=',DbgS(Widget), ' ', GetWidgetClassName(Widget), ' ',dbgs(TruncToInt(Event^.X)),',',dbgs(TruncToInt(Event^.Y))); {$ENDIF} ResetDefaultIMContext; UpdateMouseCaptureControl; // stop the signal, so that it is not sent to the parent widgets g_signal_stop_emission_by_name(PGTKObject(Widget), 'button-press-event'); if (csDesigning in TComponent(Data).ComponentState) then exit; if ControlGetsMouseDownBefore(TControl(Data),Widget) then exit; //debugln('[gtkMouseBtnPressAfter] calling DeliverMouseDownMessage'); DeliverMouseDownMessage(Widget, Event, TWinControl(Data)); end; {------------------------------------------------------------------------------- function ControlGetsMouseUpBefore(AControl: TControl): boolean; Returns true, if mouse up event should be sent before the widget istelf reacts. -------------------------------------------------------------------------------} function ControlGetsMouseUpBefore(AControl: TControl): boolean; begin Result:=true; if AControl=nil then ; end; {------------------------------------------------------------------------------- procedure DeliverMouseUpMessage(widget: PGtkWidget; event : pgdkEventButton; AWinControl: TWinControl); Translate a gdk mouse release event into a LCL mouse up message and send it. returns true, if message was handled by LCL -------------------------------------------------------------------------------} function DeliverMouseUpMessage(widget: PGtkWidget; event: pgdkEventButton; AWinControl: TWinControl): boolean; var MessI : TLMMouse; ShiftState: TShiftState; MappedXY: TPoint; function CheckMouseButtonUp(var LastMouse: TLastMouseClick; MsgUp: longint): boolean; begin MessI.Msg := MsgUp; LastMouse.Down := False; Result := True; end; begin Result := False; MappedXY := TranslateGdkPointToClientArea(Event^.Window, Point(TruncToInt(Event^.X), TruncToInt(Event^.Y)), PGtkWidget(AWinControl.Handle)); MappedXY := SubtractScoll(PGtkWidget(AWinControl.Handle), MappedXY); //DebugLn(['DeliverMouseUpMessage ',GetWidgetDebugReport(Widget),' ',dbgsName(AWinControl),' ',dbgs(MappedXY)]); case event^.Button of 1: if not CheckMouseButtonUp(LastLeft, LM_LBUTTONUP) then Exit; 2: if not CheckMouseButtonUp(LastMiddle, LM_MBUTTONUP) then Exit; 3: if not CheckMouseButtonUp(LastRight, LM_RBUTTONUP) then exit; else begin MessI.Msg := LM_NULL; Exit; end; end; // case MessI.XPos := MappedXY.X; MessI.YPos := MappedXY.Y; ShiftState := GTKEventStateToShiftState(Event^.State); MessI.Keys := ShiftStateToKeys(ShiftState); if MessI.Msg <> LM_NULL then begin // send the message directly to the LCL // (Posting the message via queue // has the risk of getting out of sync with the gtk) MessI.Result := 0; NotifyApplicationUserInput(MessI.Msg); DeliverMessage(AWinControl, MessI); if MessI.Result <> 0 then begin // handled by the LCL //DebugLn(['DeliverMouseUpMessage msg was handled by the LCL, Stopping signal ...']); g_signal_stop_emission_by_name(PGTKObject(Widget), 'button-release-event'); Result := True; end; end; end; {------------------------------------------------------------------------------- gtkMouseBtnRelease Params: widget: PGTKWidget; event: PGDKEventMotion; data: gPointer Returns: GBoolean Called whenever the mouse is over a widget and a mouse button is released. -------------------------------------------------------------------------------} function gtkMouseBtnRelease(widget: PGtkWidget; event : pgdkEventButton; data: gPointer) : GBoolean; cdecl; var DesignOnlySignal: boolean; AForm: TCustomForm; begin Result := CallBackDefaultReturn; {$IFDEF VerboseMouseBugfix} DesignOnlySignal:=GetDesignOnlySignalFlag(Widget,dstMouseRelease); DebugLn(['[gtkMouseBtnRelease] A ',DbgSName(TObject(Data)),' ', ' Widget=',DbgS(Widget), ' Event.time=',event^.time, ' DSO=',DesignOnlySignal, ' ',TruncToInt(Event^.X),',',TruncToInt(Event^.Y),' Btn=',event^.Button]); {$ENDIF} //DebugLn('EEE1 MouseRelease Widget=',DbgS(Widget), //' EventMask=',DbgS(gdk_window_get_events(Widget^.Window)), //' GDK_BUTTON_RELEASE_MASK=',DbgS(GDK_BUTTON_RELEASE_MASK)); ResetDefaultIMContext; UpdateMouseCaptureControl; if not (csDesigning in TComponent(Data).ComponentState) then begin DesignOnlySignal := GetDesignOnlySignalFlag(Widget, dstMouseRelease); ReleaseMouseCapture; if DesignOnlySignal or (not ControlGetsMouseUpBefore(TControl(Data))) then Exit; end else begin // stop the signal, so that the widget does not auto react if (not (TControl(Data) is TCustomNoteBook)) and (not (TControl(Data) is TCustomTabControl)) then begin g_signal_stop_emission_by_name(PGTKObject(Widget), 'button-release-event'); Result := not CallBackDefaultReturn; end; end; if DeliverMouseUpMessage(Widget, Event, TWinControl(Data)) then begin if not DragManager.IsDragging then Result := not CallBackDefaultReturn else begin // workaround for gtk2 bug where "clicked" isn't triggered // because of Result=TRUE and we started modal form from OnDropDown event. // see issue http://bugs.freepascal.org/view.php?id=14318 for details. if GTK_IS_BUTTON(Widget) then begin AForm := GetParentForm(TWinControl(Data)); if (AForm <> nil) and (fsModal in AForm.FormState) then gtk_button_clicked(PGtkButton(Widget)); end; end; end; end; {------------------------------------------------------------------------------- gtkMouseBtnReleaseAfter Params: widget: PGTKWidget; event: PGDKEventMotion; data: gPointer Returns: GBoolean Called whenever the mouse is over a widget and a mouse button is released. This is the last handler. -------------------------------------------------------------------------------} function gtkMouseBtnReleaseAfter(widget: PGtkWidget; event : pgdkEventButton; data: gPointer) : GBoolean; cdecl; begin Result := True; {$IFDEF VerboseMouseBugfix} DebugLn('[gtkMouseBtnReleaseAfter] ',DbgSName(TObject(Data)),' ', ' Widget=',DbgS(Widget), ' ',dbgs(TruncToInt(Event^.X)),',',dbgs(TruncToInt(Event^.Y)),' Btn=',dbgs(event^.Button)); {$ENDIF} // stop the signal, so that it is not sent to the parent widgets g_signal_stop_emission_by_name(PGTKObject(Widget),'button-release-event'); ResetDefaultIMContext; UpdateMouseCaptureControl; if (csDesigning in TComponent(Data).ComponentState) then exit; if ControlGetsMouseUpBefore(TControl(Data)) then exit; DeliverMouseUpMessage(Widget,Event,TWinControl(Data)); end; function gtkMouseWheelCB(widget: PGtkWidget; event: PGdkEventScroll; data: gPointer): GBoolean; cdecl; var AWinControl: TWinControl; EventXY: TPoint; ShiftState: TShiftState; MappedXY: TPoint; MessE : TLMMouseEvent; begin Result := False; AWinControl:=TWinControl(Data); EventXY:=Point(TruncToInt(Event^.X),TruncToInt(Event^.Y)); ShiftState := GTKEventStateToShiftState(Event^.State); MappedXY:=TranslateGdkPointToClientArea(Event^.Window,EventXY, PGtkWidget(AWinControl.Handle)); MappedXY := SubtractScoll(PGtkWidget(AWinControl.Handle), MappedXY); //DebugLn('gtkMouseWheelCB ',DbgSName(AWinControl),' Mapped=',dbgs(MappedXY.X),',',dbgs(MappedXY.Y),' Event=',dbgs(EventXY.X),',',dbgs(EventXY.Y)); // this is a mouse wheel event FillChar(MessE,SizeOf(MessE),0); MessE.Msg := LM_MOUSEWHEEL; case event^.direction of GDK_SCROLL_UP: MessE.WheelDelta := 120; GDK_SCROLL_DOWN: MessE.WheelDelta := -120; else exit; end; MessE.X := MappedXY.X; MessE.Y := MappedXY.Y; MessE.State := ShiftState; MessE.UserData := AWinControl; MessE.Button := 0; // send the message directly to the LCL NotifyApplicationUserInput(MessE.Msg); if DeliverMessage(AWinControl, MessE) <> 0 then Result := True; // message handled by LCL, stop processing end; function gtkclickedCB(widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var Mess: TLMessage; begin Result := CallBackDefaultReturn; //DebugLn('[gtkclickedCB] ',TObject(Data).ClassName); EventTrace('clicked', data); if (LockOnChange(PgtkObject(Widget),0)>0) then exit; Mess.Msg := LM_CLICKED; DeliverMessage(Data, Mess); end; function gtkEnterCB(widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var Mess : TLMessage; begin Result := CallBackDefaultReturn; {$IFDEF EventTrace} EventTrace('enter', data); {$ENDIF} if csDesigning in TControl(Data).ComponentState then begin // stop the signal, so that the widget does not auto react g_signal_stop_emission_by_name(PGTKObject(Widget),'enter'); end; Mess.msg := LM_MOUSEENTER; DeliverMessage(Data, Mess); end; function gtkLeaveCB(widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var Mess : TLMessage; begin Result := CallBackDefaultReturn; {$IFDEF EventTrace} EventTrace('leave', data); {$ENDIF} if csDesigning in TControl(Data).ComponentState then begin // stop the signal, so that the widget does not auto react g_signal_stop_emission_by_name(PGTKObject(Widget),'leave'); end; Mess.msg := LM_MOUSELEAVE; DeliverMessage(Data, Mess); end; function gtksize_allocateCB(widget: PGtkWidget; size: pGtkAllocation; data: gPointer) : GBoolean; cdecl; {$IFDEF VerboseSizeMsg} var w, h: Gint; {$ENDIF} begin Result := CallBackDefaultReturn; EventTrace('size-allocate', data); with Size^ do Assert(False, Format('Trace:[gtksize_allocateCB] %s --> X: %d, Y: %d, Width: %d, Height: %d', [TObject(data).ClassName, X, Y, Width, Height])); if not (TObject(Data) is TControl) then begin // owner is not TControl -> ignore DebugLn('WARNING: gtksize_allocateCB: Data is not TControl. Data=', DbgS(Data),' ',GetWidgetClassName(Widget)); if Data<>nil then DebugLn(' Data=',TObject(Data).ClassName); RaiseGDBException(''); exit; end; {$IFDEF VerboseSizeMsg} w:=0; h:=0; if Widget^.window<>nil then gdk_window_get_size(Widget^.window,@w,@h); DebugLn(['gtksize_allocateCB: ', DbgSName(TControl(Data)), ' widget=',GetWidgetDebugReport(Widget), ' fixwidget=',DbgS(GetFixedWidget(Widget)), ' NewSize=',Size^.Width,',',Size^.Height, ' GtkPos=',Widget^.allocation.x,',',Widget^.allocation.y, ',',Widget^.allocation.width,'x',Widget^.allocation.height, ' LCLPos=',TControl(Data).Left,',',TControl(Data).Top, ',',TControl(Data).Width,'x',TControl(Data).Height, ' gdkwindow=',w,'x',h]); {$ENDIF} {$IFDEF VerboseFormPositioning} if TControl(Data) is TCustomForm then DebugLn('VFP gtksize_allocateCB: ',TControl(Data).ClassName,' ',dbgs(Size^.X),',',dbgs(Size^.Y)); {$ENDIF} SendSizeNotificationToLCL(Widget); end; function gtksize_allocate_client(widget: PGtkWidget; size: pGtkAllocation; data: gPointer): GBoolean; cdecl; var MainWidget: PGtkWidget; ClientWidget: PGtkWidget; begin Result := CallBackDefaultReturn; if (Widget=nil) or (Size=nil) then ; if (TObject(Data) is TWinControl) then begin {$IFDEF VerboseSizeMsg} DebugLn('gtksize_allocate_client: ', TControl(Data).Name,':',TControl(Data).ClassName, ' widget=',DbgS(Widget), ' NewSize=',dbgs(Size^.Width),',',dbgs(Size^.Height), ' Allocation='+dbgs(widget^.Allocation.Width)+'x'+dbgs(Widget^.Allocation.Height), ' Requisiton='+dbgs(widget^.Requisition.Width)+'x'+dbgs(Widget^.Requisition.Height) ); {$ENDIF} if not TWinControl(Data).HandleAllocated then begin exit; end; MainWidget:=PGtkWidget(TWinControl(Data).Handle); ClientWidget:=GetFixedWidget(MainWidget); if GTK_WIDGET_REALIZED(ClientWidget) then begin // the gtk resizes bottom to top, that means the // inner widget (client area) is resized before the outer widget // is resized. Because the LCL reads both sizes, keep this message back. SaveClientSizeNotification(ClientWidget); end; end else begin // owner is not TWinControl -> ignore DebugLn('WARNING: gtksize_allocate_client: Data is not TWinControl. Data=', DbgS(Data)); exit; end; end; function gtkconfigureevent( widget: PGtkWidget; event : PgdkEventConfigure; data: gPointer) : GBoolean; cdecl; var Allocation : TGtkAllocation; begin { This signal is emitted for top level controls only, i.e. only controls that are not children. Thus, we register this event only for forms. This event is fired when the form is sized, moved or changes Z order. } FillChar(Allocation,SizeOf(TGtkAllocation),0); with Allocation do begin X:= Event^.X; Y:= Event^.Y; Width:= Event^.Width; Height:= Event^.Height; end; Result:= gtksize_allocateCB( Widget, @Allocation, Data); end; function gtkInsertText(widget: PGtkWidget; char : pChar; NewTextLength : Integer; Position : pgint; data: gPointer) : GBoolean; cdecl; var Memo: TCustomMemo; CurrLength, CutLength: integer; begin Result := CallBackDefaultReturn; { GTK does not provide its own max. length for memos we have to do our own. } if TObject(Data) is TCustomMemo then begin if (NewTextLength = 1) and (char^ = #13) and (LineEnding = #10) then char^ := #10; Memo:= TCustomMemo(Data); if Memo.MaxLength <= 0 then Exit; CurrLength:= gtk_text_get_length(PGtkText(widget)); if CurrLength + NewTextLength <= Memo.MaxLength then Exit; CutLength:= CurrLength + NewTextLength - Memo.MaxLength; if NewTextLength - CutLength > 0 then gtk_editable_insert_text(PGtkEditable(widget), char, NewTextLength - CutLength, Position); g_signal_stop_emission_by_name(PGtkObject(widget), 'insert_text'); end; if TObject(Data) is TCustomEdit then if (NewTextLength = 1) and (char^ = #13) then g_signal_stop_emission_by_name(PGtkObject(widget), 'insert_text'); end; function gtkSetEditable( widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var Mess : TLMessage; begin EventTrace('Set Editable', data); if (Widget=nil) then ; Mess.msg := LM_SETEDITABLE; Result:= DeliverMessage(Data, Mess) = 0; end; function gtkMoveWord( widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var Mess : TLMessage; begin EventTrace('Move Word', data); if (Widget=nil) then ; Mess.msg := LM_MOVEWORD; Result:= DeliverMessage(Data, Mess) = 0; end; function gtkMovePage( widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var Mess : TLMessage; begin EventTrace('Move Page', data); if (Widget=nil) then ; Mess.msg := LM_MOVEPAGE; Result:= DeliverMessage(Data, Mess) = 0; end; function gtkMoveToRow( widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var Mess : TLMessage; begin EventTrace('Move To Row!!', data); if (Widget=nil) then ; Mess.msg := LM_MOVETOROW; Result:= DeliverMessage(Data, Mess) = 0; end; function gtkMoveToColumn( widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var Mess : TLMessage; begin EventTrace('MoveToColumn', data); if (Widget=nil) then ; Mess.msg := LM_MOVETOCOLUMN; Result:= DeliverMessage(Data, Mess) = 0; end; function gtkKillChar( widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var Mess : TLMessage; begin EventTrace('Kill Char', data); if (Widget=nil) then ; Mess.msg := LM_KILLCHAR; Result:= DeliverMessage(Data, Mess) = 0; end; function gtkKillWord( widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var Mess : TLMessage; begin EventTrace('Kill Word', data); if (Widget=nil) then ; Mess.msg := LM_KILLWORD; Result:= DeliverMessage(Data, Mess) = 0; end; function gtkKillLine( widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var Mess : TLMessage; begin EventTrace('Kill Line', data); if (Widget=nil) then ; Mess.msg := LM_KILLLINE; Result:= DeliverMessage(Data, Mess) = 0; end; function gtkCutToClip( widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var Mess : TLMessage; Info: PWidgetInfo; begin EventTrace('Cut to clip', data); if (Widget=nil) then ; if (gtk_major_version = 2) and (gtk_minor_version < 17) then begin if (Widget <> nil) and (GTK_IS_ENTRY(Widget)) then begin Info := GetWidgetInfo(Widget, False); include(Info^.Flags, wwiInvalidEvent); end; end; Mess.msg := LM_CUT; Result:= DeliverMessage(Data, Mess) = 0; end; function gtkCopyToClip( widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var Mess : TLMessage; begin EventTrace('Copy to Clip', data); if (Widget=nil) then ; Mess.msg := LM_COPY; Result:= DeliverMessage(Data, Mess) = 0; end; function gtkPasteFromClip( widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var Mess : TLMessage; Info: PWidgetInfo; begin EventTrace('Paste from clip', data); if (Widget=nil) then ; if (gtk_major_version = 2) and (gtk_minor_version < 17) then begin if (Widget <> nil) and (GTK_IS_ENTRY(Widget)) then begin Info := GetWidgetInfo(Widget, False); include(Info^.Flags, wwiInvalidEvent); end; end; Mess.msg := LM_PASTE; Result:= DeliverMessage(Data, Mess) = 0; end; function gtkValueChanged(widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var Mess : TLMessage; begin Result := CallBackDefaultReturn; EventTrace('Value changed', data); Mess.msg := LM_CHANGED; DeliverMessage(Data, Mess); end; {------------------------------------------------------------------------------ Method: gtkTimerCB Params: Data - pointer TGtkITimerInfo structure Returns: 1 - 1 tells gtk to restart the timer 0 - 0 will stop the gtk timer Callback for gtk timer. WARNING: There seems to be a bug in gtk-1.2.x which breaks gtk_timeout_remove so we have to dispose data here & return 0 (s.a. KillTimer). ------------------------------------------------------------------------------} function gtkTimerCB(Data: gPointer): gBoolean; cdecl; var TimerInfo: PGtkITimerinfo; begin EventTrace ('TimerCB', nil); Result := GdkFalse; // assume: timer will stop TimerInfo:=PGtkITimerinfo(Data); if (FTimerData=nil) or (FTimerData.IndexOf(Data)<0) then begin {$IFDEF VerboseTimer} DebugLn('gtkTimerCB Timer was killed: TimerInfo=',DbgS(TimerInfo)); {$ENDIF} // timer was killed Result:=GdkFalse; // stop timer end else begin {$IFDEF VerboseTimer} DebugLn('gtkTimerCB Timer Event: TimerInfo=',DbgS(TimerInfo)); {$ENDIF} if TimerInfo^.TimerFunc <> nil then begin // Call users timer function //DebugLn(['gtkTimerCB ']); TimerInfo^.TimerFunc; Result:=GdkTrue; // timer will go on end else begin Result := GdkFalse; // stop timer end; end; if (Result<>GdkFalse) and (FTimerData.IndexOf(Data)<0) then begin // timer was killed // -> stop timer Result:=GdkFalse; end; if Result=GdkFalse then begin {$IFDEF VerboseTimer} DebugLn('gtkTimerCB Timer was STOPPED: TimerInfo=',DbgS(TimerInfo)); {$ENDIF} // timer will be stopped // -> free timer data, if not already done if (FTimerData<>nil) and (FTimerData.IndexOf(Data)>=0) then begin FTimerData.Remove(Data); Dispose (TimerInfo); // free memory with timer data end; end; end; function gtkFocusInNotifyCB (widget : PGtkWidget; event : PGdkEvent; data : gpointer) : GBoolean; cdecl; var MessI : TLMEnter; begin Result := CallBackDefaultReturn; //DebugLn('[gtkFocusInNotifyCB] ',TControl(data).Name,':',TObject(data).ClassName); {$IFDEF EventTrace} EventTrace ('FocusInNotify (alias Enter)', data); {$ENDIF} if (Event=nil) then ; if csDesigning in TControl(Data).ComponentState then begin // stop the signal, so that the widget does not auto react g_signal_stop_emission_by_name(PGTKObject(Widget),'focus-in-event'); end; MessI.msg := LM_Enter; DeliverMessage(Data, MessI); end; function gtkFocusOutNotifyCB (widget : PGtkWidget; event : PGdkEvent; data : gpointer) : GBoolean; cdecl; var MessI : TLMExit; begin Result := CallBackDefaultReturn; //DebugLn('[gtkFocusOutNotifyCB] ',TControl(data).Name,':',TObject(data).ClassName); {$IFDEF EventTrace} EventTrace ('FocusOutNotify (alias Exit)', data); {$ENDIF} if (Event=nil) then ; if csDesigning in TControl(Data).ComponentState then begin // stop the signal, so that the widget does not auto react g_signal_stop_emission_by_name(PGTKObject(Widget),'focus-out-event'); end; MessI.msg := LM_Exit; DeliverMessage(Data, MessI); end; function get_gtk_scroll_type(range: PGTKRange): TGtkScrollType; type TUnOpaqueTimer=record timeout_id: guint; ScrollType: TGTkScrollType; end; PUnOpaqueTimer=^TUnopaqueTimer; begin if (gtk_major_version=2) and (gtk_minor_version<6) and (Range^.Timer<>nil) then { gtk2 pre gtk2.6 ONLY, tested gtk2.0. Later versions (gtk2.6+) have a change-value signal that includes scrolltype anyways } Result := PUnOpaqueTimer(Range^.Timer)^.ScrollType else Result := GTK_SCROLL_NONE; end; {$IFDEF VerboseGtkScrollbars} procedure DebugScrollStyle(Scroll: LongInt); begin DbgOut('TYPE='); case Scroll of GTK_SCROLL_NONE: DbgOut('GTK_SCROLL_NONE '); GTK_SCROLL_STEP_BACKWARD: DbgOut('GTK_SCROLL_STEP_BACKWARD '); GTK_SCROLL_STEP_FORWARD: DbgOut('GTK_SCROLL_STEP_FORWARD '); GTK_SCROLL_PAGE_BACKWARD: DbgOut('GTK_SCROLL_PAGE_BACKWARD '); GTK_SCROLL_PAGE_FORWARD: DbgOut('GTK_SCROLL_PAGE_FORWARD '); GTK_SCROLL_JUMP: DbgOut('GTK_SCROLL_JUMP '); GTK_SCROLL_STEP_UP: DbgOut('GTK_SCROLL_STEP_UP'); GTK_SCROLL_STEP_DOWN: DbgOut('GTK_SCROLL_STEP_DOWN'); GTK_SCROLL_PAGE_UP: DbgOut('GTK_SCROLL_PAGE_UP'); GTK_SCROLL_PAGE_DOWN: DbgOut('GTK_SCROLL_PAGE_DOWN'); GTK_SCROLL_STEP_LEFT: DbgOut('GTK_SCROLL_STEP_LEFT'); GTK_SCROLL_STEP_RIGHT: DbgOut('GTK_SCROLL_STEP_RIGHT'); GTK_SCROLL_PAGE_LEFT: DbgOut('GTK_SCROLL_PAGE_LEFT'); GTK_SCROLL_PAGE_RIGHT: DbgOut('GTK_SCROLL_PAGE_RIGHT'); GTK_SCROLL_START: DbgOut('GTK_SCROLL_START'); GTK_SCROLL_END: DbgOut('GTK_SCROLL_END'); else DbgOut(IntToStr(Scroll), '->?'); end; end; {$ENDIF VerboseGtkScrollbars} function ScrollTypeToSbCode(IsVertSB: boolean; ScrollType: TGtkScrollType; UpdatePolicy: TGtkUpdateType): Integer; begin case ScrollType of GTK_SCROLL_STEP_BACKWARD: if IsVertSB then Result := SB_LINEUP else Result := SB_LINELEFT; GTK_SCROLL_STEP_FORWARD: if IsVertSB then Result := SB_LINEDOWN else Result := SB_LINERIGHT; GTK_SCROLL_PAGE_BACKWARD: if IsVertSB then Result := SB_PAGEUP else Result := SB_PAGELEFT; GTK_SCROLL_PAGE_FORWARD: if IsVertSB then Result := SB_PAGEDOWN else Result := SB_PAGERIGHT; GTK_SCROLL_STEP_UP: Result := SB_LINEUP; GTK_SCROLL_STEP_DOWN: Result := SB_LINEDOWN; GTK_SCROLL_PAGE_UP: Result := SB_PAGEUP; GTK_SCROLL_PAGE_DOWN: Result := SB_PAGEDOWN; GTK_SCROLL_STEP_LEFT: Result := SB_LINELEFT; GTK_SCROLL_STEP_RIGHT: Result := SB_LINERIGHT; GTK_SCROLL_PAGE_LEFT: Result := SB_PAGELEFT; GTK_SCROLL_PAGE_RIGHT: Result := SB_PAGERIGHT; GTK_SCROLL_START: if IsVertSB then Result := SB_TOP else Result := SB_LEFT; GTK_SCROLL_END: if IsVertSB then Result := SB_BOTTOM else Result := SB_RIGHT; else begin {$IFDEF VerboseGtkScrollbars} debugln('ScrollTypeToSbCode: Scroll_type=', IntToStr(ScrollType)); {$Endif} if UpdatePolicy=GTK_UPDATE_CONTINUOUS then Result := SB_THUMBTRACK else Result := SB_THUMBPOSITION; end; end; end; function GTKHScrollCB(Adjustment: PGTKAdjustment; data: GPointer): GBoolean; cdecl; var Msg: TLMHScroll; Scroll: PGtkRange; ScrollType: TGtkScrollType; begin Result := CallBackDefaultReturn; Assert(False, Format('Trace:[GTKHScrollCB] Value: %d', [RoundToInt(Adjustment^.Value)])); Scroll := PgtkRange(gtk_object_get_data(PGTKObject(Adjustment), odnScrollBar)); if Scroll<>nil then begin Msg.Msg := LM_HSCROLL; with Msg do begin Pos := Round(Adjustment^.Value); if Pos < High(SmallPos) then SmallPos := Pos else SmallPos := High(SmallPos); ScrollBar := HWND(PtrUInt(Scroll)); ScrollType := get_gtk_scroll_type(Scroll); ScrollCode := ScrollTypeToSbCode(False, ScrollType, gtk_range_get_update_policy(Scroll)); end; DeliverMessage(Data, Msg); end; end; function GTKVScrollCB(Adjustment: PGTKAdjustment; data: GPointer): GBoolean; cdecl; var Msg: TLMVScroll; Scroll: PGtkRange; ScrollType: TGtkScrollType; begin //TODO: implement SB_THUMBPOSITION message after track is finished Result := CallBackDefaultReturn; Assert(False, Format('Trace:[GTKVScrollCB] Value: %d', [RoundToInt(Adjustment^.Value)])); Scroll := PgtkRange(gtk_object_get_data(PGTKObject(Adjustment), odnScrollBar)); if Scroll<>nil then begin Msg.Msg := LM_VSCROLL; with Msg do begin Pos := Round(Adjustment^.Value); if Pos < High(SmallPos) then SmallPos := Pos else SmallPos := High(SmallPos); //DebugLn('GTKVScrollCB A Adjustment^.Value=',dbgs(Adjustment^.Value),' SmallPos=',dbgs(SmallPos)); ScrollBar := HWND(PtrUInt(Scroll)); ScrollType := get_gtk_scroll_type(Scroll); // GTK1 has a bug with wheel mouse. It sometimes gives the wrong direction. ScrollCode := ScrollTypeToSbCode(True, ScrollType, gtk_range_get_update_policy(Scroll)); //DebugLn('GTKVScrollCB B Adjustment^.Value=',dbgs(Adjustment^.Value),' ScrollCode=',dbgs(ScrollCode),' ScrollType=',dbgs(ScrollType)); end; DeliverMessage(Data, Msg); end; end; function Gtk2RangeScrollCB(ARange: PGtkRange; AScrollType: TGtkScrollType; AValue: gdouble; AWidgetInfo: PWidgetInfo): gboolean; cdecl; var Msg: TLMVScroll; MaxValue: gdouble; begin Result := CallBackDefaultReturn; //Assert(False, Format('Trace:[Gtk2RangeScrollCB] Value: %d', [RoundToInt(AValue)])); if G_OBJECT_TYPE(ARange) = gtk_hscrollbar_get_type then Msg.Msg := LM_HSCROLL else Msg.Msg := LM_VSCROLL; if (AWidgetInfo^.LCLObject is TScrollingWinControl) then begin if ARange^.adjustment^.page_size > 0 then MaxValue := ARange^.adjustment^.upper - ARange^.adjustment^.page_size else MaxValue := ARange^.adjustment^.upper; if (AValue > MaxValue) or (AValue < ARange^.adjustment^.lower) then begin Result := not Result; AValue := MaxValue; end; end; with Msg do begin Pos := Round(AValue); if Pos < High(SmallPos) then SmallPos := Pos else SmallPos := High(SmallPos); ScrollBar := HWND(PtrUInt(ARange)); ScrollCode := GtkScrollTypeToScrollCode(AScrollType); end; Result := DeliverMessage(AWidgetInfo^.LCLObject, Msg) <> 0; end; {------------------------------------------------------------------------------ Function: GTKKeySnooper Params: Widget: The widget for which this event is fired Event: The keyevent data FuncData: the user parameter passed when the snooper was installed Returns: True if other snoopers shouldn't handled Keeps track of which keys are pressed. The keycode is casted to a pointer and if it exists in the KeyStateList, it is pressed. ------------------------------------------------------------------------------} function GTKKeySnooper(Widget: PGtkWidget; Event: PGdkEventKey; FuncData: gPointer): gInt; cdecl; var KeyStateList: TFPList; procedure UpdateToggleList(const AVKeyCode: Integer); begin // Check for a toggle // If the remove was successfull, the key was on // else it was off so we should set the toggle flag if KeyStateList.Remove(Pointer(PtrInt(AVKeyCode or KEYMAP_TOGGLE))) < 0 then KeyStateList.Add(Pointer(PtrInt(AVKeyCode or KEYMAP_TOGGLE))); end; procedure UpdateList(const AVKeyCode: Integer; const APressed: Boolean); begin if AVKeyCode = 0 then Exit; if APressed then begin if KeyStateList.IndexOf(Pointer(PtrInt(AVKeyCode))) < 0 then KeyStateList.Add(Pointer(PtrInt(AVKeyCode))); end else begin KeyStateList.Remove(Pointer(PtrInt(AVKeyCode))); end; end; const STATE_MAP: array[0..3] of TShiftStateEnum = ( ssShift, ssCtrl, ssAlt, ssSuper ); VK_MAP: array[0..3] of array[0..2] of Byte = ( // (Main key, alt key 1, alt key 2) to check (VK_SHIFT, VK_LSHIFT, VK_RSHIFT), (VK_CONTROL, VK_LCONTROL, VK_RCONTROL), (VK_MENU, VK_LMENU, VK_RMENU), (VK_LWIN, VK_RWIN, 0) ); var KeyCode: Word; KCInfo: TKeyCodeInfo; VKey: Byte; Pressed, InState: Boolean; n: Integer; ShiftState: TShiftState; begin Result := 0; // TODO: Remove when KeyStateList is obsolete case gdk_event_get_type(Event) of GDK_KEY_PRESS: Pressed := True; GDK_KEY_RELEASE: Pressed := False; else // not interested Exit; end; KeyCode := Event^.hardware_keycode; //DebugLn('GTKKeySnooper: KeyCode=%u -> %s', [KeyCode, Event^._String ]); if KeyCode > High(MKeyCodeInfo) then begin if Pressed then DebugLn('[WARNING] Key pressed with keycode (%u) larger than expected: K=0x%x S="%s"', [ KeyCode, Event^.KeyVal, Event^._String ]); Exit; end; KCInfo := MKeyCodeInfo[KeyCode]; if KCInfo.VKey1 = 0 then begin if Pressed then DebugLn('[WARNING] Key pressed without VKey: K=0x%x S="%s"', [ Event^.KeyVal, Event^._String ]); Exit; end; if FuncData = nil then exit; KeyStateList := TObject(FuncData) as TFPList; ShiftState := GTKEventStateToShiftState(Event^.State); if (KCInfo.Flags and KCINFO_FLAG_SHIFT_XOR_NUM <> 0) and ((ssShift in ShiftState) xor (ssNum in ShiftState)) then VKey := KCInfo.VKey2 else VKey := KCInfo.VKey1; UpdateList(VKey, Pressed); if Pressed then UpdateToggleList(VKey); // Add special left and right codes case Event^.KeyVal of GDK_Key_Shift_L: UpdateList(VK_LSHIFT, Pressed); GDK_Key_Shift_R: UpdateList(VK_RSHIFT, Pressed); GDK_Key_Control_L: UpdateList(VK_LCONTROL, Pressed); GDK_Key_Control_R: UpdateList(VK_RCONTROL, Pressed); GDK_Key_Alt_L: UpdateList(VK_LMENU, Pressed); GDK_Key_Alt_R: UpdateList(VK_RMENU, Pressed); end; // Recheck the list against the modifiers for n := 0 to High(STATE_MAP) do begin // Skip our current key, since the state is updated after the event if VKey = VK_MAP[n][0] then Continue; if VKey = VK_MAP[n][1] then Continue; if VKey = VK_MAP[n][2] then Continue; InState := STATE_MAP[n] in ShiftState; UpdateList(VK_MAP[n][0], InState); UpdateList(VK_MAP[n][1], InState); UpdateList(VK_MAP[n][2], InState); end; // if the VKey has multiple VK_codes then SHIFT distinguishes between them // In that case SHIFT is not pressed // On the next event the shift flag will be restored based on modifiers if Pressed and ((KCInfo.Flags and KCINFO_FLAG_SHIFT_XOR_NUM) <> 0) then begin UpdateList(VK_SHIFT, False); UpdateList(VK_LSHIFT, False); UpdateList(VK_RSHIFT, False); end; end; function gtkYearChanged(Widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var MSG: TLMessage; begin Result := CallBackDefaultReturn; if (Widget=nil) then ; EventTrace('year changed', data); MSG.Msg := LM_YEARCHANGED; DeliverPostMessage(Data, MSG); end; procedure GtkDragDataReceived(widget:PGtkWidget; context:PGdkDragContext; x:gint; y:gint; selection_data:PGtkSelectionData; info:guint; time:guint; Data: gPointer);cdecl; var S: TStringList; I: Integer; FileName, DecodedFileName: String; Files: Array of String; Form: TControl; Result: Boolean; U: TURI; begin //DebugLn('GtkDragDataReceived ' + PChar(selection_data^.data)); Result := False; if selection_data^.data <> nil then // data is list of uri begin SetLength(Files, 0); S := TStringList.Create; try S.Text := PChar(selection_data^.data); for I := 0 to S.Count - 1 do begin FileName := S[I]; if FileName = '' then Continue; // uri = protocol://hostname/file name U := ParseURI(FileName); if (SameText(U.Host, 'localhost') or (U.Host = '')) and SameText(U.Protocol, 'file') and URIToFileName(FileName, DecodedFileName) then // convert uri of local files to file name begin FileName := DecodedFileName; end; // otherwise: protocol and hostname are preserved! if FileName = '' then Continue; SetLength(Files, Length(Files) + 1); Files[High(Files)] := FileName; //DebugLn('GtkDragDataReceived ' + DbgS(I) + ': ' + PChar(FileName)); end; finally S.Free; end; if Length(Files) > 0 then begin Form := nil; if (TObject(Data) is TWinControl) then Form := (TObject(Data) as TWinControl).GetTopParent; if Form is TCustomForm then (Form as TCustomForm).IntfDropFiles(Files) else if (Application <> nil) and (Application.MainForm <> nil) then Application.MainForm.IntfDropFiles(Files); if Application <> nil then Application.IntfDropFiles(Files); Result := True; end; end; gtk_drag_finish(Context, Result, false, time); end; {------------------------------------------------------------------------------ ClipboardSelectionReceivedHandler This handler is called whenever a clipboard owner sends data. Because the LCL caches all requests, this is typically data from another application. Copy the received selection data record and buffer to internal record and buffer (ClipboardSelectionData) ------------------------------------------------------------------------------} procedure ClipboardSelectionReceivedHandler(TargetWidget: PGtkWidget; SelectionData: PGtkSelectionData; TimeID: guint32; Data: Pointer); cdecl; var TempBuf: Pointer; c: PClipboardEventData; i: integer; begin // at any time there can be several requests // find the request with the correct TimeID if (Data=nil) or (TargetWidget=nil) then ; i:=ClipboardSelectionData.Count-1; while (i>=0) do begin c:=PClipboardEventData(ClipboardSelectionData[i]); if c^.TimeID=TimeID then break; dec(i); end; {$IFDEF DEBUG_CLIPBOARD} DebugLn('[ClipboardSelectionReceivedHandler] A TimeID=',dbgs(TimeID),' RequestIndex=',dbgs(i), ' selection=',dbgs(SelectionData^.selection)+'='+GdkAtomToStr(SelectionData^.selection), ' target=',dbgs(SelectionData^.Target)+'='+GdkAtomToStr(SelectionData^.Target), ' theType=',dbgs(SelectionData^._type)+'='+GdkAtomToStr(SelectionData^._type), ' format=',dbgs(SelectionData^.format), ' len=',dbgs(SelectionData^.length) ); {$ENDIF} if i<0 then exit; // free old data if (c^.Data.Data<>nil) then FreeMem(c^.Data.Data); // copy the information c^.Data:=SelectionData^; // copy the raw data to an internal buffer (the gtk buffer will be destroyed // right after this event) {$IFDEF DEBUG_CLIPBOARD} DebugLn('[ClipboardSelectionReceivedHandler] B DataLen=',dbgs(c^.Data.Length)); {$ENDIF} if (c^.Data.Data<>nil) and (c^.Data.Length>0) then begin GetMem(TempBuf,c^.Data.Length); Move(c^.Data.Data^,TempBuf^,c^.Data.Length); c^.Data.Data:=TempBuf; {$IFDEF DEBUG_CLIPBOARD} DebugLn('[ClipboardSelectionReceivedHandler] C FirstCharacter=',dbgs(ord(PChar(c^.Data.Data)[0]))); {$ENDIF} end else begin {if (SelectionData^.Target <> GDK_TARGET_STRING) and (SelectionData^.length<0) then begin if gtk_selection_convert (TargetWidget, SelectionData^.selection, GDK_TARGET_STRING, TimeID)<>GdkFalse then begin DebugLn('[ClipboardSelectionReceivedHandler] D TimeID=',dbgs(TimeID),' RequestIndex=',dbgs(i), ' selection=',dbgs(SelectionData^.selection)+'='+GdkAtomToStr(SelectionData^.selection), ' target=',dbgs(SelectionData^.Target)+'='+GdkAtomToStr(SelectionData^.Target), ' theType=',dbgs(SelectionData^.theType)+'='+GdkAtomToStr(SelectionData^.theType), ' format=',dbgs(SelectionData^.format), ' len=',dbgs(SelectionData^.length) ); end; end;} c^.Data.Data:=nil; end; end; {------------------------------------------------------------------------------ ClipboardSelectionRequestHandler This signal is emitted if someone requests the clipboard data. Since the lcl clipboard caches all requests this will typically be another application. ------------------------------------------------------------------------------} procedure ClipboardSelectionRequestHandler(TargetWidget: PGtkWidget; SelectionData: PGtkSelectionData; Info: cardinal; TimeID: cardinal; Data: Pointer); cdecl; var ClipboardType: TClipboardType; MemStream: TMemoryStream; FormatID: cardinal; Buffer: Pointer; BufLength: integer; BitCount: integer; P: PChar; begin {$IFDEF DEBUG_CLIPBOARD} DebugLn('*** [ClipboardSelectionRequestHandler] START'); {$ENDIF} if (Data=nil) or (TimeID=0) or (Info=0) or (TargetWidget=nil) then ; if SelectionData^.Target=0 then exit; for ClipboardType:=Low(TClipboardType) to High(TClipboardType) do begin if SelectionData^.Selection=ClipboardTypeAtoms[ClipboardType] then begin if Assigned(ClipboardHandler[ClipboardType]) then begin // handler found for this of clipboard // now create a stream and find a supported format {$IFDEF DEBUG_CLIPBOARD} DebugLn('[ClipboardSelectionRequestHandler] "',ClipboardTypeName[ClipboardType],'" Format=',GdkAtomToStr(SelectionData^.Target),' ID=',dbgs(SelectionData^.Target)); {$ENDIF} MemStream:=TMemoryStream.Create; try // the gtk-interface provides automatically some formats, that the lcl // does not know. Wrapping them to lcl formats ... FormatID:=SelectionData^.Target; if ((FormatID=gdk_atom_intern('COMPOUND_TEXT',GdkTrue)) and (ClipboardExtraGtkFormats[ClipboardType][gfCOMPOUND_TEXT])) or ((FormatID=gdk_atom_intern('UTF8_STRING',GdkTrue)) and (ClipboardExtraGtkFormats[ClipboardType][gfUTF8_STRING])) or ((FormatID=gdk_atom_intern('STRING',GdkTrue)) and (ClipboardExtraGtkFormats[ClipboardType][gfSTRING])) or ((FormatID=gdk_atom_intern('TEXT',GdkTrue)) and (ClipboardExtraGtkFormats[ClipboardType][gfTEXT])) then FormatID:=gdk_atom_intern('text/plain',GdkTrue); {$IFDEF DEBUG_CLIPBOARD} DebugLn('[ClipboardSelectionRequestHandler] FormatID=',dbgs(FormatID),'=',GdkAtomToStr(FormatID),' ',dbgs(ClipboardExtraGtkFormats[ClipboardType][gfCOMPOUND_TEXT])); {$ENDIF} // get the requested data by calling the handler for this clipboard type ClipboardHandler[ClipboardType](FormatID,MemStream); MemStream.Position:=0; // build clipboard data for gtk Buffer:=nil; BufLength:=0; BitCount:=8; // if the format was wrapped, transform it back if (FormatID=gdk_atom_intern('text/plain',GdkTrue)) then begin if (SelectionData^.Target=gdk_atom_intern('COMPOUND_TEXT',GdkTrue)) then begin // transform text/plain to COMPOUND_TEXT BufLength:=integer(MemStream.Size); P:=StrAlloc(BufLength+1); MemStream.Read(P^,BufLength); P[BufLength]:=#0; BufLength:=0; gdk_string_to_compound_text(P, @SelectionData^._Type, @SelectionData^.Format,ppguchar(@Buffer),@BufLength); StrDispose(P); gtk_selection_data_set(SelectionData,SelectionData^.Target, SelectionData^.Format,Buffer,BufLength); gdk_free_compound_text(Buffer); exit; end; end; if Buffer=nil then begin {$IFDEF DEBUG_CLIPBOARD} DebugLn('[ClipboardSelectionRequestHandler] Default MemStream.Size=',dbgs(MemStream.Size)); {$ENDIF} BufLength:=integer(MemStream.Size); if BufLength>0 then begin GetMem(Buffer,BufLength); MemStream.Read(Buffer^,BufLength); {SetLength(s,MemStream.Size); MemStream.Position:=0; MemStream.Read(s[1],MemStream.Size); DebugLn(' >>> "',s,'"');} end; end; {$IFDEF DEBUG_CLIPBOARD} DebugLn('[ClipboardSelectionRequestHandler] Len=',dbgs(BufLength)); {$ENDIF} gtk_selection_data_set(SelectionData,SelectionData^.Target,BitCount, Buffer,BufLength); if Buffer<>nil then FreeMem(Buffer); finally MemStream.Free; end; end; break; end; end; end; {------------------------------------------------------------------------------ ClipboardSelectionLostOwnershipHandler This signal is emitted if another application gets the clipboard ownership. ------------------------------------------------------------------------------} function ClipboardSelectionLostOwnershipHandler(TargetWidget: PGtkWidget; EventSelection: PGdkEventSelection; Data: Pointer): cardinal; cdecl; var ClipboardType: TClipboardType; begin if (Data=nil) or (TargetWidget=nil) then ; //DebugLn('*** [ClipboardSelectionLostOwnershipHandler] ',DbgS(targetwidget)); for ClipboardType:=Low(TClipboardType) to High(TClipboardType) do if EventSelection^.Selection=ClipboardTypeAtoms[ClipboardType] then begin {$IFDEF DEBUG_CLIPBOARD} DebugLn('*** [ClipboardSelectionLostOwnershipHandler] ',ClipboardTypeName[ClipboardType]); {$ENDIF} if (ClipboardWidget<>nil) and (gdk_selection_owner_get(ClipboardTypeAtoms[ClipboardType]) <> GetControlWindow(ClipboardWidget)) and Assigned(ClipboardHandler[ClipboardType]) then begin // handler found for this type of clipboard {$IFDEF DEBUG_CLIPBOARD} DebugLn('[ClipboardSelectionLostOwnershipHandler] ',ClipboardTypeName[ClipboardType]); {$ENDIF} ClipboardHandler[ClipboardType](0,nil); ClipboardHandler[ClipboardType]:=nil; end; break; end; Result:=1; end; {------------------------------------------------------------------------------- procedure GTKStyleChanged(Widget: PGtkWidget; previous_style : PGTKStyle; Data: Pointer); cdecl; Handler for style changes. For example the user changes the theme. But also called on every widget realize, so it should not release all styles everytime. -------------------------------------------------------------------------------} procedure GTKStyleChanged(Widget: PGtkWidget; previous_style : PGTKStyle; Data: Pointer); cdecl; begin if (Widget=nil) or (Data=nil) or (previous_style=nil) then ; {$IFDEF EventTrace} EventTrace('style-set', nil); {$ENDIF} //ReleaseAllStyles; end; procedure GTKStyleChangedAfter(Widget: PGtkWidget; previous_style : PGTKStyle; Data: Pointer); cdecl; begin if (Widget=nil) or (Data=nil) or (previous_style=nil) then ; {$IFDEF EventTrace} EventTrace('style-set', nil); {$ENDIF} { Note: This event is called for many widgets but not for all. It is called on creation and called when the theme changes. The resizing should occur when all styles were updated by the gtk. The gtk itself uses size messages via queue. Maybe the solution is to use g_idle_add for the top level form and resize. } //debugln('style-set after ',DbgSName(TWinControl(Data))); //LCLObject.InvalidateClientRectCache(False); end; function gtkListBoxSelectionChangedAfter(widget: PGtkWidget; data: gPointer ): GBoolean; cdecl; var Mess: TLMessage; GtkList: PGtkList; begin Result := CallBackDefaultReturn; {$IFDEF EventTrace} EventTrace('gtkListSelectionChangedAfter', data); {$ENDIF} GtkList:=PGtkList(widget); if (GtkList^.selection = nil) or (LockOnChange(PGtkObject(widget),0) > 0) then Exit; FillChar(Mess,SizeOf(Mess),0); Mess.msg := LM_SelChange; if gtkListGetSelectionMode(GtkList)=GTK_SELECTION_SINGLE then gtk_list_set_selection_mode(GtkList,GTK_SELECTION_BROWSE); DeliverMessage(Data, Mess); end; {$I gtk2DragCallback.inc} {$I gtk2ComboBoxCallback.inc} {$I gtk2PageCallback.inc}