{%MainUnit gtkproc.pp} { ***************************************************************************** * * * This file is part of the Lazarus Component Library (LCL) * * * * See the file COPYING.LCL, 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. * * * ***************************************************************************** } {$IFOPT C-} // Uncomment for local trace // {$C+} // {$DEFINE ASSERT_IS_ON} {$ENDIF} {$DEFINE ASSERT_IS_ON} 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 := DeliverMessage(Target,PaintMsg) = 0; FinalizePaintMessage(@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 begin Result := DeliverPaintMessage(Target,TheMessage); end; end; end; function DeliverGtkPaintMessage(Target: Pointer; Widget: PGtkWidget; Area: PGDKRectangle; RepaintAll: boolean): GBoolean; var MSG: TLMGtkPaint; {$IFDEF DirectPaintMsg} PaintMsg: TLMPaint; {$ENDIF} begin if (not RepaintAll) and ((Area^.Width<1) or (Area^.Width<1)) then exit; 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; {$IFDEF DirectPaintMsg} PaintMsg:= GtkPaintMessageToPaintMessage(Msg,true); Result := DeliverMessage(Target,PaintMsg) = 0; FinalizePaintMessage(@PaintMsg); {$ELSE} Result:=DeliverPostMessage(Target,Msg); {$ENDIF} 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 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; EventTrace('realize', nil); if (Data<>nil) then begin if TObject(Data) is TCustomForm then begin TheForm:=TCustomForm(Data); if TheForm.Parent=nil then begin TheWindow:=GetControlWindow(Widget); //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); end; end; if (TObject(Data) is TWinControl) then UpdateWidgetStyleOfControl(TWinControl(Data)); if not (csDesigning in TComponent(Data).ComponentState) then RealizeAccelerator(TComponent(Data),Widget); 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: PWinWidgetInfo; HiddenLCLObject, LCLObject: TObject; NewEventMask: TGdkEventMask; TheWinControl: TWinControl; ClientWidget: PGtkWidget; MainWidget: PGtkWidget; begin Result := CallBackDefaultReturn; if Data=nil then ; EventTrace('realizeafter', nil); 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 {$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF} NewEventMask:=gdk_window_get_events(GetControlWindow(Widget)) or WinWidgetInfo^.EventMask; {$IFNDEF Gtk1} gtk_widget_add_events(Widget,NewEventMask); {$ENDIF} gdk_window_set_events(GetControlWindow(Widget),NewEventMask); if (ClientWidget<>nil) and (GetControlWindow(ClientWidget)<>nil) and (ClientWidget^.Window<>Widget^.Window) then begin NewEventMask:=gdk_window_get_events(GetControlWindow(ClientWidget)) or WinWidgetInfo^.EventMask; {$IFNDEF Gtk1} gtk_widget_add_events(ClientWidget,WinWidgetInfo^.EventMask); {$ENDIF} 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; SetCursor(TheWinControl, crDefault); ConnectInternalWidgetsSignals(MainWidget,TheWinControl); UpdateWidgetStyleOfControl(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; EventTrace('show', data); 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; EventTrace('hide', data); 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; EventTrace('activate', data); 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(PGTKWindow(Widget)^.focus_widget); Mess.Result := 0; DeliverMessage(Data, Mess); //DebugLn('gtkactivateCB ',TWinControl(Data).Name,':',TWinControl(Data).ClassName); Result := CallBackDefaultReturn; end; function GTKCheckMenuToggeledCB(AMenuItem: PGTKCheckMenuItem; AData: gPointer): GBoolean; cdecl; // AData --> LCLMenuItem var LCLMenuItem: TMenuItem; begin Result := CallBackDefaultReturn; EventTrace('toggled', AData); 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 if ComponentIsDestroyingHandle(TWinControl(Data)) or (LockOnChange(PgtkObject(Widget),0)>0) then exit; EventTrace('changed', data); Mess.Msg := LM_CHANGED; DeliverMessage(Data, Mess); Result := CallBackDefaultReturn; end; function gtkchanged_editbox( widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var Mess : TLMessage; begin Result := CallBackDefaultReturn; if LockOnChange(PgtkObject(Widget),0)>0 then exit; EventTrace('changed_editbox', data); Mess.Msg := CM_TEXTCHANGED; DeliverMessage(Data, Mess); Result := CallBackDefaultReturn; 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; begin //DebugLn('gtktoggledCB ',DbgSName(TObject(Data))); Result := CallBackDefaultReturn; EventTrace('toggled', data); if LockOnChange(PgtkObject(Widget),0) > 0 then Exit; if GtkWidgetIsA(Widget,gtk_toggle_button_get_type) then begin gtk_object_set_data(PgtkObject(Widget), 'Grayed', nil); end; Mess.Msg := LM_CHANGED; Mess.Result := 0; DeliverMessage(Data, Mess); //DebugLn('gtktoggledCB END ',DbgSName(TObject(Data))); end; {$Ifdef GTK1} function gtkDrawAfter(Widget: PGtkWidget; area: PGDKRectangle; data: gPointer) : GBoolean; cdecl; var DesignOnlySignal: boolean; begin Result := CallBackDefaultReturn; EventTrace('DrawAfter', data); if not (csDesigning in TComponent(Data).ComponentState) then begin DesignOnlySignal:=GetDesignOnlySignalFlag(Widget,dstDrawAfter); if DesignOnlySignal then exit; end else begin {$IFDEF VerboseDesignerDraw} DebugLn('gtkDrawAfter', ' Widget=',DbgS(Widget),'=',GetWidgetClassName(Widget), ' ',TComponent(Data).Name, ' ',area^.x,',',area^.y,',',area^.width,',',area^.height, ''); {$ENDIF} end; DeliverGtkPaintMessage(Data,Widget,Area,false); end; {$ENDIF} function gtkExposeEventAfter(Widget: PGtkWidget; Event : PGDKEventExpose; Data: gPointer): GBoolean; cdecl; var DesignOnlySignal: boolean; begin Result := CallBackDefaultReturn; EventTrace('ExposeAfter', data); 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, ' ',Event^.area.x,',',Event^.area.y,',',Event^.area.width,',',Event^.area.height, ''); {$ENDIF} end; // the expose area is ok, but some gtk widgets repaints everything on expose // -> maximize the area DeliverGtkPaintMessage(Data,Widget,@Event^.Area,true); end; function gtkfrmactivateAfter(widget: PGtkWidget; Event : PgdkEventFocus; data: gPointer) : GBoolean; cdecl; var Mess : TLMActivate; {$IFDEF VerboseFocus} LCLObject: TObject; CurFocusWidget: PGtkWidget; {$ENDIF} begin EventTrace('activate after', data); if (Widget=nil) or (Event=nil) then ; FillChar(Mess,SizeOf(Mess),#0); {$IFDEF VerboseFocus} write('gtkfrmactivateAfter Widget=',DbgS(Widget),' Event^.theIn=',Event^.theIn); 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} UpdateMouseCaptureControl; Mess.Msg := LM_ACTIVATE; Mess.Active:=true; Mess.Minimized:=false; Mess.ActiveWindow:=0; if GtkWidgetIsA(Widget, gtk_window_get_type) then Mess.ActiveWindow:=HWnd(PGTKWindow(Widget)^.focus_widget); Mess.Result := 0; DeliverMessage(Data, Mess); // send message directly (not Post) Result := CallBackDefaultReturn; end; function gtkfrmdeactivateAfter( widget: PGtkWidget; Event : PgdkEventFocus; data: gPointer) : GBoolean; cdecl; var Mess : TLMActivate; {$IFDEF VerboseFocus} LCLObject: TControl; {$ENDIF} begin EventTrace('deactivate after', data); if (Widget=nil) or (Event=nil) then ; {$IFDEF VerboseFocus} write('gtkfrmdeactivate Widget=',DbgS(Widget),' ',Event^.theIn, ' GetFocus=',DbgS(Widget)); LCLObject:=TControl(GetLCLObject(Widget)); if LCLObject<>nil then DebugLn(' LCLObject=',LCLObject.Name,':',LCLObject.ClassName) else DebugLn(' LCLObject=nil'); {$ENDIF} UpdateMouseCaptureControl; Mess.Msg := LM_DEACTIVATE; DeliverMessage(Data, Mess); Result := CallBackDefaultReturn; end; function GTKMap(Widget: PGTKWidget; Data: gPointer): GBoolean; cdecl; begin Result := CallBackDefaultReturn; if (Widget=nil) then ; EventTrace('map', data); end; function GTKKeyUpDown(Widget: PGtkWidget; Event: PGdkEventKey; Data: gPointer) : GBoolean; cdecl; begin Result:=HandleGtkKeyUpDown(Widget,Event,Data,true); end; function GTKKeyUpDownAfter(Widget: PGtkWidget; Event: pgdkeventkey; Data: gPointer): GBoolean; cdecl; begin Result:=HandleGtkKeyUpDown(Widget,Event,Data,false); end; function GTKFocusCB( widget: PGtkWidget; event:PGdkEventFocus; data: gPointer) : GBoolean; cdecl; {$IFDEF VerboseFocus} var LCLObject: TObject; CurFocusWidget: PGtkWidget; {$ENDIF} begin EventTrace('focus', data); if (Widget=nil) or (Event=nil) then ; {$IFDEF VerboseFocus} write('GTKFocusCB Widget=',DbgS(Widget),' Event^.theIn=',Event^.theIn); 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} Result:=true; end; function GTKFocusCBAfter(widget: PGtkWidget; event:PGdkEventFocus; data: gPointer) : GBoolean; cdecl; var Mess : TLMessage; {$IFDEF VerboseFocus} LCLObject: TObject; CurFocusWidget: PGtkWidget; {$ENDIF} begin EventTrace('focus', data); if (Widget=nil) or (Event=nil) then ; {$IFDEF VerboseFocus} write('GTKFocusCBAfter Widget=',DbgS(Widget),' Event^.theIn=',Event^.theIn); 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} UpdateMouseCaptureControl; //TODO: fill in old focus FillChar(Mess,SizeOf(Mess),0); Mess.msg := LM_SETFOCUS; DeliverMessage(Data, Mess); Result:=true; end; function GTKKillFocusCB(widget: PGtkWidget; event:PGdkEventFocus; data: gPointer) : GBoolean; cdecl; {$IFDEF VerboseFocus} var LCLObject: TObject; CurFocusWidget: PGtkWidget; {$ENDIF} begin EventTrace('killfocus', data); if (Widget=nil) or (Event=nil) then ; {$IFDEF VerboseFocus} write('GTKillFocusCB Widget=',DbgS(Widget),' Event^.theIn=',Event^.theIn); 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} Result:=true; 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 ; EventTrace('killfocus', data); {$IFDEF VerboseFocus} write('GTKillFocusCBAfter Widget=',DbgS(Widget),' Event^.theIn=',Event^.theIn); 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} UpdateMouseCaptureControl; FillChar(Mess,SizeOf(Mess),0); Mess.msg := LM_KILLFOCUS; //TODO: fill in new focus Assert(False, Format('Trace:TODO: [gtkkillfocusCB] %s finish', [TObject(Data).ClassName])); DeliverMessage(Data, Mess); Result:=true; end; function gtkdestroyCB(widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var Mess: TLMessage; begin Result := CallBackDefaultReturn; EventTrace('destroy', data); FillChar(Mess,SizeOf(Mess),0); Mess.msg := LM_DESTROY; DeliverMessage(Data, Mess); Result := CallBackDefaultReturn; // NOTE: if the destroy message is posted // we should post an info destroy message as well FreeWidgetInfo(Widget); 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 ; EventTrace('resize', data); // 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 ; EventTrace('month changed', data); 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 if (Widget=nil) then ; MappedXY:=TranslateGdkPointToClientArea(Event^.Window, Point(TruncToInt(Event^.X),TruncToInt(Event^.Y)), PGtkWidget(AWinControl.Handle)); ShiftState := GTKEventState2ShiftState(Event^.State); with Msg do begin Msg := LM_MouseMove; XPos := MappedXY.X; YPos := MappedXY.Y; Keys := 0; if ssShift in ShiftState then Keys := Keys or MK_SHIFT; if ssCtrl in ShiftState then Keys := Keys or MK_CONTROL; if ssLeft in ShiftState then Keys := Keys or MK_LBUTTON; if ssRight in ShiftState then Keys := Keys or MK_RBUTTON; if ssMiddle in ShiftState then Keys := Keys or MK_MBUTTON; 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); 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; {------------------------------------------------------------------------------- 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; begin Result := CallBackDefaultReturn; {$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; 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'); end; DeliverMouseMoveMessage(Widget,Event,TWinControl(Data)); 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 := CallBackDefaultReturn; {$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; {$IFDEF Gtk2} function GTKWindowStateEventCB(widget: PGtkWidget; state: PGdkEventWindowState; data: gpointer): gboolean; cdecl; var TheForm: TCustomForm; SizeMsg: TLMSize; GtkWidth: LongInt; GtkHeight: LongInt; begin Result := CallBackDefaultReturn; // if iconified in changed then OnIconify... if TObject(Data) is TCustomForm then begin TheForm := TCustomForm(Data); if TheForm.Parent = nil then begin (* toplevel window, just as a sanity check *) if GTK_WIDGET_REALIZED(Widget) then begin // send a WMSize Message (see TCustomForm.WMSize) 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)); if (GDK_WINDOW_STATE_ICONIFIED and state^.new_window_state)>0 then SizeMsg.SizeType:=SIZEICONIC else if (GDK_WINDOW_STATE_MAXIMIZED and state^.new_window_state)>0 then SizeMsg.SizeType:=SIZEFULLSCREEN else SizeMsg.SizeType:=SIZENORMAL; with SizeMsg do begin Result := 0; Msg := LM_SIZE; SizeType := SizeType+Size_SourceIsInterface; Width := SmallInt(GtkWidth); Height := SmallInt(GtkHeight); end; DeliverMessage(TheForm, SizeMsg); end; end; end; end; {$ENDIF} {------------------------------------------------------------------------------- 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 {$IFDEF Gtk1} Result:=false; {$ENDIF} end; 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 = (-1, 1); 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 if (Widget=nil) then ; EventXY:=Point(TruncToInt(Event^.X),TruncToInt(Event^.Y)); ShiftState := GTKEventState2ShiftState(Event^.State); MappedXY:=TranslateGdkPointToClientArea(Event^.Window,EventXY, PGtkWidget(AWinControl.Handle)); //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; if ssShift in ShiftState then MessI.Keys := MessI.Keys or MK_SHIFT; if ssCtrl in ShiftState then MessI.Keys := MessI.Keys or MK_CONTROL; if ssLeft in ShiftState then MessI.Keys := MessI.Keys or MK_LBUTTON; if ssRight in ShiftState then MessI.Keys := MessI.Keys or MK_RBUTTON; if ssMiddle in ShiftState then MessI.Keys := MessI.Keys or MK_MBUTTON; MessI.Result:=0; // send the message directly to the LCL NotifyApplicationUserInput(MessI.Msg); DeliverMessage(AWinControl, MessI); end; 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. -------------------------------------------------------------------------------} 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; CaptureWidget: PGtkWidget; EventXY: TPoint; MappedXY: TPoint; begin Result := CallBackDefaultReturn; {$IFDEF VerboseMouseBugfix} DebugLn(''); DesignOnlySignal:=GetDesignOnlySignalFlag(Widget,dstMousePress); DebugLn('[gtkMouseBtnPress] ', DbgSName(TObject(Data)), ' Widget=',DbgS(Widget), ' ControlWidget=',DbgS(TWinControl(Data).Handle), ' DSO='+dbgs(DesignOnlySignal), ' '+dbgs(TruncToInt(Event^.X)),',',dbgs(TruncToInt(Event^.Y)), ' Type='+dbgs(gdk_event_get_type(Event))); {$ENDIF} //DebugLn('DDD1 MousePress Widget=',DbgS(Widget), //' ClientWidget=',DbgS(GetFixedWidget(Widget)), //' EventMask=',DbgS(gdk_window_get_events(Widget^.Window)), //' GDK_BUTTON_RELEASE_MASK=',DbgS(GDK_BUTTON_RELEASE_MASK), //' Window=',DbgS(Widget^.Window) //); //if GetFixedWidget(Widget)<>nil then // DebugLn('DDD2 ClientWindow=',DbgS(PGtkWidget(GetFixedWidget(Widget))^.Window)); EventTrace('Mouse button Press', data); 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; CaptureWidget:=PGtkWidget(TWinControl(Data).Handle); if Event^.button=1 then begin EventXY:=Point(TruncToInt(Event^.X),TruncToInt(Event^.Y)); MappedXY:=TranslateGdkPointToClientArea(Event^.Window,EventXY,CaptureWidget); SetCaptureControl(TWinControl(Data),MappedXY); //CaptureMouseForWidget(CaptureWidget,mctGTKIntf); end; end else begin // stop the signal, so that the widget does not auto react if (not (TControl(Data) is TCustomNoteBook)) or (event^.Button<>1) then begin g_signal_stop_emission_by_name(PGTKObject(Widget),'button-press-event'); Result := not CallBackDefaultReturn; end; end; //debugln('[gtkMouseBtnPress] calling DeliverMouseDownMessage Result=',dbgs(Result)); DeliverMouseDownMessage(Widget,Event,TWinControl(Data)); 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 := CallBackDefaultReturn; {$IFDEF VerboseMouseBugfix} debugln('[gtkMouseBtnPressAfter] ', DbgSName(TObject(Data)), ' Widget=',DbgS(Widget), ' ', gtk_type_name(Widget^.theObject.klass^.thetype), ' ',dbgs(TruncToInt(Event^.X)),',',dbgs(TruncToInt(Event^.Y))); {$ENDIF} 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 ; {$IFDEF Gtk1} case AControl.fCompStyle of csCheckBox, csRadioButton, csToggleBox: Result:=false; end; {$ENDIF} end; {------------------------------------------------------------------------------- procedure DeliverMouseUpMessage(widget: PGtkWidget; event : pgdkEventButton; AWinControl: TWinControl); Translate a gdk mouse release event into a LCL mouse up message and send it. -------------------------------------------------------------------------------} procedure DeliverMouseUpMessage(widget: PGtkWidget; event: pgdkEventButton; AWinControl: TWinControl); 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 if (Widget=nil) then ; MappedXY:=TranslateGdkPointToClientArea(Event^.Window, Point(TruncToInt(Event^.X),TruncToInt(Event^.Y)), PGtkWidget(AWinControl.Handle)); 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 := gtkeventstate2shiftstate(Event^.State); MessI.Keys := 0; if ssShift in ShiftState then MessI.Keys := MessI.Keys or MK_SHIFT; if ssCtrl in ShiftState then MessI.Keys := MessI.Keys or MK_CONTROL; if ssLeft in ShiftState then MessI.Keys := MessI.Keys or MK_LBUTTON; if ssRight in ShiftState then MessI.Keys := MessI.Keys or MK_RBUTTON; if ssMiddle in ShiftState then MessI.Keys := MessI.Keys or MK_MBUTTON; 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); 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; begin Result := CallBackDefaultReturn; {$IFDEF VerboseMouseBugfix} DesignOnlySignal:=GetDesignOnlySignalFlag(Widget,dstMouseRelease); DebugLn('[gtkMouseBtnRelease] A ',DbgSName(TObject(Data)),' ', ' Widget=',DbgS(Widget), ' DSO=',dbgs(DesignOnlySignal), ' ',dbgs(TruncToInt(Event^.X)),',',dbgs(TruncToInt(Event^.Y)),' Btn=',dbgs(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)); UpdateMouseCaptureControl; if not (csDesigning in TComponent(Data).ComponentState) then begin DesignOnlySignal:=GetDesignOnlySignalFlag(Widget,dstMouseRelease); ReleaseMouseCapture; if DesignOnlySignal or (not ControlGetsMouseUpBefore(TControl(Data))) then begin exit; end; end else begin // stop the signal, so that the widget does not auto react if not (TControl(Data) is TCustomNoteBook) then g_signal_stop_emission_by_name(PGTKObject(Widget),'button-release-event'); Result := not CallBackDefaultReturn; end; DeliverMouseUpMessage(Widget,Event,TWinControl(Data)); 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 := CallBackDefaultReturn; {$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'); UpdateMouseCaptureControl; if (csDesigning in TComponent(Data).ComponentState) then exit; if ControlGetsMouseUpBefore(TControl(Data)) then exit; DeliverMouseUpMessage(Widget,Event,TWinControl(Data)); 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 GTKDialogSelectRowCB Params: widget: PGtkWidget; data: gPointer Result: GBoolean This function is called, whenever a row is selected in a commondialog -------------------------------------------------------------------------------} function gtkDialogSelectRowCB(widget: PGtkWidget; Row, Column: gInt; bevent: pgdkEventButton; data: gPointer): GBoolean; cdecl; var theDialog: TCommonDialog; MenuWidget: PGtkWidget; AFilterEntry: PFileSelFilterEntry; FileSelWidget: PGtkFileSelection; ShiftState: TShiftState; loop : gint; startRow : gint; endRow : gint; begin //debugln('GTKDialogSelectRowCB A '); Result:=CallBackDefaultReturn; if (Data=nil) or (BEvent=nil) or (Column=0) or (Row=0) then ; theDialog:=TCommonDialog(GetLCLObject(Widget)); if (theDialog is TOpenDialog) then begin // only process the callback if there is event data. If there isn't any // event data that means it was called due to a direct function call of the // widget and not an actual mouse click on the widget. FileSelWidget:=PGtkFileSelection(theDialog.Handle); if (bevent <> nil) and (gdk_event_get_type(bevent) = GDK_2BUTTON_PRESS) and (FileSelWidget^.dir_list = widget) then begin MenuWidget := gtk_object_get_data(PGtkObject(FileSelWidget), 'LCLFilterMenu'); if MenuWidget <> nil then begin AFilterEntry := gtk_object_get_data(PGtkObject( gtk_menu_get_active(PGtkMenu(MenuWidget))), 'LCLIsFilterMenuItem'); if (AFilterEntry<>nil) and (AFilterEntry^.Mask<>nil) then PopulateFileAndDirectoryLists(FileSelWidget,AFilterEntry^.Mask); end; end else if (bevent <> nil) and (ofAllowMultiSelect in TOpenDialog(theDialog).Options) and (FileSelWidget^.file_list=widget) then begin // multi selection ShiftState := GTKEventState2ShiftState(BEvent^.State); if ssShift in ShiftState then begin if LastFileSelectRow <> -1 then begin startRow := LastFileSelectRow; endRow := row; if LastFileSelectRow > row then begin startRow := row; endRow := LastFileSelectRow; end; for loop := startRow to endRow do begin gtk_clist_select_row(PGtkCList(widget), loop, column); end; end; end else if not (ssCtrl in ShiftState) then begin gtk_clist_unselect_all(PGtkCList(widget)); gtk_clist_select_row(PGtkCList(widget), row, column); end; LastFileSelectRow := row; end; UpdateDetailView(TOpenDialog(theDialog)); end; end; function gtkDialogOKclickedCB( widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var theDialog : TCommonDialog; Fpointer : Pointer; // colordialog colorsel : PGtkColorSelection; newColor : TGdkColor; // fontdialog FontName : String; ALogFont : TLogFont; // filedialog rowNum : gint; fileInfo : PGChar; {$IfDef GTK2} fileList : PPgchar; {$else} cListRow : PGList; fileList : PGTKCList; {$EndIf} DirName : string; FileName : string; Files: TStringList; CurFilename: string; //SelectedFont: PGdkFont; function CheckOpenedFilename(const AFilename: string): boolean; begin Result:=true; if (ofOverwritePrompt in TOpenDialog(theDialog).Options) and FileExists(AFilename) then begin Result:=MessageDlg(rsfdOverwriteFile, Format(rsfdFileAlreadyExists,[AFileName]), mtConfirmation,[mbOk,mbCancel],0)=mrOk; if not Result then exit; end; end; procedure AddFile(List: TStrings; const NewFile: string); var i: Integer; begin for i:=0 to List.Count-1 do if List[i]=NewFile then exit; List.Add(NewFile); end; begin Result := True; if (Widget=nil) then ; theDialog := TCommonDialog(data); FPointer := Pointer(theDialog.Handle); if theDialog is TFileDialog then begin if theDialog is TOpenDialog then begin // check extra options if ofAllowMultiSelect in TOpenDialog(theDialog).Options then begin FileName:=gtk_file_selection_get_filename( PGtkFileSelection(FPointer)); DirName:=ExtractFilePath(FileName); TFileDialog(data).FileName := ''; Files:=TStringList(TFileDialog(theDialog).Files); Files.Clear; if (Filename<>'') then begin Result:=CheckOpenedFilename(Filename); if not Result then exit; AddFile(Files,FileName); end; {$IfDef GTK2} fileList := gtk_file_selection_get_selections(PGtkFileSelection(FPointer)); rowNum := 0; While FileList^ <> nil do begin fileInfo := FileList^; CurFilename:=fileInfo; // convert PChar to AnsiString (not typecast) if (CurFilename<>'') and (Files.IndexOf(CurFilename)<0) then begin CurFilename:=DirName+fileInfo; Result:=CheckOpenedFilename(CurFilename); if not Result then exit; Files.Add(CurFilename); end; inc(FileList); inc(rowNum); end; Dec(FileList, rowNum); g_strfreev(fileList); {$Else} fileList := PGtkCList(PGtkFileSelection(FPointer)^.file_list); rowNum := 0; cListRow := fileList^.row_list; while cListRow <> nil do begin if PGtkCListRow(cListRow^.data)^.state = GTK_STATE_SELECTED then begin if gtk_clist_get_cell_type(fileList, rowNum, 0) = GTK_CELL_TEXT then begin gtk_clist_get_text(fileList, rowNum, 0, @fileInfo); CurFilename:=DirName+fileInfo; Result:=CheckOpenedFilename(CurFilename); if not Result then exit; AddFile(Files,CurFilename); end; end; // get next row from list rowNum := rowNum + 1; cListRow := g_list_next(cListRow); end; {$EndIf} end else begin CurFilename:= gtk_file_selection_get_filename(PGtkFileSelection(FPointer)); Result:=CheckOpenedFilename(CurFilename); if not Result then exit; TFileDialog(data).FileName := CurFilename; end; end else begin TFileDialog(data).FileName := gtk_file_selection_get_filename(PGtkFileSelection(FPointer)); end; end else if theDialog is TColorDialog then begin colorSel := PGtkColorSelection(PGtkColorSelectionDialog(FPointer)^.colorsel); gtk_color_selection_get_current_color(colorsel, @newColor); TColorDialog(theDialog).Color := TGDKColorToTColor(newcolor); {$IFDEF VerboseColorDialog} DebugLn('gtkDialogOKclickedCB ',DbgS(TColorDialog(theDialog).Color)); {$ENDIF} end else if theDialog is TFontDialog then begin Assert(False, 'Trace:Pressed OK in FontDialog'); FontName := gtk_font_selection_dialog_get_font_name( pgtkfontselectiondialog(FPointer)); //debugln('gtkDialogOKclickedCB FontName=',FontName); //SelectedFont:=gdk_font_load(PChar(FontName)); //debugln('gtkDialogOKclickedCB ',dbgs(SelectedFont)); // extract basic font attributes from the font name in XLFD format ALogFont:=XLFDNameToLogFont(FontName); TFontDialog(theDialog).Font.Assign(ALogFont); // set the font name in XLFD format // a font name in XLFD format overrides in the gtk interface all other font // settings. TFontDialog(theDialog).Font.Name := FontName; Assert(False, 'Trace:-----'+TFontDialog(theDialog).Font.Name+'----'); end; StoreCommonDialogSetup(theDialog); theDialog.UserChoice := mrOK; end; {------------------------------------------------------------------------------- function gtkDialogCancelclickedCB Params: widget: PGtkWidget; data: gPointer Result: GBoolean This function is called, whenever the user clicks the cancel button in a commondialog -------------------------------------------------------------------------------} function gtkDialogCancelclickedCB(widget: PGtkWidget; data: gPointer): GBoolean; cdecl; var theDialog : TCommonDialog; begin Result := CallBackDefaultReturn; if (Widget=nil) then ; theDialog := TCommonDialog(data); if theDialog is TFileDialog then begin TFileDialog(data).FileName := ''; end; StoreCommonDialogSetup(theDialog); theDialog.UserChoice := mrCancel; end; {------------------------------------------------------------------------------- function gtkDialogHelpclickedCB Params: widget: PGtkWidget; data: gPointer Result: GBoolean This function is called, whenever the user clicks the help button in a commondialog -------------------------------------------------------------------------------} function gtkDialogHelpclickedCB(widget: PGtkWidget; data: gPointer): GBoolean; cdecl; var theDialog : TCommonDialog; begin Result := CallBackDefaultReturn; if (Widget=nil) then ; theDialog := TCommonDialog(data); if theDialog is TOpenDialog then begin if TOpenDialog(theDialog).OnHelpClicked<>nil then TOpenDialog(theDialog).OnHelpClicked(theDialog); end; end; {------------------------------------------------------------------------------- function gtkDialogApplyclickedCB Params: widget: PGtkWidget; data: gPointer Result: GBoolean This function is called, whenever the user clicks the Apply button in a commondialog -------------------------------------------------------------------------------} function gtkDialogApplyclickedCB(widget: PGtkWidget; data: gPointer): GBoolean; cdecl; var theDialog : TCommonDialog; FontName: string; ALogFont: TLogFont; begin Result := CallBackDefaultReturn; if (Widget=nil) then ; theDialog := TCommonDialog(data); if (theDialog is TFontDialog) and (fdApplyButton in TFontDialog(theDialog).Options) and (Assigned(TFontDialog(theDialog).OnApplyClicked)) then begin // extract basic font attributes from the font name in XLFD format FontName := gtk_font_selection_dialog_get_font_name( pgtkfontselectiondialog(theDialog.Handle)); ALogFont:=XLFDNameToLogFont(FontName); TFontDialog(theDialog).Font.Assign(ALogFont); // set the font name in XLFD format // a font name in XLFD format overrides in the gtk interface all other font // settings. TFontDialog(theDialog).Font.Name := FontName; TFontDialog(theDialog).OnApplyClicked(theDialog); end; end; {------------------------------------------------------------------------------- function gtkDialogCloseQueryCB Params: widget: PGtkWidget; data: gPointer Result: GBoolean This function is called, before a commondialog is destroyed -------------------------------------------------------------------------------} function gtkDialogCloseQueryCB(widget: PGtkWidget; data: gPointer): GBoolean; cdecl; var theDialog : TCommonDialog; CanClose: boolean; begin Result := False; // true = do nothing, false = destroy or hide window if (Data=nil) then ; // data is not the commondialog. Get it manually. theDialog := TCommonDialog(GetLCLObject(Widget)); if theDialog=nil then exit; if theDialog.OnCanClose<>nil then begin CanClose:=True; theDialog.OnCanClose(theDialog,CanClose); Result:=not CanClose; end; if not Result then begin StoreCommonDialogSetup(theDialog); DestroyCommonDialogAddOns(theDialog); end; end; {------------------------------------------------------------------------------- procedure UpdateDetailView Params: OpenDialog: TOpenDialog Result: none Shows some OS dependent information about the current file -------------------------------------------------------------------------------} procedure UpdateDetailView(OpenDialog: TOpenDialog); var FileDetailLabel: PGtkWidget; Filename, OldFilename, Details: string; begin Filename:= gtk_file_selection_get_filename(PGtkFileSelection(OpenDialog.Handle)); OldFilename:=OpenDialog.Filename; if Filename=OldFilename then exit; OpenDialog.Filename:=Filename; // tell application, that selection has changed OpenDialog.DoSelectionChange; if (OpenDialog.OnFolderChange<>nil) and (ExtractFilePath(Filename)<>ExtractFilePath(OldFilename)) then OpenDialog.DoFolderChange; // show some information FileDetailLabel:=gtk_object_get_data(PGtkObject(OpenDialog.Handle), 'FileDetailLabel'); if FileDetailLabel=nil then exit; if FileExists(Filename) then begin Details:=GetFileDescription(Filename); end else begin Details:=Format(rsFileInfoFileNotFound, [Filename]); end; gtk_label_set_text(PGtkLabel(FileDetailLabel),PChar(Details)); end; {------------------------------------------------------------------------------- function GTKDialogKeyUpDownCB Params: Widget: PGtkWidget; Event : pgdkeventkey; Data: gPointer Result: GBoolean This function is called, whenever a key is pressed or released in a common dialog window -------------------------------------------------------------------------------} function GTKDialogKeyUpDownCB(Widget: PGtkWidget; Event : pgdkeventkey; Data: gPointer) : GBoolean; cdecl; begin //debugln('GTKDialogKeyUpDownCB A '); Result:=CallBackDefaultReturn; if (Widget=nil) then ; case gdk_event_get_type(Event) of GDK_KEY_RELEASE, GDK_KEY_PRESS: begin if Event^.KeyVal = GDK_KEY_Escape then begin StoreCommonDialogSetup(TCommonDialog(data)); TCommonDialog(data).UserChoice:=mrCancel; end; if (TCommonDialog(data) is TOpenDialog) then begin UpdateDetailView(TOpenDialog(data)); end; end; end; end; {------------------------------------------------------------------------------- function GTKDialogRealizeCB Params: Widget: PGtkWidget; Data: Pointer Result: GBoolean This function is called, whenever a commondialog window is realized -------------------------------------------------------------------------------} function GTKDialogRealizeCB(Widget: PGtkWidget; Data: Pointer): GBoolean; cdecl; var LCLComponent: TObject; begin if (Data=nil) then ; gdk_window_set_events(GetControlWindow(Widget), gdk_window_get_events(GetControlWindow(Widget)) or GDK_KEY_RELEASE_MASK or GDK_KEY_PRESS_MASK); LCLComponent:=GetLCLObject(Widget); if LCLComponent is TCommonDialog then TCommonDialog(LCLComponent).DoShow; Result:=true; end; {------------------------------------------------------------------------------- function GTKDialogFocusInCB Params: widget: PGtkWidget; data: gPointer Result: GBoolean This function is called, when a widget of a commondialog gets focus -------------------------------------------------------------------------------} function GTKDialogFocusInCB(widget: PGtkWidget; data: gPointer): GBoolean; cdecl; var theDialog: TCommonDialog; begin //debugln('GTKDialogFocusInCB A '); Result:=CallBackDefaultReturn; if (Data=nil) then ; theDialog:=TCommonDialog(GetLCLObject(Widget)); if (theDialog is TOpenDialog) then begin UpdateDetailView(TOpenDialog(theDialog)); end; end; {------------------------------------------------------------------------------- function GTKDialogMenuActivateCB Params: widget: PGtkWidget; data: gPointer Result: GBoolean This function is called, whenever a menu of a commondialog is activated -------------------------------------------------------------------------------} function GTKDialogMenuActivateCB(widget: PGtkWidget; data: gPointer): GBoolean; cdecl; var theDialog: TCommonDialog; procedure CheckFilterActivated(FilterWidget: PGtkWidget); var AFilterEntry: PFileSelFilterEntry; begin if FilterWidget=nil then exit; AFilterEntry:=gtk_object_get_data(PGtkObject(FilterWidget), 'LCLIsFilterMenuItem'); if (AFilterEntry<>nil) and (AFilterEntry^.Mask<>nil) then begin PopulateFileAndDirectoryLists(PGtkFileSelection(theDialog.Handle), AFilterEntry^.Mask); TOpenDialog(TheDialog).FilterIndex := AFilterEntry^.FilterIndex + 1; UpdateDetailView(TOpenDialog(theDialog)); end; end; var AHistoryEntry: PFileSelHistoryEntry; FilterMenu, ActiveFilterMenuItem: PGtkWidget; begin Result:=false; if (Data=nil) then ; theDialog:=TCommonDialog(GetNearestLCLObject(Widget)); if (theDialog is TOpenDialog) then begin // check if history activated AHistoryEntry:=gtk_object_get_data(PGtkObject(Widget), 'LCLIsHistoryMenuItem'); if (AHistoryEntry<>nil) and (AHistoryEntry^.Filename<>nil) then begin // user has choosen a history file // -> select it in the filedialog gtk_file_selection_complete(PGtkFileSelection(theDialog.Handle), AHistoryEntry^.Filename); // restore filter if DirPathExists(AHistoryEntry^.Filename) then begin FilterMenu:=gtk_object_get_data(PGtkObject(theDialog.Handle), 'LCLFilterMenu'); if FilterMenu<>nil then begin ActiveFilterMenuItem:=gtk_menu_get_active(GTK_MENU(FilterMenu)); CheckFilterActivated(ActiveFilterMenuItem); end; end; UpdateDetailView(TOpenDialog(theDialog)); end; // check if filter activated CheckFilterActivated(Widget); end; end; {------------------------------------------------------------------------------- function gtkDialogDestroyCB Params: widget: PGtkWidget; data: gPointer Result: GBoolean This function is called, when a commondialog is destroyed -------------------------------------------------------------------------------} function gtkDialogDestroyCB(widget: PGtkWidget; data: gPointer): GBoolean; cdecl; begin Result := True; if (Widget=nil) then ; TCommonDialog(data).UserChoice := mrAbort; TCommonDialog(data).Close; end; function gtkPressedCB( widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var Mess : TLMessage; begin Result := CallBackDefaultReturn; if (Widget=nil) then ; EventTrace('pressed', data); Mess.msg := LM_PRESSED; DeliverMessage(Data, Mess); Result := CallBackDefaultReturn; end; function gtkEnterCB(widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var Mess : TLMessage; begin Result := CallBackDefaultReturn; EventTrace('enter', data); 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 := CM_MOUSEENTER; DeliverMessage(Data, Mess); Result := CallBackDefaultReturn; end; function gtkLeaveCB(widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var Mess : TLMessage; begin Result := CallBackDefaultReturn; EventTrace('leave', data); 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 := CM_MOUSELEAVE; DeliverMessage(Data, Mess); Result := CallBackDefaultReturn; end; function gtkMoveCursorCB(widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var Mess : TLMessage; begin Result := CallBackDefaultReturn; if (Widget=nil) then ; EventTrace('move-cursor', data); Mess.msg := LM_MOVECURSOR; DeliverMessage(Data, Mess); end; function gtksize_allocateCB(widget: PGtkWidget; size: pGtkAllocation; data: gPointer) : GBoolean; cdecl; 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); RaiseException(''); exit; end; { The gtk sends the size messages after the resizing. Therefore the parent widget is already resized, but the parent resize message will be emitted after all its childs. So, the gtk resizes in top-bottom order, just like the LCL. But it sends size messages in bottom-top order, which results in many resizes in the LCL. Therefore all resize messages between lcl and gtk are cached. } {$IFDEF VerboseSizeMsg} DebugLn('gtksize_allocateCB: ', TControl(Data).Name+':'+TControl(Data).ClassName, ' widget='+DbgS(Widget)+WidgetFlagsToString(widget)+ ' fixwidget=',DbgS(GetFixedWidget(Widget)), ' GtkPos=',dbgs(Widget^.allocation.x)+','+dbgs(Widget^.allocation.y), ','+dbgs(Widget^.allocation.width)+'x'+dbgs(Widget^.allocation.width)+ ' LCLPos='+dbgs(TControl(Data).Left)+','+dbgs(TControl(Data).Top), ','+dbgs(TControl(Data).Width)+'x'+dbgs(TControl(Data).Height)); {$ENDIF} {$IFDEF VerboseFormPositioning} if TControl(Data) is TCustomForm then DebugLn('VFP gtksize_allocateCB: ',TControl(Data).ClassName,' ',dbgs(Size^.X),',',dbgs(Size^.Y)); {$ENDIF} if GTK_WIDGET_REALIZED(Widget) then SaveSizeNotification(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 SaveClientSizeNotification(ClientWidget); end else begin // owner is not TWinControl -> ignore DebugLn('WARNING: gtksize_allocate_client: Data is not TWinControl. Data=', DbgS(Data)); exit; end; end; function gtkswitchpage(widget: PGtkWidget; page: Pgtkwidget; pagenum: integer; data: gPointer): GBoolean; cdecl; var Mess: TLMNotify; NMHdr: tagNMHDR; SwitchAllowed: Boolean; begin Result := CallBackDefaultReturn; if (Widget=nil) or (Page=nil) then ; EventTrace('switch-page', data); UpdateNoteBookClientWidget(TObject(Data)); // gtkswitchpage is called before the switch // send first the TCN_SELCHANGING to ask if switch is allowed FillChar(Mess,SizeOf(Mess),0); Mess.Msg := LM_NOTIFY; FillChar(NMHdr,SizeOf(NMHdr),0); NMHdr.code := TCN_SELCHANGING; NMHdr.hwndfrom := PtrInt(widget); NMHdr.idfrom := pagenum; //use this to set pageindex to the correct page. Mess.NMHdr := @NMHdr; Mess.Result := 0; DeliverMessage(Data, Mess); SwitchAllowed:=Mess.Result=0; if not SwitchAllowed then begin debugln('gtkswitchpage A SwitchAllowed=false not yet implemented'); end; // then send the new page FillChar(Mess,SizeOf(Mess),0); Mess.Msg := LM_NOTIFY; FillChar(NMHdr,SizeOf(NMHdr),0); NMHdr.code := TCN_SELCHANGE; NMHdr.hwndfrom := ptrint(widget); NMHdr.idfrom := pagenum; //use this to set pageindex to the correct page. Mess.NMHdr := @NMHdr; DeliverMessage(Data, Mess); end; function gtkconfigureevent( widget: PGtkWidget; event : PgdkEventConfigure; data: gPointer) : GBoolean; cdecl; var Allocation : PGtkAllocation; 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. } New(Allocation); try with Allocation^ do begin X:= Event^.X; Y:= Event^.Y; Width:= Event^.Width; Height:= Event^.Height; end; Result:= gtksize_allocateCB( Widget, Allocation, Data); finally Dispose(Allocation); end; end; function gtkreleasedCB( widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var Mess : TLMEssage; begin Result := CallBackDefaultReturn; if (Widget=nil) then ; EventTrace('released', data); Mess.msg := LM_RELEASED; DeliverMessage(Data, Mess); 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 begin gtk_editable_insert_text(PGtkEditable(widget), char, NewTextLength - CutLength, Position); end; 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 gtkDeleteText( widget: PGtkWidget; Startpos, EndPos : Integer; data: gPointer) : GBoolean; cdecl; var Mess : TLMessage; begin EventTrace('Delete Text', data); if (StartPos=0) or (EndPos=0) or (Widget=nil) then ; Mess.msg := LM_DELETETEXT; Result:= DeliverMessage(Data, Mess) = 0; 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; begin EventTrace('Cut to clip', data); if (Widget=nil) then ; Mess.msg := LM_CUTTOCLIP; 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_COPYTOCLIP; Result:= DeliverMessage(Data, Mess) = 0; end; function gtkPasteFromClip( widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var Mess : TLMessage; begin EventTrace('Paste from clip', data); if (Widget=nil) then ; Mess.msg := LM_PASTEFROMCLIP; Result:= DeliverMessage(Data, Mess) = 0; end; function gtkValueChanged(widget: PGtkWidget; data: gPointer) : GBoolean; cdecl; var Mess : TLMessage; begin Result := CallBackDefaultReturn; EventTrace('Value changed', data); if (Widget=nil) then ; 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): {$IFDEF Gtk2}gBoolean{$ELSE}gint{$ENDIF}; 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 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); EventTrace ('FocusInNotify (alias Enter)', data); 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); EventTrace ('FocusOutNotify (alias Exit)', data); 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; {$IFDEF gtk1} function gtk_range_get_update_policy(range: PGTKRange): TGtkUpdateType; begin result := policy(Range^); end; {$ENDIF} function get_gtk_scroll_type(range: PGTKRange): TGtkScrollType; {$IFNDEF gtk1} type TUnOpaqueTimer=record timeout_id: guint; ScrollType: TGTkScrollType; end; PUnOpaqueTimer=^TUnopaqueTimer; {$ENDIF} begin {$IFDEF gtk1} Result := Scroll_type(Range^); {$ELSE} 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; {$ENDIF} 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 '); {$ifdef gtk2} 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'); {$endif} 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; {$ifdef GTK2} 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; {$endif} 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(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 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(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: 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 Byte = ( GDK_SHIFT_MASK, // shift GDK_CONTROL_MASK, // control GDK_MOD1_MASK, // alt GDK_MOD4_MASK // win ); 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 VKey: TVKeyRecord; Pressed: Boolean; n: Integer; 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; VKey := KeySymToVKey(Event^.keyval); if VKey.VKey = $FF then begin if Pressed then DebugLn(Format('[WARNING] Key pressed without VKey: K=0x%x S="%s"', [ Event^.KeyVal, {$IFDEF GTK2} Event^._String {$ELSE} Event^.theString {$ENDIF} ])); Exit; end; if FuncData=nil then exit; KeyStateList := TObject(FuncData) as TFPList; UpdateList(Vkey.VKey, Pressed); if IsToggleKey(Vkey.VKey) then UpdateToggleList(Vkey.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.Vkey = VK_MAP[n][0] then Continue; if VKey.Vkey = VK_MAP[n][1] then Continue; if VKey.Vkey = VK_MAP[n][2] then Continue; UpdateList(VK_MAP[n][0], (STATE_MAP[n] and Event^.State) <> 0); UpdateList(VK_MAP[n][1], (STATE_MAP[n] and Event^.State) <> 0); UpdateList(VK_MAP[n][2], (STATE_MAP[n] and Event^.State) <> 0); 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 ((VKey.Flags and VKEY_FLAG_MULTI_VK) <> 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; {------------------------------------------------------------------------------ ClipboardSelectionReceivedHandler copy the received selection data record and buffer to internal record and buffer (ClipboardSelectionData) ------------------------------------------------------------------------------} procedure ClipboardSelectionReceivedHandler(TargetWidget: PGtkWidget; SelectionData: PGtkSelectionData; TimeID: cardinal; 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)+'='+gdk_atom_name(SelectionData^.selection), ' target=',dbgs(SelectionData^.Target)+'='+gdk_atom_name(SelectionData^.Target), ' theType=',dbgs(SelectionData^.theType)+'='+gdk_atom_name(SelectionData^.theType), ' 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)+'='+gdk_atom_name(SelectionData^.selection), ' target=',dbgs(SelectionData^.Target)+'='+gdk_atom_name(SelectionData^.Target), ' theType=',dbgs(SelectionData^.theType)+'='+gdk_atom_name(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 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('STRING',GdkTrue)) and (ClipboardExtraGtkFormats[ClipboardType][gfSTRING])) or ((FormatID=gdk_atom_intern('TEXT',GdkTrue)) and (ClipboardExtraGtkFormats[ClipboardType][gfTEXT])) then FormatID:=gdk_atom_intern('text/plain',GdkFalse); {$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^.{$ifdef GTK2}_Type{$ELSE}theType{$ENDIF}, @SelectionData^.Format,@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; {------------------------------------------------------------------------------ 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 ; EventTrace('style-set', nil); //ReleaseAllStyles; end; function gtkListBoxSelectionChangedAfter(widget: PGtkWidget; data: gPointer ): GBoolean; cdecl; var Mess: TLMessage; begin //debugln('gtkListBoxSelectionChangedAfter ',GetWidgetDebugReport(Widget)); Result := CallBackDefaultReturn; EventTrace('gtkListBoxSelectionChangedAfter', data); FillChar(Mess,SizeOf(Mess),0); Mess.msg := LM_SelChange; DeliverMessage(Data, Mess); end; {$I gtkDragCallback.inc} {$I gtkListViewCallback.inc} {$I gtkComboBoxCallback.inc} {$I gtkPageCallback.inc} {$IFDEF ASSERT_IS_ON} {$UNDEF ASSERT_IS_ON} {$C-} {$ENDIF}