mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-06 07:58:07 +02:00
f5718e9f06
This fixes a bunch of warnings when Gtk1 applications start. The fixes are on keyboard initialization (make a previously statically sized array dynamic as the old value wasn't long enough and disable an unnecessary warning about filling the VK table as the user can't do anything about it - nor we unless the whole thing is redesigned), module loading (this is a side effect of an environment variable collision between Gtk1, Gtk2 and Gtk3 - all of these use the GTK_MODULES variable to load some modules but since as of 2023 no distribution aside from Slackware comes with Gtk1, all of these warnings are bogus, so this patch temporarily cleans the environment variable before initializing Gtk and restores it later so that child processes can still access it) and passing NULL styles to gtk_style_copy (the previous code assumed the style retrieval functions always return a valid object, which is not the case).
9978 lines
313 KiB
PHP
9978 lines
313 KiB
PHP
{%MainUnit gtkproc.pp}
|
|
|
|
{******************************************************************************
|
|
Misc Support Functs
|
|
******************************************************************************
|
|
used by:
|
|
GTKObject
|
|
GTKWinAPI
|
|
GTKCallback
|
|
******************************************************************************
|
|
*****************************************************************************
|
|
This file is part of the Lazarus Component Library (LCL)
|
|
|
|
See the file COPYING.modifiedLGPL.txt, included in this distribution,
|
|
for details about the license.
|
|
*****************************************************************************
|
|
}
|
|
|
|
{off $DEFINE VerboseAccelerator}
|
|
{off $DEFINE VerboseUpdateSysColorMap}
|
|
|
|
{$IFOPT C-}
|
|
// Uncomment for local trace
|
|
//{$C+}
|
|
//{$DEFINE ASSERT_IS_ON}
|
|
{$ENDIF}
|
|
|
|
function gtk_widget_get_xthickness(Style : PGTKStyle) : gint;
|
|
begin
|
|
If (Style <> nil) then begin
|
|
{$IfNDef GTK2}
|
|
If (Style^.klass = nil) then
|
|
result := 0
|
|
else
|
|
{$EndIf}
|
|
result := Style^.{$IfNDef GTK2}klass^.{$EndIF}xthickness
|
|
end else
|
|
result := 0;
|
|
end;
|
|
|
|
function gtk_widget_get_ythickness(Style : PGTKStyle) : gint;
|
|
begin
|
|
If (Style <> nil) then begin
|
|
{$IfNDef GTK2}
|
|
If (Style^.klass = nil) then
|
|
result := 0
|
|
else
|
|
{$EndIf}
|
|
result := Style^.{$IfNDef GTK2}klass^.{$EndIF}ythickness
|
|
end else
|
|
result := 0;
|
|
end;
|
|
|
|
function gtk_widget_get_xthickness(Widget : PGTKWidget) : gint; overload;
|
|
begin
|
|
result := gtk_widget_get_xthickness(gtk_widget_get_style(Widget));
|
|
end;
|
|
|
|
function gtk_widget_get_ythickness(Widget : PGTKWidget) : gint; overload;
|
|
begin
|
|
result := gtk_widget_get_ythickness(gtk_widget_get_style(Widget));
|
|
end;
|
|
|
|
function GetGtkContainerBorderWidth(Widget: PGtkContainer): gint;
|
|
begin
|
|
Result:=(Widget^.flag0 and bm_TGtkContainer_border_width)
|
|
shr bp_TGtkContainer_border_width;
|
|
end;
|
|
|
|
procedure gdk_event_key_get_string(Event : PGDKEventKey; var theString : Pointer);
|
|
begin
|
|
{$IfDef GTK2}
|
|
theString := Pointer(Event^._String);
|
|
{$Else}
|
|
theString := Pointer(Event^.TheString);
|
|
{$EndIF}
|
|
end;
|
|
|
|
procedure gdk_event_key_set_string(Event: PGDKEventKey; const NewString: PChar);
|
|
var
|
|
OldString: PChar;
|
|
begin
|
|
{$IfDef GTK2}
|
|
OldString := Pointer(Event^._String);
|
|
{$Else}
|
|
OldString := Pointer(Event^.TheString);
|
|
{$EndIF}
|
|
// MG: should we set Event^.length := 0; or is this used for mem allocation?
|
|
if (OldString<>nil) then begin
|
|
if (NewString<>nil) then
|
|
OldString[0]:=NewString[0]
|
|
else
|
|
OldString[0]:=#0;
|
|
end;
|
|
end;
|
|
|
|
function gdk_event_get_type(Event : Pointer) : TGdkEventType;
|
|
begin
|
|
{$IfDef GTK2}
|
|
result := PGdkEvent(Event)^._type;
|
|
{$Else}
|
|
result := PGdkEvent(Event)^.TheType;
|
|
{$EndIF}
|
|
end;
|
|
|
|
procedure RememberKeyEventWasHandledByLCL(Event: PGdkEventKey;
|
|
BeforeEvent: boolean);
|
|
var
|
|
HandledEvent: TLCLHandledKeyEvent;
|
|
EventList: TFPList;
|
|
begin
|
|
if KeyEventWasHandledByLCL(Event,BeforeEvent) then exit;
|
|
if BeforeEvent then begin
|
|
if LCLHandledKeyEvents=nil then
|
|
LCLHandledKeyEvents:=TFPList.Create;
|
|
EventList:=LCLHandledKeyEvents;
|
|
end else begin
|
|
if LCLHandledKeyAfterEvents=nil then
|
|
LCLHandledKeyAfterEvents:=TFPList.Create;
|
|
EventList:=LCLHandledKeyAfterEvents;
|
|
end;
|
|
HandledEvent:=TLCLHandledKeyEvent.Create(Event);
|
|
EventList.Add(HandledEvent);
|
|
while EventList.Count>10 do begin
|
|
HandledEvent:=TLCLHandledKeyEvent(EventList[0]);
|
|
HandledEvent.Free;
|
|
EventList.Delete(0);
|
|
end;
|
|
end;
|
|
|
|
function KeyEventWasHandledByLCL(Event: PGdkEventKey; BeforeEvent: boolean
|
|
): boolean;
|
|
var
|
|
i: Integer;
|
|
HandledEvent: TLCLHandledKeyEvent;
|
|
EventList: TFPList;
|
|
begin
|
|
Result:=false;
|
|
if BeforeEvent then
|
|
EventList:=LCLHandledKeyEvents
|
|
else
|
|
EventList:=LCLHandledKeyAfterEvents;
|
|
if EventList=nil then exit;
|
|
for i:=0 to EventList.Count-1 do begin
|
|
HandledEvent:=TLCLHandledKeyEvent(EventList[i]);
|
|
if HandledEvent.IsEqual(Event) then begin
|
|
Result:=true;
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
{$Ifdef GTK2}
|
|
function gtk_class_get_type(aclass : Pointer) : TGtkType;
|
|
begin
|
|
If (aclass <> nil) then
|
|
result := PGtkTypeClass(aclass)^.g_Type
|
|
else
|
|
result := 0;
|
|
end;
|
|
|
|
function gtk_object_get_class(anobject : Pointer) : Pointer;
|
|
begin
|
|
If (anobject <> nil) then
|
|
result := PGtkTypeObject(anobject)^.g_Class
|
|
else
|
|
result := nil;
|
|
end;
|
|
|
|
function gtk_window_get_modal(window:PGtkWindow):gboolean;
|
|
begin
|
|
if assigned(Window) then
|
|
result := GTK2.gtk_window_get_modal(window)
|
|
else
|
|
result := False;
|
|
end;
|
|
|
|
function gdk_region_union_with_rect(region:PGdkRegion; rect:PGdkRectangle) : PGdkRegion;
|
|
begin
|
|
result := gdk_region_copy(region);
|
|
GDK2.gdk_region_union_with_rect(result, rect);
|
|
end;
|
|
|
|
function gdk_region_intersect(source1:PGdkRegion; source2:PGdkRegion) : PGdkRegion;
|
|
begin
|
|
result := gdk_region_copy(source1);
|
|
GDK2.gdk_region_intersect(result, source2);
|
|
end;
|
|
|
|
function gdk_region_union(source1:PGdkRegion; source2:PGdkRegion) : PGdkRegion;
|
|
begin
|
|
result := gdk_region_copy(source1);
|
|
GDK2.gdk_region_union(result, source2);
|
|
end;
|
|
|
|
function gdk_region_subtract(source1:PGdkRegion; source2:PGdkRegion) : PGdkRegion;
|
|
begin
|
|
result := gdk_region_copy(source1);
|
|
GDK2.gdk_region_subtract(result, source2);
|
|
end;
|
|
|
|
function gdk_region_xor(source1:PGdkRegion; source2:PGdkRegion) : PGdkRegion;
|
|
begin
|
|
result := gdk_region_copy(source1);
|
|
GDK2.gdk_region_xor(result, source2);
|
|
end;
|
|
|
|
Procedure gdk_text_extents(TheFont: TGtkIntfFont;
|
|
Str: PChar; StrLength: integer;
|
|
lbearing, rbearing, width, ascent, descent: Pgint);
|
|
var
|
|
Layout : PPangoLayout;
|
|
Extents : TPangoRectangle;
|
|
begin
|
|
//DebugLn(['gdk_text_extents Str="',Str,'" StrLength=',StrLength,' lbearing=',lbearing<>nil,' rbearing=',rbearing<>Nil,' width=',width<>nil,' ascent=',ascent<>nil,' descent=',descent<>Nil,' ',TheFont<>Nil]);
|
|
Layout:=TheFont;
|
|
pango_layout_set_single_paragraph_mode(Layout, TRUE);
|
|
pango_layout_set_width(Layout, -1);
|
|
pango_layout_set_text(Layout, Str, StrLength);
|
|
if Assigned(width) then
|
|
pango_layout_get_pixel_size(Layout, width, nil);
|
|
if Assigned(lbearing) or Assigned(rbearing)
|
|
or Assigned(ascent) or Assigned(descent) then begin
|
|
pango_layout_get_extents(Layout, nil, @Extents);
|
|
|
|
if Assigned(lbearing) then
|
|
lbearing^ := PANGO_LBEARING(extents) div PANGO_SCALE;
|
|
|
|
if Assigned(rbearing) then
|
|
rBearing^ := PANGO_RBEARING(extents) div PANGO_SCALE;
|
|
|
|
if Assigned(ascent) then
|
|
ascent^ := PANGO_ASCENT(extents) div PANGO_SCALE;
|
|
|
|
if Assigned(descent) then
|
|
descent^ := PANGO_DESCENT(extents) div PANGO_SCALE;
|
|
end;
|
|
end;
|
|
|
|
{$EndIf Gtk2}
|
|
|
|
procedure BeginGDKErrorTrap;
|
|
begin
|
|
Inc(GdkTrapCalls);
|
|
if GdkTrapIsSet then
|
|
exit;
|
|
|
|
gdk_error_trap_push; //try to prevent GDK Bad Drawable/X Windows Errors
|
|
// from killing us...
|
|
|
|
{$IfDef GDK_ERROR_TRAP_FLUSH}
|
|
gdk_flush; //only for debugging purposes DO NOT enable by default.
|
|
// slows things down intolerably for actual use, if we ever
|
|
// have a real need for it, it should be called from that
|
|
// specific function, since this gets called constantly during
|
|
// drawing.
|
|
{$EndIf}
|
|
|
|
GdkTrapIsSet:=true;
|
|
end;
|
|
|
|
procedure EndGDKErrorTrap;
|
|
var
|
|
Xerror : gint;
|
|
begin
|
|
Dec(GdkTrapCalls);
|
|
if (not GdkTrapIsSet) then
|
|
RaiseGDBException('EndGDKErrorTrap without BeginGDKErrorTrap');
|
|
if (GdkTrapCalls > 0) then
|
|
exit;
|
|
|
|
Xerror := gdk_error_trap_pop;
|
|
|
|
GdkTrapIsSet:=false;
|
|
|
|
{$IFDEF VerboseGtkToDos}{$note TODO: enable standard error_log handling}{$ENDIF}
|
|
{$IfDef REPORT_GDK_ERRORS}
|
|
If (Xerror<>0) then
|
|
RaiseGDBException('A GDK/X Error occurred, this is normally fatal. The error code was: ' + IntToStr(Xerror));
|
|
{$EndIf}
|
|
end;
|
|
|
|
function dbgGRect(const ARect: PGDKRectangle): string;
|
|
begin
|
|
if ARect=nil then begin
|
|
Result:='nil';
|
|
end else begin
|
|
Result:='x='+dbgs(ARect^.x)+',y='+dbgs(ARect^.y)
|
|
+',w='+dbgs(ARect^.width)+',h='+dbgs(ARect^.height);
|
|
end;
|
|
end;
|
|
|
|
|
|
{------------------------------------------------------------------------------
|
|
Allocates a new PChar
|
|
------------------------------------------------------------------------------
|
|
function CreatePChar(const s: string): PChar;
|
|
begin
|
|
Result:=StrAlloc(length(s) + 1);
|
|
StrPCopy(Result, s);
|
|
end;
|
|
}
|
|
function FindChar(c: char; p:PChar; Max: integer): integer;
|
|
begin
|
|
Result:=0;
|
|
while (Result<Max) do begin
|
|
if p[Result]<>c then
|
|
inc(Result)
|
|
else
|
|
exit;
|
|
end;
|
|
Result:=-1;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function FindLineLen(p: PChar; Max: integer): integer;
|
|
|
|
Find line end
|
|
------------------------------------------------------------------------------}
|
|
function FindLineLen(p: PChar; Max: integer): integer;
|
|
begin
|
|
Result:=0;
|
|
while (Result<Max) do begin
|
|
if not (p[Result] in [#10,#13]) then
|
|
inc(Result)
|
|
else
|
|
exit;
|
|
end;
|
|
Result:=-1;
|
|
end;
|
|
|
|
function RectFromGdkRect(const AGdkRect: TGdkRectangle): TRect;
|
|
begin
|
|
with Result do
|
|
begin
|
|
Left := AGdkRect.x;
|
|
Top := AGdkRect.y;
|
|
Right := AGdkRect.Width + AGdkRect.x;
|
|
Bottom := AGdkRect.Height + AGdkRect.y;
|
|
end;
|
|
end;
|
|
|
|
function GdkRectFromRect(const R: TRect): TGdkRectangle;
|
|
begin
|
|
with Result do
|
|
begin
|
|
x := R.Left;
|
|
y := R.Top;
|
|
width := R.Right-R.Left;
|
|
height := R.Bottom-R.Top;
|
|
end;
|
|
end;
|
|
|
|
function AlignToGtkAlign(Align: TAlignment): gfloat;
|
|
begin
|
|
case Align of
|
|
taLeftJustify : AlignToGtkAlign := 0.0;
|
|
taCenter : AlignToGtkAlign := 0.5;
|
|
taRightJustify: AlignToGtkAlign := 1.0;
|
|
end;
|
|
end;
|
|
|
|
{$ifdef gtk2}
|
|
function GtkScrollTypeToScrollCode(ScrollType: TGtkScrollType): LongWord;
|
|
begin
|
|
case ScrollType of
|
|
GTK_SCROLL_NONE : Result := SB_ENDSCROLL;
|
|
GTK_SCROLL_JUMP : Result := SB_THUMBPOSITION;
|
|
GTK_SCROLL_STEP_BACKWARD : Result := SB_LINELEFT;
|
|
GTK_SCROLL_STEP_FORWARD : Result := SB_LINERIGHT;
|
|
GTK_SCROLL_PAGE_BACKWARD : Result := SB_PAGELEFT;
|
|
GTK_SCROLL_PAGE_FORWARD : 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 : Result := SB_TOP;
|
|
GTK_SCROLL_END : Result := SB_BOTTOM;
|
|
end;
|
|
end;
|
|
{$endif}
|
|
|
|
{------------------------------------------------------------------------------
|
|
function GtkWidgetIsA(Widget: PGtkWidget; AType: TGtkType): boolean;
|
|
|
|
The GTK_IS_XXX macro functions in the fpc gtk1.x bindings are not correct.
|
|
They just test the highest level.
|
|
This function checks as the real C macros.
|
|
------------------------------------------------------------------------------}
|
|
function GtkWidgetIsA(Widget: PGtkWidget; AType: TGtkType): boolean;
|
|
begin
|
|
Result:=(Widget<>nil)
|
|
and (gtk_object_get_class(Widget)<>nil)
|
|
and gtk_type_is_a(gtk_class_get_type(gtk_object_get_class(Widget)), AType);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function GetWidgetClassName(Widget: PGtkWidget): string;
|
|
|
|
Returns the gtk class name of Widget.
|
|
------------------------------------------------------------------------------}
|
|
function GetWidgetClassName(Widget: PGtkWidget): string;
|
|
var
|
|
AType: TGtkType;
|
|
ClassPGChar: Pgchar;
|
|
ClassLen: Integer;
|
|
begin
|
|
Result:='';
|
|
if Widget=nil then begin
|
|
Result:='nil';
|
|
exit;
|
|
end;
|
|
if (gtk_object_get_class(Widget)=nil) then begin
|
|
Result:='<Widget without class>';
|
|
exit;
|
|
end;
|
|
AType:=gtk_class_get_type(gtk_object_get_class(Widget));
|
|
ClassPGChar:=gtk_type_name(AType);
|
|
if ClassPGChar=nil then begin
|
|
Result:='<Widget without classname>';
|
|
exit;
|
|
end;
|
|
ClassLen:=strlen(ClassPGChar);
|
|
SetLength(Result,ClassLen);
|
|
if ClassLen>0 then
|
|
Move(ClassPGChar[0],Result[1],ClassLen);
|
|
end;
|
|
|
|
function GetWidgetDebugReport(Widget: PGtkWidget): string;
|
|
var
|
|
LCLObject: TObject;
|
|
AWinControl: TWinControl;
|
|
MainWidget: PGtkWidget;
|
|
WinWidgetInfo: PWinWidgetInfo;
|
|
FixedWidget: PGTKWidget;
|
|
begin
|
|
if Widget = nil
|
|
then begin
|
|
Result := 'nil';
|
|
exit;
|
|
end;
|
|
Result := Format('%p=%s %s', [Pointer(Widget), GetWidgetClassName(Widget), WidgetFlagsToString(Widget)]);
|
|
LCLObject:=GetNearestLCLObject(Widget);
|
|
Result := Result + Format(' LCLObject=%p', [Pointer(LCLObject)]);
|
|
if LCLObject=nil then exit;
|
|
if LCLObject is TControl then
|
|
Result:=Result+'='+TControl(LCLObject).Name+':'+LCLObject.ClassName
|
|
else
|
|
Result:=Result+'='+LCLObject.ClassName;
|
|
if LCLObject is TWinControl then begin
|
|
AWinControl:=TWinControl(LCLObject);
|
|
if AWinControl.HandleAllocated then begin
|
|
MainWidget:=PGTKWidget(AWinControl.Handle);
|
|
if MainWidget=Widget
|
|
then Result:=Result+'<Is MainWidget>'
|
|
else Result:=Result+Format('<MainWidget=%p=%s>', [Pointer(MainWidget), GetWidgetClassName(MainWidget)]);
|
|
FixedWidget:=GetFixedWidget(MainWidget);
|
|
if FixedWidget=Widget then
|
|
Result:=Result+'<Is FixedWidget>';
|
|
WinWidgetInfo:=GetWidgetInfo(MainWidget,false);
|
|
if WinWidgetInfo<>nil then begin
|
|
if WinWidgetInfo^.CoreWidget = Widget then
|
|
Result:=Result+'<Is CoreWidget>';
|
|
end;
|
|
end
|
|
else begin
|
|
Result:=Result+'<NOT HandleAllocated>'
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function GetWindowDebugReport(AWindow: PGDKWindow): string;
|
|
var
|
|
p: gpointer;
|
|
Widget: PGtkWidget;
|
|
WindowType: TGdkWindowType;
|
|
Width: Integer;
|
|
Height: Integer;
|
|
{$ifdef gtk1}
|
|
Visual: PGdkVisual;
|
|
{$endif}
|
|
TypeAsStr: String;
|
|
begin
|
|
Result := DbgS(AWindow);
|
|
if AWindow = nil then Exit;
|
|
|
|
// window type
|
|
WindowType := gdk_window_get_type(AWindow);
|
|
case WindowType of
|
|
GDK_WINDOW_ROOT: TypeAsStr := 'Root';
|
|
GDK_WINDOW_TOPLEVEL: TypeAsStr := 'TopLvl';
|
|
GDK_WINDOW_CHILD: TypeAsStr := 'Child';
|
|
GDK_WINDOW_DIALOG: TypeAsStr := 'Dialog';
|
|
GDK_WINDOW_TEMP: TypeAsStr := 'Temp';
|
|
{$ifdef gtk1}
|
|
GDK_WINDOW_PIXMAP: TypeAsStr := 'Pixmap';
|
|
{$endif gtk1}
|
|
GDK_WINDOW_FOREIGN: TypeAsStr := 'Foreign';
|
|
else
|
|
TypeAsStr := 'Unknown';
|
|
end;
|
|
Result:=Result + ' Type=' + TypeAsStr;
|
|
|
|
DebugLn(Result);
|
|
// user data
|
|
if WindowType in [GDK_WINDOW_ROOT,GDK_WINDOW_TOPLEVEL,GDK_WINDOW_CHILD, GDK_WINDOW_DIALOG] then
|
|
begin
|
|
p := nil;
|
|
gdk_window_get_user_data(AWindow, @p);
|
|
if GtkWidgetIsA(PGTKWidget(p), gtk_widget_get_type) then
|
|
begin
|
|
Widget := PGTKWidget(p);
|
|
Result := Result + '<Widget[' + GetWidgetDebugReport(Widget) + ']>';
|
|
end
|
|
else
|
|
Result := Result + '<UserData=' + DbgS(p) + ']>';
|
|
end;
|
|
|
|
// size
|
|
gdk_window_get_size(AWindow, @Width, @Height);
|
|
Result := Result + ' Size=' + IntToStr(Width) + 'x' + IntToStr(Height);
|
|
|
|
{$ifdef gtk1}
|
|
// visual
|
|
Visual := gdk_window_get_visual(AWindow);
|
|
if Visual <> nil then
|
|
if WindowType in [GDK_WINDOW_PIXMAP] then
|
|
Result := Result + ' Depth=' + IntToStr(Visual^.bits_per_rgb);
|
|
{$endif gtk1}
|
|
end;
|
|
|
|
function GetStyleDebugReport(AStyle: PGTKStyle): string;
|
|
begin
|
|
Result:='[';
|
|
if AStyle=nil then
|
|
Result:=Result+'nil'
|
|
else begin
|
|
Result:=Result+'FG[N]:='+GdkColorToStr(@AStyle^.fg[GTK_STATE_NORMAL])+' ';
|
|
Result:=Result+'BG[N]:='+GdkColorToStr(@AStyle^.bg[GTK_STATE_NORMAL])+' ';
|
|
Result:=Result+'Base[N]:='+GdkColorToStr(@AStyle^.base[GTK_STATE_NORMAL])+' ';
|
|
Result:=Result+'BG_Pixmap[N]:='+DbgS(AStyle^.bg_pixmap[GTK_STATE_NORMAL])+' ';
|
|
Result:=Result+'rc_style='+GetRCStyleDebugReport(AStyle^.rc_style);
|
|
end;
|
|
Result:=Result+']';
|
|
end;
|
|
|
|
function GetRCStyleDebugReport(AStyle: PGtkRcStyle): string;
|
|
begin
|
|
Result:='[';
|
|
if AStyle=nil then
|
|
Result:=Result+'nil'
|
|
else begin
|
|
Result:=Result+'name="'+AStyle^.name+'" ';
|
|
{$IFDEF GTK1}
|
|
Result:=Result+'font_name="'+AStyle^.font_name+'" ';
|
|
Result:=Result+'fontset_name="'+AStyle^.fontset_name+'" ';
|
|
Result:=Result+'FG[N]='+GdkColorToStr(@AStyle^.fg[GTK_STATE_NORMAL])+' ';
|
|
Result:=Result+'BG[N]='+GdkColorToStr(@AStyle^.bg[GTK_STATE_NORMAL])+' ';
|
|
Result:=Result+'Base[N]='+GdkColorToStr(@AStyle^.base[GTK_STATE_NORMAL])+' ';
|
|
Result:=Result+'flagi='+intTostr(AStyle^.color_flags[GTK_STATE_NORMAL])+' ';
|
|
{$ELSE GTK2}
|
|
Result:=Result+'font_desc=['+GetPangoDescriptionReport(AStyle^.font_desc)+'] ';
|
|
{$ENDIF GTK2}
|
|
Result:=Result+'bg_pixmap_name[N]="'+AStyle^.bg_pixmap_name[GTK_STATE_NORMAL]+'" ';
|
|
{$IFDEF GTK1}
|
|
Result:=Result+'engine='+DbgS(AStyle^.engine);
|
|
{$ENDIF GTK1}
|
|
end;
|
|
Result:=Result+']';
|
|
end;
|
|
|
|
{$IFDEF Gtk2}
|
|
function GetPangoDescriptionReport(Desc: PPangoFontDescription): string;
|
|
begin
|
|
if Desc=nil then begin
|
|
Result:='nil';
|
|
end else begin
|
|
Result:='family='+pango_font_description_get_family(Desc);
|
|
Result:=Result+' size='+IntToStr(pango_font_description_get_size(Desc));
|
|
Result:=Result+' weight='+IntToStr(pango_font_description_get_weight(Desc));
|
|
Result:=Result+' variant='+IntToStr(pango_font_description_get_variant(Desc));
|
|
Result:=Result+' style='+IntToStr(pango_font_description_get_style(Desc));
|
|
Result:=Result+' stretch='+IntToStr(pango_font_description_get_stretch(Desc));
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
function WidgetFlagsToString(Widget: PGtkWidget): string;
|
|
begin
|
|
Result:='[';
|
|
if Widget=nil then
|
|
Result:=Result+'nil'
|
|
else begin
|
|
if GTK_WIDGET_REALIZED(Widget) then
|
|
Result:=Result+'R';
|
|
if GTK_WIDGET_MAPPED(Widget) then
|
|
Result:=Result+'M';
|
|
if GTK_WIDGET_VISIBLE(Widget) then
|
|
Result:=Result+'V';
|
|
if GTK_WIDGET_DRAWABLE(Widget) then
|
|
Result:=Result+'D';
|
|
if GTK_WIDGET_CAN_FOCUS(Widget) then
|
|
Result:=Result+'F';
|
|
if GTK_WIDGET_RC_STYLE(Widget) then
|
|
Result:=Result+'St';
|
|
if GTK_WIDGET_PARENT_SENSITIVE(Widget) then
|
|
Result:=Result+'Pr';
|
|
{$IFDEF Gtk2}
|
|
if GTK_WIDGET_NO_WINDOW(Widget) then
|
|
Result:=Result+'Nw';
|
|
if GTK_WIDGET_COMPOSITE_CHILD(Widget) then
|
|
Result:=Result+'Cc';
|
|
if GTK_WIDGET_APP_PAINTABLE(Widget) then
|
|
Result:=Result+'Ap';
|
|
if GTK_WIDGET_DOUBLE_BUFFERED(Widget) then
|
|
Result:=Result+'Db';
|
|
{$ENDIF}
|
|
end;
|
|
Result:=Result+']';
|
|
end;
|
|
|
|
function GdkColorToStr(Color: PGDKColor): string;
|
|
begin
|
|
if Color=nil then
|
|
Result:='nil'
|
|
else
|
|
Result:='R'+HexStr(Color^.Red,4)+'G'+HexStr(Color^.Green,4)
|
|
+'B'+HexStr(Color^.Blue,4);
|
|
end;
|
|
|
|
function GetWidgetStyleReport(Widget: PGtkWidget): string;
|
|
var
|
|
AStyle: PGtkStyle;
|
|
ARCStyle: PGtkRcStyle;
|
|
begin
|
|
Result:='';
|
|
if Widget=nil then exit;
|
|
AStyle:=gtk_widget_get_style(Widget);
|
|
if AStyle=nil then begin
|
|
Result:='nil';
|
|
exit;
|
|
end;
|
|
Result:=Result+'attach_count='+dbgs(AStyle^.attach_count);
|
|
ARCStyle:=AStyle^.rc_style;
|
|
if ARCStyle=nil then begin
|
|
Result:=Result+' rc_style=nil';
|
|
end else begin
|
|
Result:=Result+' rc_style=[';
|
|
{$IFDEF GTK1}
|
|
Result:=Result+ARCStyle^.font_name+',';
|
|
Result:=Result+ARCStyle^.fontset_name+',';
|
|
{$ELSE GTK1}
|
|
Result:=Result+GetPangoDescriptionReport(AStyle^.font_desc);
|
|
{$ENDIF GTK1}
|
|
Result:=Result+']';
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function WidgetIsDestroyingHandle(Widget: PGtkWidget): boolean;
|
|
|
|
Tests if Destruction Mark is set.
|
|
------------------------------------------------------------------------------}
|
|
function WidgetIsDestroyingHandle(Widget: PGtkWidget): boolean;
|
|
begin
|
|
Result:=gtk_object_get_data(PGtkObject(Widget),'LCLDestroyingHandle')<>nil;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure SetWidgetIsDestroyingHandle(Widget: PGtkWidget);
|
|
|
|
Marks widget for destruction.
|
|
------------------------------------------------------------------------------}
|
|
procedure SetWidgetIsDestroyingHandle(Widget: PGtkWidget);
|
|
begin
|
|
gtk_object_set_data(PGtkObject(Widget),'LCLDestroyingHandle',Widget);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function ComponentIsDestroyingHandle(AWinControl: TWinControl): boolean;
|
|
|
|
Tests if Destruction Mark is set.
|
|
------------------------------------------------------------------------------}
|
|
function ComponentIsDestroyingHandle(AWinControl: TWinControl): boolean;
|
|
begin
|
|
Result:=
|
|
(AWinControl<>nil) and (AWinControl is TWinControl)
|
|
and (AWinControl.HandleAllocated)
|
|
and WidgetIsDestroyingHandle(PGtkWidget(AWinControl.Handle));
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function LockOnChange(GtkObject: PGtkObject; LockOffset: integer): integer;
|
|
|
|
Adds LockOffset to the OnChangeLock and returns the result.
|
|
------------------------------------------------------------------------------}
|
|
function LockOnChange(GtkObject: PGtkObject; LockOffset: integer): integer;
|
|
var
|
|
Info: PWidgetInfo;
|
|
begin
|
|
Info := GetWidgetInfo(GtkObject, True);
|
|
if Info = nil
|
|
then begin
|
|
Result := 0;
|
|
Exit;
|
|
end;
|
|
|
|
Inc(Info^.ChangeLock, LockOffset);
|
|
Result := Info^.ChangeLock;
|
|
end;
|
|
|
|
procedure SetFormShowInTaskbar(AForm: TCustomForm;
|
|
const AValue: TShowInTaskbar);
|
|
var
|
|
Enable: boolean;
|
|
Widget: PGtkWidget;
|
|
begin
|
|
if (AForm.Parent <> nil) or
|
|
(AForm.ParentWindow <> 0) or
|
|
not (AForm.HandleAllocated) then Exit;
|
|
|
|
Widget := PGtkWidget(AForm.Handle);
|
|
// if widget not yet realized then exit
|
|
if Widget^.Window = nil then
|
|
Exit;
|
|
|
|
Enable := AValue <> stNever;
|
|
{if (AValue = stDefault)
|
|
and (Application<>nil) and (Application.MainForm <> nil)
|
|
and (Application.MainForm <> AForm) then
|
|
Enable := false;}
|
|
|
|
//debugln('SetGtkWindowShowInTaskbar ',DbgSName(AForm),' ',dbgs(Enable));
|
|
// The button reappears in some (still unknown) situations, but has the
|
|
//'skip-taskbar-hint' property still set to True, so invoking the function
|
|
//doesn't have an effect. Resetting the property makes it work.
|
|
{$IFNDEF GTK1}
|
|
if (not Enable) and gtk_window_get_skip_taskbar_hint(PGtkWindow(Widget)) then
|
|
gtk_window_set_skip_taskbar_hint(PGtkWindow(Widget), False);
|
|
{$ENDIF}
|
|
SetGtkWindowShowInTaskbar(PGtkWindow(Widget), Enable);
|
|
end;
|
|
|
|
procedure SetGtkWindowShowInTaskbar(AGtkWindow: PGtkWindow; Value: boolean);
|
|
begin
|
|
{$IFDEF GTK1}
|
|
if PgtkWidget(AGtkWindow)^.Window=nil then begin
|
|
// widget not yet realized
|
|
exit;
|
|
end;
|
|
GDK_WINDOW_SHOW_IN_TASKBAR(PGdkWindowPrivate(PGtkWidget(AGtkWindow)^.Window),
|
|
Value);
|
|
{$ELSE}
|
|
//DebugLn(['SetGtkWindowShowInTaskbar ',GetWidgetDebugReport(PGtkWidget(AGtkWindow)),' ',Value]);
|
|
gtk_window_set_skip_taskbar_hint(AGtkWindow, not Value);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure SetWindowFullScreen(AForm: TCustomForm; const AValue: Boolean);
|
|
{$IFDEF GTK1}
|
|
var
|
|
XDisplay: PDisplay;
|
|
XScreen: PScreen;
|
|
XRootWindow,
|
|
XWindow: TWindow;
|
|
XEvent: TXClientMessageEvent;
|
|
_NET_WM_STATE: Integer;
|
|
//_NET_WM_STATE_MODAL: Integer;
|
|
//_NET_WM_STATE_ABOVE: Integer;
|
|
//_NET_WM_STATE_FULLSCREEN: Integer;
|
|
_NET_WM_STATE_ATOMS: array [0..2] of Integer;
|
|
I: Integer;
|
|
{$ENDIF}
|
|
begin
|
|
{$IFDEF GTK2}
|
|
If AValue then
|
|
GTK_Window_FullScreen(PGTKWindow(AForm.Handle))
|
|
else
|
|
GTK_Window_UnFullScreen(PGTKWindow(AForm.Handle));
|
|
{$ENDIF}
|
|
{$IFDEF GTK1}
|
|
XDisplay := gdk_display;
|
|
XScreen := XDefaultScreenOfDisplay(xdisplay);
|
|
XRootWindow := XRootWindowOfScreen(xscreen);
|
|
XWindow := FormToX11Window(AForm);
|
|
|
|
_NET_WM_STATE := XInternAtom(xdisplay, '_NET_WM_STATE', false);
|
|
//_NET_WM_STATE_MODAL := XInternAtom(xdisplay, '_NET_WM_STATE_MODAL', false);
|
|
//_NET_WM_STATE_ABOVE := XInternAtom(xdisplay, '_NET_WM_STATE_ABOVE', false);
|
|
//_NET_WM_STATE_FULLSCREEN := XInternAtom(xdisplay, '_NET_WM_STATE_FULLSCREEN', false);
|
|
_NET_WM_STATE_ATOMS[0] := XInternAtom(xdisplay, '_NET_WM_STATE_MODAL', false);
|
|
_NET_WM_STATE_ATOMS[1] := XInternAtom(xdisplay, '_NET_WM_STATE_ABOVE', false);
|
|
_NET_WM_STATE_ATOMS[2] := XInternAtom(xdisplay, '_NET_WM_STATE_FULLSCREEN', false);
|
|
|
|
for I := 0 to 2 do begin
|
|
XEvent._type := ClientMessage;
|
|
XEvent.window := XWindow;
|
|
XEvent.message_type := _NET_WM_STATE;
|
|
XEvent.format := 32;
|
|
XEvent.data.l[0] := Ord(AValue);// 0=Remove 1=Add 2=Toggle
|
|
XEvent.data.l[1] := _NET_WM_STATE_ATOMS[I];
|
|
|
|
XSendEvent(XDisplay, XRootWindow, False, SubstructureNotifyMask, PXEvent(@XEvent));
|
|
end;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure GrabKeyBoardToForm(AForm: TCustomForm);
|
|
begin
|
|
{$IFDEF HasX}
|
|
XGrabKeyboard(gdk_display, FormToX11Window(AForm), true, GrabModeASync,
|
|
GrabModeASync, CurrentTime);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure ReleaseKeyBoardFromForm(AForm: TCustomForm);
|
|
begin
|
|
{$IFDEF HasX}
|
|
XUngrabKeyboard(gdk_display, CurrentTime);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure GrabMouseToForm(AForm: TCustomForm);
|
|
{$IFDEF HasX}
|
|
var
|
|
eventMask: LongInt;
|
|
begin
|
|
eventMask := ButtonPressMask or ButtonReleaseMask
|
|
or PointerMotionMask or PointerMotionHintMask;
|
|
|
|
XGrabPointer(gdk_display, FormToX11Window(AForm), true,
|
|
eventMask, GrabModeASync, GrabModeAsync, FormToX11Window(AForm),
|
|
None, CurrentTime);
|
|
end;
|
|
{$ELSE}
|
|
begin
|
|
end;
|
|
{$ENDIF}
|
|
|
|
procedure ReleaseMouseFromForm(AForm: TCustomForm);
|
|
begin
|
|
{$IFDEF HasX}
|
|
XUngrabPointer(gdk_display, CurrentTime);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
{$IFDEF HasX}
|
|
function FormToX11Window(const AForm: TCustomForm): X.TWindow;
|
|
var
|
|
Widget: PGtkWidget;
|
|
begin
|
|
Result:=0;
|
|
if (AForm=nil) or (not AForm.HandleAllocated) then exit;
|
|
Widget:=PGtkWidget(AForm.Handle);
|
|
if Widget^.window = nil then exit;
|
|
{$ifdef gtk1}
|
|
Result := PGdkWindowPrivate(Widget^.window)^.xwindow;
|
|
{$else}
|
|
Result := gdk_window_xwindow(Widget^.window);
|
|
{$endif}
|
|
end;
|
|
{$ENDIF}
|
|
|
|
procedure SetLabelAlignment(LabelWidget: PGtkLabel;
|
|
const NewAlignment: TAlignment);
|
|
const
|
|
cLabelAlignX : array[TAlignment] of gfloat = (0.0, 1.0, 0.5);
|
|
cLabelAlignY : array[TTextLayout] of gfloat = (0.0, 0.5, 1.0);
|
|
cLabelAlign : array[TAlignment] of TGtkJustification =
|
|
(GTK_JUSTIFY_LEFT, GTK_JUSTIFY_RIGHT, GTK_JUSTIFY_CENTER);
|
|
begin
|
|
gtk_label_set_justify(LabelWidget, cLabelAlign[NewAlignment]);
|
|
gtk_misc_set_alignment(GTK_MISC(LabelWidget), cLabelAlignX[NewAlignment],
|
|
cLabelAlignY[tlTop]);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function GtkPaintMessageToPaintMessage(var GtkPaintMsg: TLMGtkPaint;
|
|
FreeGtkPaintMsg: boolean): TLMPaint;
|
|
|
|
Converts a LM_GTKPAINT message to a LM_PAINT message
|
|
------------------------------------------------------------------------------}
|
|
function GtkPaintMessageToPaintMessage(var GtkPaintMsg: TLMGtkPaint;
|
|
FreeGtkPaintMsg: boolean): TLMPaint;
|
|
var
|
|
PS : PPaintStruct;
|
|
Widget: PGtkWidget;
|
|
begin
|
|
FillByte(Result,SizeOf(Result),0);
|
|
Result.Msg := LM_PAINT;
|
|
New(PS);
|
|
FillChar(PS^, SizeOf(TPaintStruct), 0);
|
|
Widget := GtkPaintMsg.Data.Widget;
|
|
If GtkPaintMsg.Data.RepaintAll then
|
|
PS^.rcPaint := Rect(0, 0, Widget^.Allocation.Width, Widget^.Allocation.Height)
|
|
else
|
|
PS^.rcPaint := GtkPaintMsg.Data.Rect;
|
|
|
|
Result.DC := BeginPaint(HWND(Widget), PS^);
|
|
Result.PaintStruct := PS;
|
|
Result.Result := 0;
|
|
if FreeGtkPaintMsg then
|
|
FreeThenNil(GtkPaintMsg.Data);
|
|
end;
|
|
|
|
procedure FinalizePaintMessage(Msg: PLMessage);
|
|
var
|
|
PS: PPaintStruct;
|
|
DC: TGtkDeviceContext;
|
|
begin
|
|
if (Msg^.Msg = LM_PAINT) then
|
|
begin
|
|
if Msg^.LParam <> 0 then
|
|
begin
|
|
PS := PPaintStruct(Msg^.LParam);
|
|
if Msg^.WParam <> 0 then
|
|
DC := TGtkDeviceContext(Msg^.WParam)
|
|
else
|
|
DC := TGtkDeviceContext(PS^.hdc);
|
|
EndPaint(HWND(DC.Widget), PS^);
|
|
Dispose(PS);
|
|
Msg^.LParam:=0;
|
|
Msg^.WParam:=0;
|
|
end
|
|
else
|
|
if Msg^.WParam<>0 then
|
|
begin
|
|
ReleaseDC(0, Msg^.WParam);
|
|
Msg^.WParam := 0;
|
|
end;
|
|
end else
|
|
if Msg^.Msg = LM_GTKPAINT then
|
|
FreeThenNil(TLMGtkPaintData(Msg^.WParam));
|
|
end;
|
|
|
|
procedure FinalizePaintTagMsg(Msg: PMsg);
|
|
var
|
|
PS: PPaintStruct;
|
|
DC: TGtkDeviceContext;
|
|
begin
|
|
if (Msg^.Message = LM_PAINT) then
|
|
begin
|
|
if Msg^.LParam <> 0 then
|
|
begin
|
|
PS := PPaintStruct(Msg^.LParam);
|
|
if Msg^.WParam<>0 then
|
|
DC := TGtkDeviceContext(Msg^.WParam)
|
|
else
|
|
DC := TGtkDeviceContext(PS^.hdc);
|
|
EndPaint(HWND(DC.Widget), PS^);
|
|
Dispose(PS);
|
|
Msg^.LParam:=0;
|
|
Msg^.WParam:=0;
|
|
end else
|
|
if Msg^.WParam<>0 then
|
|
begin
|
|
ReleaseDC(0, Msg^.WParam);
|
|
Msg^.WParam:=0;
|
|
end;
|
|
end else
|
|
if Msg^.Message = LM_GTKPAINT then
|
|
FreeThenNil(TObject(Msg^.WParam));
|
|
end;
|
|
|
|
procedure SetGCRasterOperation(TheGC: PGDKGC; Rop: Cardinal);
|
|
begin
|
|
case ROP of
|
|
WHITENESS,
|
|
BLACKNESS,
|
|
SRCCOPY :
|
|
gdk_gc_set_function(TheGC, GDK_Copy);
|
|
SRCPAINT :
|
|
gdk_gc_set_function(TheGC, GDK_NOOP);
|
|
SRCAND :
|
|
gdk_gc_set_function(TheGC, GDK_Clear);
|
|
SRCINVERT :
|
|
gdk_gc_set_function(TheGC, GDK_XOR);
|
|
SRCERASE :
|
|
gdk_gc_set_function(TheGC, GDK_AND);
|
|
NOTSRCCOPY :
|
|
gdk_gc_set_function(TheGC, GDK_OR_REVERSE);
|
|
NOTSRCERASE :
|
|
gdk_gc_set_function(TheGC, GDK_AND);
|
|
MERGEPAINT :
|
|
gdk_gc_set_function(TheGC, GDK_Copy_Invert);
|
|
DSTINVERT :
|
|
gdk_gc_set_function(TheGC, GDK_INVERT);
|
|
else begin
|
|
gdk_gc_set_function(TheGC, GDK_COPY);
|
|
DebugLn('WARNING: [SetRasterOperation] Got unknown/unsupported CopyMode!!');
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure MergeClipping(DestinationDC: TGtkDeviceContext; DestinationGC: PGDKGC;
|
|
X,Y,Width,Height: integer; ClipMergeMask: PGdkBitmap;
|
|
ClipMergeMaskX, ClipMergeMaskY: integer;
|
|
var NewClipMask: PGdkBitmap);
|
|
// merge ClipMergeMask into the destination clipping mask at the
|
|
// destination rectangle
|
|
var
|
|
temp_gc : PGDKGC;
|
|
temp_color : TGDKColor;
|
|
RGNType : Longint;
|
|
OffsetXY: TPoint;
|
|
//ClipMergeMaskWidth, ClipMergeMaskHeight: integer;
|
|
begin
|
|
{$IFDEF VerboseStretchCopyArea}
|
|
DebugLn('MergeClipping START DestinationDC=',DbgS(DestinationDC),
|
|
' DestinationGC=',DbgS(DestinationGC),
|
|
' X='+dbgs(X),' Y='+dbgs(Y),' Width='+dbgs(Width),' Height='+dbgs(Height),
|
|
' ClipMergeMask=',DbgS(ClipMergeMask),
|
|
' ClipMergeMaskX=',dbgs(ClipMergeMaskX),' ClipMergeMaskY=',dbgs(ClipMergeMaskY));
|
|
{$ENDIF}
|
|
|
|
// activate clipping region of destination
|
|
DestinationDC.SelectRegion;
|
|
NewClipMask := nil;
|
|
if (ClipMergeMask = nil) then exit;
|
|
|
|
BeginGDKErrorTrap;
|
|
// create temporary mask with the size of the destination rectangle
|
|
NewClipMask := PGdkBitmap(gdk_pixmap_new(nil, width, height, 1));
|
|
// create temporary GC for combination mask
|
|
temp_gc := gdk_gc_new(NewClipMask);
|
|
gdk_gc_set_clip_region(temp_gc, nil); // no default clipping
|
|
gdk_gc_set_clip_rectangle(temp_gc, nil);
|
|
|
|
// clear mask
|
|
temp_color.pixel := 0;
|
|
gdk_gc_set_foreground(temp_gc, @temp_color);
|
|
gdk_draw_rectangle(NewClipMask, temp_gc, 1, 0, 0, width+1, height+1);
|
|
|
|
// copy the destination clipping mask into the temporary mask
|
|
with DestinationDC do begin
|
|
If (ClipRegion <> nil) then begin
|
|
RGNType := RegionType(ClipRegion^.GDIRegionObject);
|
|
If (RGNType <> ERROR) and (RGNType <> NULLREGION) then begin
|
|
// destination has a clipping mask
|
|
{$IFDEF VerboseStretchCopyArea}
|
|
DebugLn('MergeClipping Destination has clipping mask -> apply to temp GC');
|
|
{$ENDIF}
|
|
// -> copy the destination clipping mask to the temporary mask
|
|
// The X,Y coordinate in the destination relates to
|
|
// 0,0 in the temporary mask.
|
|
// The clip region of dest is always at 0,0 in dest
|
|
OffsetXY:=Point(-X,-Y);
|
|
// 1. Move the region
|
|
gdk_region_offset(ClipRegion^.GDIRegionObject,OffsetXY.X,OffsetXY.Y);
|
|
// 2. Apply region to temporary mask
|
|
gdk_gc_set_clip_region(temp_gc, ClipRegion^.GDIRegionObject);
|
|
// 3. Undo moving the region
|
|
gdk_region_offset(ClipRegion^.GDIRegionObject,-OffsetXY.X,-OffsetXY.Y);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
// merge the source clipping mask into the temporary mask
|
|
//gdk_window_get_size(ClipMergeMask,@ClipMergeMaskWidth,@ClipMergeMaskHeight);
|
|
//DebugLn('MergeClipping A MergeMask Size=',ClipMergeMaskWidth,',',ClipMergeMaskHeight);
|
|
gdk_draw_pixmap(NewClipMask, temp_gc,
|
|
ClipMergeMask, ClipMergeMaskX, ClipMergeMaskY, 0, 0, -1, -1);
|
|
|
|
// free the temporary GC
|
|
gdk_gc_destroy(temp_gc);
|
|
|
|
// apply the new mask to the destination GC
|
|
// The new mask has only the size of the destination rectangle, not of
|
|
// the whole destination. Apply it to destination and move it to the right
|
|
// position.
|
|
gdk_gc_set_clip_mask(DestinationGC, NewClipMask);
|
|
gdk_gc_set_clip_origin(DestinationGC, x, y);
|
|
EndGDKErrorTrap;
|
|
end;
|
|
|
|
function CreatePixbufFromImageAndMask(ASrc: PGdkDrawable; ASrcX, ASrcY, ASrcWidth,
|
|
ASrcHeight: integer; ASrcColorMap: PGdkColormap; ASrcMask: PGdkBitmap): PGdkPixbuf;
|
|
|
|
procedure Warn(const AText: String);
|
|
begin
|
|
DebugLn('[WARNING] ScalePixmapAndMask: ' + AText);
|
|
end;
|
|
|
|
procedure ApplyMask(APixels, AMask: pguchar);
|
|
type
|
|
TPixbufPixel = record
|
|
R,G,B,A: Byte;
|
|
end;
|
|
var
|
|
RGBA: ^TPixbufPixel absolute APixels;
|
|
Mask: ^TPixbufPixel absolute AMask;
|
|
n: Integer;
|
|
begin
|
|
for n := 0 to (ASrcHeight * ASrcWidth) - 1 do
|
|
begin
|
|
if (Mask^.B = 0) and (Mask^.G = 0) and (Mask^.R = 0)
|
|
then RGBA^.A := 0;
|
|
inc(RGBA);
|
|
inc(Mask);
|
|
end;
|
|
end;
|
|
|
|
var
|
|
Msk: PGdkPixbuf;
|
|
FullSrcWidth, FullSrcHeight: integer;
|
|
begin
|
|
Result := nil;
|
|
if ASrc = nil then Exit;
|
|
|
|
gdk_window_get_size(PGDKWindow(ASrc), @FullSrcWidth, @FullSrcHeight);
|
|
if ASrcX + ASrcWidth > FullSrcWidth
|
|
then begin
|
|
Warn('ASrcX+ASrcWidth>FullSrcWidth');
|
|
end;
|
|
if ASrcY + ASrcHeight > FullSrcHeight
|
|
then begin
|
|
Warn('ASrcY+ASrcHeight>FullSrcHeight');
|
|
end;
|
|
|
|
// Creating PixBuf from pixmap
|
|
Result := CreatePixbufFromDrawable(ASrc, ASrcColorMap, ASrcMask <> nil, ASrcX, ASrcY, 0, 0, ASrcWidth, ASrcHeight);
|
|
if Result = nil
|
|
then begin
|
|
Warn('Result=nil');
|
|
Exit;
|
|
end;
|
|
//DbgDumpPixbuf(Result, 'Pixbuf from Source');
|
|
|
|
// Apply mask if present
|
|
if ASrcMask <> nil
|
|
then begin
|
|
if gdk_pixbuf_get_rowstride(Result) <> ASrcWidth shl 2
|
|
then begin
|
|
Warn('rowstride <> 4*width');
|
|
gdk_pixbuf_unref(Result);
|
|
Result := nil;
|
|
Exit;
|
|
end;
|
|
|
|
Msk := CreatePixbufFromDrawable(ASrcMask, nil, True, ASrcX, ASrcY, 0, 0, ASrcWidth, ASrcHeight);
|
|
ApplyMask(gdk_pixbuf_get_pixels(Result), gdk_pixbuf_get_pixels(Msk));
|
|
gdk_pixbuf_unref(Msk);
|
|
end;
|
|
end;
|
|
|
|
function ScalePixmapAndMask(AScaleGC: PGDKGC; AScaleMethod: TGdkInterpType;
|
|
ASrc: PGdkPixmap; ASrcX, ASrcY, ASrcWidth, ASrcHeight: integer;
|
|
ASrcColorMap: PGdkColormap; ASrcMask: PGdkBitmap;
|
|
ADstWidth, ADstHeight: Integer; FlipHorz, FlipVert: Boolean;
|
|
out ADst, ADstMask: PGdkPixmap) : Boolean;
|
|
|
|
procedure Warn(const AText: String);
|
|
begin
|
|
DebugLn('[WARNING] ScalePixmapAndMask: ' + AText);
|
|
end;
|
|
|
|
var
|
|
ScaleSrc, ScaleDst: PGdkPixbuf;
|
|
begin
|
|
Result := False;
|
|
ADst:=nil;
|
|
ADstMask:=nil;
|
|
|
|
// Creating PixBuf from pixmap
|
|
ScaleSrc := CreatePixbufFromImageAndMask(ASrc, ASrcX, ASrcY, ASrcWidth, ASrcHeight,
|
|
ASrcColorMap, ASrcMask);
|
|
|
|
// Scaling PixBuf
|
|
ScaleDst := gdk_pixbuf_scale_simple(ScaleSrc, ADstWidth, ADstHeight, AScaleMethod);
|
|
gdk_pixbuf_unref(ScaleSrc);
|
|
if ScaleDst = nil
|
|
then begin
|
|
Warn('ScaleDst=nil');
|
|
exit;
|
|
end;
|
|
|
|
// flip if needed
|
|
if FlipHorz then
|
|
begin
|
|
{$IFNDEF GTK1}
|
|
ScaleSrc := ScaleDst;
|
|
ScaleDst := gdk_pixbuf_flip(ScaleSrc, True);
|
|
gdk_pixbuf_unref(ScaleSrc);
|
|
if ScaleDst = nil
|
|
then begin
|
|
Warn('ScaleDst=nil');
|
|
exit;
|
|
end;
|
|
{$ELSE}
|
|
// TODO: implement flipping for gtk1
|
|
{$ENDIF}
|
|
end;
|
|
|
|
if FlipVert then
|
|
begin
|
|
{$IFNDEF GTK1}
|
|
ScaleSrc := ScaleDst;
|
|
ScaleDst := gdk_pixbuf_flip(ScaleSrc, False);
|
|
gdk_pixbuf_unref(ScaleSrc);
|
|
if ScaleDst = nil
|
|
then begin
|
|
Warn('ScaleDst=nil');
|
|
exit;
|
|
end;
|
|
{$ELSE}
|
|
// TODO: implement flipping for gtk1
|
|
{$ENDIF}
|
|
end;
|
|
|
|
// BeginGDKErrorTrap;
|
|
|
|
// Creating pixmap from scaled pixbuf
|
|
gdk_pixbuf_render_pixmap_and_mask(ScaleDst, ADst, ADstMask, $80);
|
|
|
|
// EndGDKErrorTrap;
|
|
gdk_pixbuf_unref(ScaleDst);
|
|
Result := True;
|
|
end;
|
|
|
|
{$IFDEF VerboseGtkToDos}{$note remove when gtk native imagelist will be ready}{$ENDIF}
|
|
procedure DrawImageListIconOnWidget(ImgList: TCustomImageList;
|
|
Index: integer; AEffect: TGraphicsDrawEffect; DestWidget: PGTKWidget;
|
|
CenterHorizontally, CenterVertically: boolean;
|
|
DestLeft, DestTop: integer);
|
|
// draw icon of imagelist centered on gdkwindow
|
|
var
|
|
Bitmap: TBitmap;
|
|
ImageWidth: Integer;
|
|
ImageHeight: Integer;
|
|
WindowWidth, WindowHeight: integer;
|
|
DestDC: HDC;
|
|
Offset: TPoint;
|
|
{$ifdef gtk2}
|
|
FixedWidget: PGtkWidget;
|
|
{$ENDIF}
|
|
begin
|
|
if ImgList=nil then exit;
|
|
if (Index<0) or (Index>=ImgList.Count) then exit;
|
|
if (DestWidget=nil) then exit;
|
|
ImageWidth:=ImgList.Width;
|
|
ImageHeight:=ImgList.Height;
|
|
Bitmap := TBitmap.Create;
|
|
ImgList.GetBitmap(Index, Bitmap, AEffect);
|
|
if (ImageWidth<1) or (ImageHeight<1) then exit;
|
|
|
|
WindowWidth := DestWidget^.allocation.width;
|
|
WindowHeight := DestWidget^.allocation.height;
|
|
|
|
Offset := Point(0, 0);
|
|
{$ifdef gtk2}
|
|
// if our widget is placed on non-window fixed then we should substract its allocation here
|
|
// since in GetDC we will get this difference in offset
|
|
FixedWidget := GetFixedWidget(DestWidget);
|
|
if (FixedWidget <> nil) and GTK_WIDGET_NO_WINDOW(FixedWidget) then
|
|
Offset := Point(FixedWidget^.allocation.x, FixedWidget^.allocation.y);
|
|
{$endif}
|
|
|
|
if CenterHorizontally then
|
|
DestLeft := DestWidget^.allocation.x - Offset.x + ((WindowWidth-ImageWidth) div 2);
|
|
if CenterVertically then
|
|
DestTop := DestWidget^.allocation.y - Offset.y + ((WindowHeight-ImageHeight) div 2);
|
|
DestDC := GetDC(HDC(PtrUInt(DestWidget)));
|
|
|
|
//DebugLn('DrawImageListIconOnWidget B DestXY=',DestLeft,',',DestTop,
|
|
// ' DestWindowSize=',WindowWidth,',',WindowWidth,
|
|
// ' SrcRect=',ImageRect.Left,',',ImageRect.Top,',',ImageWidth,'x',ImageHeight);
|
|
StretchBlt(DestDC, DestLeft, DestTop, ImageWidth, ImageHeight,
|
|
Bitmap.Canvas.Handle, 0, 0, ImageWidth, ImageHeight,
|
|
SRCCOPY);
|
|
ReleaseDC(HDC(PtrUInt(DestWidget)),DestDC);
|
|
Bitmap.Free;
|
|
end;
|
|
|
|
procedure DrawImageListIconOnWidget(ImgList: TCustomImageList;
|
|
Index: integer; DestWidget: PGTKWidget);
|
|
begin
|
|
DrawImageListIconOnWidget(ImgList, Index, gdeNormal, DestWidget, true, true, 0, 0);
|
|
end;
|
|
|
|
function GetGdkImageBitsPerPixel(Image: PGdkImage): cardinal;
|
|
begin
|
|
Result:=Image^.bpp;
|
|
if Result<Image^.Depth then
|
|
Result:=Result*8;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Function: CreateGtkBitmapMask
|
|
Params: AImageMask: Then internal gtkBitmap for imagemask
|
|
AMask: External gtkbitmap
|
|
Returns: A GdkBitmap
|
|
|
|
This function returns a bitmap based on the internal alpha bitmap and the
|
|
maskhandle passed.
|
|
If both internal mask and the given mask is valid, then a new bitmap is created
|
|
else either internal mask or given mask (with increased reference)
|
|
------------------------------------------------------------------------------}
|
|
function CreateGdkMaskBitmap(AImageMask, AMask: PGdkBitmap): PGdkBitmap;
|
|
var
|
|
W, H: Integer;
|
|
GC: PGdkGc;
|
|
begin
|
|
Result := nil;
|
|
if (AImageMask = nil) and (AMask = nil) then Exit;
|
|
|
|
if AMask = nil
|
|
then begin
|
|
Result := AImageMask;
|
|
gdk_pixmap_ref(Result);
|
|
Exit;
|
|
end;
|
|
|
|
if AImageMask = nil
|
|
then begin
|
|
Result := AMask;
|
|
gdk_pixmap_ref(Result);
|
|
Exit;
|
|
end;
|
|
|
|
// if we are here we need a combination (=AND) of both masks
|
|
gdk_window_get_size(AImageMask, @W, @H);
|
|
Result := gdk_pixmap_new(nil, W, H, 1);
|
|
GC := gdk_gc_new(Result);
|
|
// copy image mask
|
|
gdk_draw_pixmap(Result, GC, AImageMask, 0, 0, 0, 0, -1, -1);
|
|
// and with mask
|
|
gdk_gc_set_function(GC, GDK_AND);
|
|
gdk_draw_pixmap(Result, GC, AMask, 0, 0, 0, 0, -1, -1);
|
|
gdk_gc_unref(GC);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Function: CreateGdkMaskBitmap
|
|
Params: AImage: Handle to the (LCL) bitmap image
|
|
AMask: Handle to the (LCL) bitmap mask
|
|
Returns: A GdkBitmap
|
|
|
|
This function returns a bitmap based on the internal alpha bitmap of the
|
|
image handle and the maskhandle passed.
|
|
If only internal mask is valid, then that one is returned (with increased reference)
|
|
Otherwise a new bitmap is created.
|
|
------------------------------------------------------------------------------}
|
|
function CreateGdkMaskBitmap(AImage, AMask: HBITMAP): PGdkBitmap;
|
|
var
|
|
GdiImage: PGdiObject absolute AImage;
|
|
GdiMask: PGdiObject absolute AMask;
|
|
W, H: Integer;
|
|
GC: PGdkGc;
|
|
begin
|
|
Result := nil;
|
|
if (AImage = 0) and (AMask = 0) then Exit;
|
|
|
|
if GdiMask = nil
|
|
then begin
|
|
if GdiImage^.GDIBitmapType = gbPixmap
|
|
then Result := GdiImage^.GDIPixmapObject.Mask;
|
|
if Result <> nil
|
|
then gdk_pixmap_ref(Result);
|
|
// DbgDumpBitmap(Result, 'CreateGdkMaskBitmap - Internal mask');
|
|
Exit;
|
|
end;
|
|
|
|
if GdiMask^.GDIBitmapType <> gbBitmap
|
|
then begin
|
|
DebugLN('[WARNING] CreateGtkBitmapMask: GDIBitmapType <> dbBitmap');
|
|
Exit;
|
|
end;
|
|
|
|
if (GdiImage = nil)
|
|
or (GdiImage^.GDIBitmapType <> gbPixmap)
|
|
or (GdiImage^.GDIPixmapObject.Mask = nil)
|
|
then begin
|
|
gdk_window_get_size(GdiMask^.GDIBitmapObject, @W, @H);
|
|
Result := gdk_pixmap_new(nil, W, H, 1);
|
|
GC := gdk_gc_new(Result);
|
|
gdk_gc_set_function(GC, {$ifdef gtk1}11{$else}GDK_COPY_INVERT{$endif});
|
|
gdk_draw_pixmap(Result, GC, GdiMask^.GDIBitmapObject, 0, 0, 0, 0, -1, -1);
|
|
gdk_gc_unref(GC);
|
|
|
|
//DbgDumpBitmap(Result, 'CreateGdkMaskBitmap - Mask');
|
|
Exit;
|
|
end;
|
|
|
|
// if we are here we need a combination (=AND) of both masks
|
|
gdk_window_get_size(GdiImage^.GDIPixmapObject.Mask, @W, @H);
|
|
Result := gdk_pixmap_new(nil, W, H, 1);
|
|
GC := gdk_gc_new(Result);
|
|
// copy image mask
|
|
gdk_draw_pixmap(Result, GC, GdiImage^.GDIPixmapObject.Mask, 0, 0, 0, 0, -1, -1);
|
|
// and with mask
|
|
gdk_gc_set_function(GC, {$ifdef gtk1}6{$else}GDK_AND_INVERT{$endif});
|
|
gdk_draw_pixmap(Result, GC, GdiMask^.GDIBitmapObject, 0, 0, 0, 0, -1, -1);
|
|
gdk_gc_unref(GC);
|
|
|
|
// DbgDumpBitmap(Result, 'CreateGdkMaskBitmap - Combi');
|
|
end;
|
|
|
|
function ExtractGdkBitmap(Bitmap: PGdkBitmap; const SrcRect: TRect): PGdkBitmap;
|
|
var
|
|
MaxRect: TRect;
|
|
SourceRect: TRect;
|
|
SrcWidth: Integer;
|
|
SrcHeight: Integer;
|
|
GC: PGdkGC;
|
|
begin
|
|
Result:=nil;
|
|
if Bitmap=nil then exit;
|
|
MaxRect:=Rect(0,0,0,0);
|
|
gdk_window_get_size(Bitmap,@MaxRect.Right,@MaxRect.Bottom);
|
|
IntersectRect(SourceRect,SrcRect,MaxRect);
|
|
SrcWidth:=SourceRect.Right-SourceRect.Left;
|
|
SrcHeight:=SourceRect.Bottom-SourceRect.Top;
|
|
DebugLn('ExtractGdkBitmap SourceRect=',dbgs(SourceRect));
|
|
if (SrcWidth<1) or (SrcHeight<1) then exit;
|
|
Result:= gdk_pixmap_new(nil, SrcWidth, SrcHeight, 1);
|
|
GC := GDK_GC_New(Result);
|
|
gdk_window_copy_area(Result,GC,0,0,Bitmap,
|
|
SourceRect.Left,SourceRect.Top,SrcWidth,SrcHeight);
|
|
GDK_GC_Unref(GC);
|
|
end;
|
|
|
|
procedure CheckGdkImageBitOrder(AImage: PGdkImage; AData: PByte; ADataCount: Integer);
|
|
var
|
|
b, count: Byte;
|
|
c: Cardinal;
|
|
|
|
{$ifdef hasx}
|
|
XImage: XLib.PXimage;
|
|
{$endif}
|
|
begin
|
|
{$ifdef hasx}
|
|
if AImage = nil then Exit;
|
|
|
|
XImage := gdk_x11_image_get_ximage(AImage);
|
|
if XImage^.bitmap_bit_order = LSBFirst then Exit;
|
|
{$endif}
|
|
|
|
// on windows or bigendian servers the bits need to be swapped
|
|
|
|
// align dataptr first
|
|
count := PtrUint(AData) and 3;
|
|
if count > ADataCount then count := ADataCount;
|
|
Dec(ADataCount, Count);
|
|
|
|
while (Count > 0) do
|
|
begin
|
|
// reduce dereferences
|
|
b := AData^;
|
|
b := ((b shr 4) and $0F) or ((b shl 4) and $F0);
|
|
b := ((b shr 2) and $33) or ((b shl 2) and $CC);
|
|
AData^ := ((b shr 1) and $55) or ((b shl 1) and $AA);
|
|
|
|
Dec(Count);
|
|
Inc(AData);
|
|
end;
|
|
|
|
// get remainder
|
|
Count := ADataCount and 3;
|
|
|
|
// now swap bits with 4 in a row
|
|
ADataCount := ADataCount shr 2;
|
|
while (ADataCount > 0) do
|
|
begin
|
|
// reduce dereferences
|
|
c := PCardinal(AData)^;
|
|
c := ((c shr 4) and $0F0F0F0F) or ((c shl 4) and $F0F0F0F0);
|
|
c := ((c shr 2) and $33333333) or ((c shl 2) and $CCCCCCCC);
|
|
PCardinal(AData)^ := ((c shr 1) and $55555555) or ((c shl 1) and $AAAAAAAA);
|
|
|
|
Dec(ADataCount);
|
|
Inc(AData, 4);
|
|
end;
|
|
|
|
// process remainder
|
|
while (Count > 0) do
|
|
begin
|
|
// reduce dereferences
|
|
b := AData^;
|
|
b := ((b shr 4) and $0F) or ((b shl 4) and $F0);
|
|
b := ((b shr 2) and $33) or ((b shl 2) and $CC);
|
|
AData^ := ((b shr 1) and $55) or ((b shl 1) and $AA);
|
|
|
|
Dec(Count);
|
|
Inc(AData);
|
|
end;
|
|
|
|
end;
|
|
|
|
|
|
{------------------------------------------------------------------------------
|
|
Function: AllocGDKColor
|
|
Params: AColor: A RGB color (TColor)
|
|
Returns: an Allocated GDKColor
|
|
|
|
Allocated a GDKColor from a winapi color
|
|
------------------------------------------------------------------------------}
|
|
function AllocGDKColor(const AColor: TColorRef): TGDKColor;
|
|
begin
|
|
with Result do
|
|
begin
|
|
Red := ((AColor shl 8) and $00FF00) or ((AColor ) and $0000FF);
|
|
Green := ((AColor ) and $00FF00) or ((AColor shr 8 ) and $0000FF);
|
|
Blue := ((AColor shr 8) and $00FF00) or ((AColor shr 16) and $0000FF);
|
|
end;
|
|
{$IFDEF DebugGDK}
|
|
BeginGDKErrorTrap;
|
|
{$ENDIF}
|
|
gdk_colormap_alloc_color(gdk_colormap_get_system, @Result, False, True);
|
|
{$IFDEF DebugGDK}
|
|
EndGDKErrorTrap;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
|
|
function RegionType(RGN: PGDKRegion) : Longint;
|
|
var
|
|
aRect : TGDKRectangle;
|
|
SimpleRGN: PGdkRegion;
|
|
begin
|
|
{$IFDEF DebugGDK}
|
|
BeginGDKErrorTrap;
|
|
{$ENDIF}
|
|
If RGN = nil then
|
|
Result := ERROR
|
|
else
|
|
If gdk_region_empty(RGN) then
|
|
Result := NULLREGION
|
|
else begin
|
|
gdk_region_get_clipbox(RGN,@aRect);
|
|
SimpleRGN := gdk_region_rectangle(@aRect);
|
|
if gdk_region_equal(SimpleRGN, RGN) then
|
|
Result := SIMPLEREGION
|
|
else
|
|
Result := COMPLEXREGION;
|
|
gdk_region_destroy(SimpleRGN);
|
|
end;
|
|
{$IFDEF DebugGDK}
|
|
EndGDKErrorTrap;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
|
|
function GDKRegionAsString(RGN: PGDKRegion): string;
|
|
var
|
|
aRect: TGDKRectangle;
|
|
begin
|
|
Result:=DbgS(RGN);
|
|
BeginGDKErrorTrap;
|
|
gdk_region_get_clipbox(RGN,@aRect);
|
|
EndGDKErrorTrap;
|
|
Result:=Result+'(x='+IntToStr(Integer(aRect.x))+',y='+IntToStr(Integer(aRect.y))+',w='
|
|
+IntToStr(aRect.Width)+',h='+IntToStr(aRect.Height)+' '
|
|
+'Type='+IntToStr(RegionType(RGN))+')';
|
|
end;
|
|
|
|
function CreateRectGDKRegion(const ARect: TRect): PGDKRegion;
|
|
var
|
|
GDkRect: TGDKRectangle;
|
|
begin
|
|
GDkRect.x:=ARect.Left;
|
|
GDkRect.y:=ARect.Top;
|
|
GDkRect.Width:=ARect.Right-ARect.Left;
|
|
GDkRect.Height:=ARect.Bottom-ARect.Top;
|
|
{$IFDEF DebugGDK}
|
|
BeginGDKErrorTrap;
|
|
{$ENDIF}
|
|
Result:=gdk_region_rectangle(@GDKRect);
|
|
{$IFDEF DebugGDK}
|
|
EndGDKErrorTrap;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
Procedure FreeGDIColor(GDIColor: PGDIColor);
|
|
begin
|
|
if (cfColorAllocated in GDIColor^.ColorFlags) then begin
|
|
if (GDIColor^.Colormap <> nil) then begin
|
|
BeginGDKErrorTrap;
|
|
gdk_colormap_free_colors(GDIColor^.Colormap,@(GDIColor^.Color), 1);
|
|
EndGDKErrorTrap;
|
|
end;
|
|
//GDIColor.Color.Pixel := -1;
|
|
Exclude(GDIColor^.ColorFlags,cfColorAllocated);
|
|
end;
|
|
end;
|
|
|
|
procedure SetGDIColorRef(var GDIColor: TGDIColor; NewColorRef: TColorRef);
|
|
begin
|
|
if GDIColor.ColorRef=NewColorRef then exit;
|
|
FreeGDIColor(@GDIColor);
|
|
GDIColor.ColorRef:=NewColorRef;
|
|
end;
|
|
|
|
Procedure AllocGDIColor(DC: hDC; GDIColor: PGDIColor);
|
|
var
|
|
RGBColor : TColorRef;
|
|
begin
|
|
if DC=0 then ;
|
|
if not (cfColorAllocated in GDIColor^.ColorFlags) then begin
|
|
RGBColor := ColorToRGB(TColor(GDIColor^.ColorRef));
|
|
|
|
With GDIColor^.Color do begin
|
|
Red := gushort(GetRValue(RGBColor)) shl 8;
|
|
Green := gushort(GetGValue(RGBColor)) shl 8;
|
|
Blue := gushort(GetBValue(RGBColor)) shl 8;
|
|
Pixel := 0;
|
|
end;
|
|
|
|
{with TGtkDeviceContext(DC) do
|
|
If CurrentPalette <> nil then
|
|
GDIColor.Colormap := CurrentPalette^.PaletteColormap
|
|
else}
|
|
GDIColor^.Colormap := GDK_Colormap_get_system;
|
|
|
|
gdk_colormap_alloc_color(GDIColor^.Colormap, @(GDIColor^.Color),True,True);
|
|
|
|
Include(GDIColor^.ColorFlags,cfColorAllocated);
|
|
end;
|
|
end;
|
|
|
|
procedure BuildColorRefFromGDKColor(var GDIColor: TGDIColor);
|
|
begin
|
|
GDIColor.ColorRef:=TGDKColorToTColor(GDIColor.Color);
|
|
Include(GDIColor.ColorFlags,cfColorAllocated);
|
|
end;
|
|
|
|
procedure EnsureGCColor(DC: hDC; ColorType: TDevContextsColorType;
|
|
IsSolidBrush, AsBackground: Boolean);
|
|
var
|
|
GC: PGDKGC;
|
|
GDIColor: PGDIColor;
|
|
|
|
procedure WarnAllocFailed(const foreground : TGdkColor);
|
|
begin
|
|
DebugLn('NOTE: EnsureGCColor.EnsureAsGCValues gdk_colormap_alloc_color failed ',
|
|
' Foreground=',
|
|
DbgS(Foreground.red),',',
|
|
DbgS(Foreground.green),',',
|
|
DbgS(Foreground.blue),
|
|
' GDIColor^.ColorRef=',DbgS(GDIColor^.ColorRef)
|
|
);
|
|
end;
|
|
|
|
procedure EnsureAsGCValues;
|
|
var
|
|
AllocFG : Boolean;
|
|
SysGCValues: TGdkGCValues;
|
|
begin
|
|
FreeGDIColor(GDIColor);
|
|
SysGCValues:=GetSysGCValues(GDIColor^.ColorRef,
|
|
TGtkDeviceContext(DC).Widget);
|
|
{$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF}
|
|
with SysGCValues do
|
|
begin
|
|
AllocFG := Foreground.Pixel = 0;
|
|
if AllocFG then
|
|
if not gdk_colormap_alloc_color(GDK_Colormap_get_system, @Foreground,
|
|
True, True) then
|
|
WarnAllocFailed(Foreground);
|
|
gdk_gc_set_fill(GC, fill);
|
|
if AsBackground then
|
|
gdk_gc_set_background(GC, @foreground)
|
|
else
|
|
gdk_gc_set_foreground(GC, @foreground);
|
|
case Fill of
|
|
GDK_TILED :
|
|
if Tile <> nil then
|
|
begin
|
|
gdk_gc_set_ts_origin(GC, ts_x_origin, ts_y_origin);
|
|
gdk_gc_set_tile(GC, Tile);
|
|
end;
|
|
GDK_STIPPLED,
|
|
GDK_OPAQUE_STIPPLED:
|
|
if stipple <> nil then
|
|
begin
|
|
gdk_gc_set_background(GC, @background);
|
|
gdk_gc_set_ts_origin(GC, ts_x_origin, ts_y_origin);
|
|
gdk_gc_set_stipple(GC, stipple);
|
|
end;
|
|
end;
|
|
if AllocFG then
|
|
gdk_colormap_free_colors(GDK_Colormap_get_system, @Foreground,1);
|
|
end;
|
|
{$IFDEF DebugGDK}EndGDKErrorTrap;{$ENDIF}
|
|
end;
|
|
|
|
procedure EnsureAsColor;
|
|
begin
|
|
AllocGDIColor(DC, GDIColor);
|
|
//DebugLn('EnsureAsColor ',DbgS(GDIColor^.ColorRef),' AsBackground=',AsBackground);
|
|
{$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF}
|
|
if AsBackground then
|
|
gdk_gc_set_background(GC, @(GDIColor^.Color))
|
|
else
|
|
begin
|
|
gdk_gc_set_fill(GC, GDK_SOLID);
|
|
gdk_gc_set_foreground(GC, @(GDIColor^.Color));
|
|
end;
|
|
{$IFDEF DebugGDK}EndGDKErrorTrap;{$ENDIF}
|
|
end;
|
|
|
|
begin
|
|
GC:=TGtkDeviceContext(DC).GC;
|
|
GDIColor:=nil;
|
|
with TGtkDeviceContext(DC) do
|
|
begin
|
|
case ColorType of
|
|
dccCurrentBackColor: GDIColor:=@CurrentBackColor;
|
|
dccCurrentTextColor: GDIColor:=@CurrentTextColor;
|
|
dccGDIBrushColor : GDIColor:=@(GetBrush^.GDIBrushColor);
|
|
dccGDIPenColor : GDIColor:=@(GetPen^.GDIPenColor);
|
|
end;
|
|
end;
|
|
if GDIColor=nil then exit;
|
|
|
|
// FPC bug workaround:
|
|
// clScrollbar = $80000000 can't be used in case statements
|
|
if TColor(GDIColor^.ColorRef)=clScrollbar then
|
|
begin
|
|
//often have a BK Pixmap
|
|
if IsSolidBrush then
|
|
EnsureAsGCValues
|
|
else
|
|
EnsureAsColor;//GC's with Pixmaps can't work w/Hatch's (yet)
|
|
exit;
|
|
end;
|
|
|
|
case TColor(GDIColor^.ColorRef) of
|
|
//clScrollbar: see above
|
|
clInfoBk,
|
|
clMenu,
|
|
clHighlight,
|
|
clBtnFace,
|
|
clWindow,
|
|
clForm:
|
|
//often have a BK Pixmap
|
|
if IsSolidBrush then
|
|
EnsureAsGCValues
|
|
else
|
|
EnsureAsColor;//GC's with Pixmaps can't work w/Hatch's (yet)
|
|
|
|
clHighlightText,
|
|
clBtnShadow,
|
|
clBtnHighlight,
|
|
clBtnText,
|
|
clInfoText,
|
|
clWindowText,
|
|
clMenuText,
|
|
clGrayText:
|
|
//should never have a BK Pixmap
|
|
EnsureAsGCValues;
|
|
else
|
|
EnsureAsColor;
|
|
end;
|
|
end;
|
|
|
|
procedure CopyGDIColor(var SourceGDIColor, DestGDIColor: TGDIColor);
|
|
begin
|
|
SetGDIColorRef(DestGDIColor,SourceGDIColor.ColorRef);
|
|
end;
|
|
|
|
function IsBackgroundColor(Color: TColor): boolean;
|
|
begin
|
|
Result := (Color = clForm) or
|
|
(Color = clInfoBk) or
|
|
(Color = clBackground);
|
|
end;
|
|
|
|
function CompareGDIColor(const Color1, Color2: TGDIColor): boolean;
|
|
begin
|
|
Result:=Color1.ColorRef=Color2.ColorRef;
|
|
end;
|
|
|
|
function CompareGDIFill(const Fill1, Fill2: TGdkFill): boolean;
|
|
begin
|
|
Result:=Fill1=Fill2;
|
|
end;
|
|
|
|
function CompareGDIBrushes(Brush1, Brush2: PGdiObject): boolean;
|
|
begin
|
|
Result:=Brush1^.IsNullBrush=Brush2^.IsNullBrush;
|
|
if Result then begin
|
|
Result:=CompareGDIColor(Brush1^.GDIBrushColor,Brush2^.GDIBrushColor);
|
|
if Result then begin
|
|
Result:=CompareGDIFill(Brush1^.GDIBrushFill,Brush2^.GDIBrushFill);
|
|
if Result then begin
|
|
Result:=Brush1^.GDIBrushPixMap=Brush2^.GDIBrushPixMap;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
//-----------------------------------------------------------------------------
|
|
|
|
{ Palette Index<->RGB Hash Functions }
|
|
|
|
type
|
|
TIndexRGB = record
|
|
Index: longint;
|
|
RGB: longint;
|
|
end;
|
|
PIndexRGB = ^TIndexRGB;
|
|
|
|
function GetIndexAsKey(p: pointer): pointer;
|
|
begin
|
|
Result:=Pointer(PIndexRGB(p)^.Index + 1);
|
|
end;
|
|
|
|
function GetRGBAsKey(p: pointer): pointer;
|
|
begin
|
|
Result:=Pointer(PIndexRGB(p)^.RGB + 1);
|
|
end;
|
|
|
|
function PaletteIndexToIndexRGB(Pal : PGDIObject; I : longint): PIndexRGB;
|
|
var
|
|
HashItem: PDynHashArrayItem;
|
|
begin
|
|
Result := nil;
|
|
HashItem:=Pal^.IndexTable.FindHashItemWithKey(Pointer(I + 1));
|
|
if HashItem<>nil then
|
|
Result:=PIndexRGB(HashItem^.Item);
|
|
end;
|
|
|
|
function PaletteRGBToIndexRGB(Pal : PGDIObject; RGB : longint): PIndexRGB;
|
|
var
|
|
HashItem: PDynHashArrayItem;
|
|
begin
|
|
Result := nil;
|
|
HashItem:=Pal^.RGBTable.FindHashItemWithKey(Pointer(RGB + 1));
|
|
if HashItem<>nil then
|
|
Result:=PIndexRGB(HashItem^.Item);
|
|
end;
|
|
|
|
{ Palette Index<->RGB lookup Functions }
|
|
|
|
function PaletteIndexExists(Pal : PGDIObject; I : longint): Boolean;
|
|
begin
|
|
Result := Pal^.IndexTable.ContainsKey(Pointer(I + 1));
|
|
end;
|
|
|
|
function PaletteRGBExists(Pal : PGDIObject; RGB : longint): Boolean;
|
|
begin
|
|
Result := Pal^.RGBTable.ContainsKey(Pointer(RGB + 1));
|
|
end;
|
|
|
|
function PaletteAddIndex(Pal : PGDIObject; I, RGB : Longint): Boolean;
|
|
var
|
|
IndexRGB: PIndexRGB;
|
|
begin
|
|
New(IndexRGB);
|
|
IndexRGB^.Index:=I;
|
|
IndexRGB^.RGB:=RGB;
|
|
Pal^.IndexTable.Add(IndexRGB);
|
|
Result := PaletteIndexExists(Pal, I);
|
|
If Not Result then
|
|
Dispose(IndexRGB)
|
|
else begin
|
|
Pal^.RGBTable.Add(IndexRGB);
|
|
Result := PaletteRGBExists(Pal, RGB);
|
|
If not Result then begin
|
|
Pal^.IndexTable.Remove(IndexRGB);
|
|
Dispose(IndexRGB);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function PaletteDeleteIndex(Pal : PGDIObject; I : Longint): Boolean;
|
|
var
|
|
RGBIndex : PIndexRGB;
|
|
begin
|
|
RGBIndex := PaletteIndextoIndexRGB(Pal,I);
|
|
Result := RGBIndex = nil;
|
|
If not Result then begin
|
|
Pal^.IndexTable.Remove(RGBIndex);
|
|
If PaletteRGBExists(Pal, RGBIndex^.RGB) then
|
|
Pal^.RGBTable.Remove(RGBIndex);
|
|
Dispose(RGBIndex);
|
|
end;
|
|
end;
|
|
|
|
function PaletteIndexToRGB(Pal : PGDIObject; I : longint): longint;
|
|
var
|
|
RGBIndex : PIndexRGB;
|
|
begin
|
|
RGBIndex := PaletteIndextoIndexRGB(Pal,I);
|
|
if RGBIndex = nil then
|
|
Result := -1//InvalidRGB
|
|
else
|
|
Result := RGBIndex^.RGB;
|
|
end;
|
|
|
|
function PaletteRGBToIndex(Pal : PGDIObject; RGB : longint): longint;
|
|
var
|
|
RGBIndex : PIndexRGB;
|
|
begin
|
|
RGBIndex := PaletteRGBtoIndexRGB(Pal,RGB);
|
|
if RGBIndex = nil then
|
|
Result:=-1//InvalidIndex
|
|
else
|
|
Result := RGBIndex^.Index;
|
|
end;
|
|
|
|
procedure InitializePalette(const Pal: PGDIObject; const Entries: PPaletteEntry; const RGBCount: Longint);
|
|
var
|
|
I: Integer;
|
|
RGBValue: Longint;
|
|
begin
|
|
for I := 0 to RGBCount - 1 do
|
|
begin
|
|
if PaletteIndexExists(Pal, I) then
|
|
PaletteDeleteIndex(Pal, I);
|
|
with Entries[I] do
|
|
RGBValue := RGB(peRed, peGreen, peBlue) {or (peFlags shl 32)??};
|
|
if not PaletteRGBExists(Pal, RGBValue) then
|
|
PaletteAddIndex(Pal, I, RGBValue);
|
|
end;
|
|
end;
|
|
|
|
function HandleGTKKeyUpDown(AWidget: PGtkWidget; AEvent: PGdkEventKey;
|
|
AData: gPointer; ABeforeEvent, AHandleDown: Boolean;
|
|
const AEventName: PGChar) : GBoolean;
|
|
// returns CallBackDefaultReturn if event can continue in gtk's message system
|
|
{off $DEFINE VerboseKeyboard}
|
|
const
|
|
KEYUP_MAP: array[Boolean {syskey}, Boolean {before}] of Cardinal = (
|
|
(LM_KEYUP, CN_KEYUP),
|
|
(LM_SYSKEYUP, CN_SYSKEYUP)
|
|
);
|
|
|
|
KEYDOWN_MAP: array[Boolean {syskey}, Boolean {before}] of Cardinal = (
|
|
(LM_KEYDOWN, CN_KEYDOWN),
|
|
(LM_SYSKEYDOWN, CN_SYSKEYDOWN)
|
|
);
|
|
|
|
CHAR_MAP: array[Boolean {syskey}, Boolean {before}] of Cardinal = (
|
|
(LM_CHAR, CN_CHAR),
|
|
(LM_SYSCHAR, CN_SYSCHAR)
|
|
);
|
|
var
|
|
Msg: TLMKey;
|
|
EventStopped: Boolean;
|
|
EventString: PChar; // GTK1 and GTK2 workaround
|
|
// (and easy access to bytes)
|
|
KeyCode: Word;
|
|
KCInfo: TKeyCodeInfo;
|
|
VKey: Byte;
|
|
ShiftState: TShiftState;
|
|
|
|
Character: TUTF8Char;
|
|
SysKey: Boolean;
|
|
|
|
CommonKeyData: Integer;
|
|
Flags: Integer;
|
|
FocusedWidget: PGtkWidget;
|
|
LCLObject: TObject;
|
|
FocusedWinControl: TWinControl;
|
|
HandledByLCL: Boolean;
|
|
TargetWidget: PGtkWidget;
|
|
TargetObj: gPointer;
|
|
KeyPressesChar: char;
|
|
|
|
procedure StopKeyEvent;
|
|
begin
|
|
{$IFDEF VerboseKeyboard}
|
|
DebugLn('StopKeyEvent AEventName="',AEventName,'" ABeforeEvent=',dbgs(ABeforeEvent));
|
|
{$ENDIF}
|
|
if not EventStopped
|
|
then begin
|
|
g_signal_stop_emission_by_name(PGtkObject(AWidget), AEventName);
|
|
EventStopped := True;
|
|
end;
|
|
|
|
//MWE: still need to skip on win32 ?
|
|
{MWE:.$IfNDef Win32}
|
|
if EventString <> nil
|
|
then begin
|
|
gdk_event_key_set_string(AEvent, #0);
|
|
AEvent^.length := 0;
|
|
end;
|
|
{MWE:.$EndIf}
|
|
ResetDefaultIMContext;
|
|
|
|
AEvent^.KeyVal := 0;
|
|
end;
|
|
|
|
function DeliverKeyMessage(const Target: Pointer; var AMessage): boolean;
|
|
begin
|
|
Result:=DeliverMessage(Target,AMessage)=0;
|
|
if not Result then StopKeyEvent;
|
|
end;
|
|
|
|
function GetSpecialChar: Char;
|
|
begin
|
|
if (AEvent^.keyval > $FF00) and (AEvent^.keyval < $FF20) and
|
|
(AEvent^.keyval <> GDK_KEY_Tab) then
|
|
Result := Chr(AEvent^.keyval xor $FF00)
|
|
else
|
|
Result := #0;
|
|
end;
|
|
|
|
function CanSendChar: Boolean;
|
|
begin
|
|
Result := False;
|
|
if AEvent^.Length > 1 then Exit;
|
|
|
|
// to be delphi compatible we should not send a space here
|
|
if AEvent^.KeyVal = GDK_KEY_KP_SPACE then Exit;
|
|
|
|
// Check if CTRL is pressed
|
|
if ssCtrl in ShiftState
|
|
then begin
|
|
// Check if we pressed ^@
|
|
if (AEvent^.Length = 0)
|
|
and (AEvent^.KeyVal = GDK_KEY_AT)
|
|
then begin
|
|
Result := True;
|
|
Exit;
|
|
end;
|
|
// check if we send the ^Char subset
|
|
if (AEvent^.Length = 1) and (EventString <> nil)
|
|
then begin
|
|
Result := (EventString^ > #0) and (EventString^ < ' ');
|
|
end;
|
|
Exit;
|
|
end;
|
|
Result := (AEvent^.Length > 0) or (GetSpecialChar <> #0);
|
|
end;
|
|
|
|
function KeyAlreadyHandledByGtk: boolean;
|
|
begin
|
|
Result := false;
|
|
if AWidget = nil then exit;
|
|
|
|
if GtkWidgetIsA(AWidget, gtk_entry_get_type)
|
|
then begin
|
|
// the gtk_entry handles the following keys
|
|
case Aevent^.keyval of
|
|
GDK_Key_Return,
|
|
GDK_Key_Escape,
|
|
GDK_Key_Tab: Exit;
|
|
end;
|
|
|
|
Result := AEvent^.length > 0;
|
|
if Result then Exit;
|
|
|
|
case AEvent^.keyval of
|
|
GDK_Key_BackSpace,
|
|
GDK_Key_Clear,
|
|
GDK_Key_Insert,
|
|
GDK_Key_Delete,
|
|
GDK_Key_Home,
|
|
GDK_Key_End,
|
|
GDK_Key_Left,
|
|
GDK_Key_Right,
|
|
$20..$FF: Result := True;
|
|
end;
|
|
exit;
|
|
end;
|
|
|
|
if GtkWidgetIsA(AWidget, gtk_text_get_type)
|
|
then begin
|
|
// the gtk_text handles the following keys
|
|
case AEvent^.keyval of
|
|
GDK_Key_Escape: Exit;
|
|
end;
|
|
|
|
Result := AEvent^.length > 0;
|
|
if Result then Exit;
|
|
|
|
case AEvent^.keyval of
|
|
GDK_Key_Return,
|
|
GDK_Key_Tab,
|
|
GDK_Key_BackSpace,
|
|
GDK_Key_Clear,
|
|
GDK_Key_Insert,
|
|
GDK_Key_Delete,
|
|
GDK_Key_Home,
|
|
GDK_Key_End,
|
|
GDK_Key_Left,
|
|
GDK_Key_Right,
|
|
GDK_Key_Up,
|
|
GDK_Key_Down,
|
|
$20..$FF: Result := True;
|
|
end;
|
|
exit;
|
|
end;
|
|
end;
|
|
|
|
procedure CharToKeyVal(C: Char; out KeyVal: guint; out Length: gint);
|
|
begin
|
|
Length := 1;
|
|
{$ifndef gtk1}
|
|
if C in [#$01..#$1B] then
|
|
begin
|
|
KeyVal := $FF00 or Ord(C);
|
|
if KeyVal = GDK_KEY_BackSpace then
|
|
Length := 0;
|
|
end
|
|
else
|
|
{$endif}
|
|
KeyVal := Ord(C);
|
|
end;
|
|
|
|
function KeyActivatedAccelerator: boolean;
|
|
|
|
function CheckMenuChilds(AMenuItem: TMenuItem): boolean;
|
|
var
|
|
i: Integer;
|
|
Item: TMenuItem;
|
|
MenuItemWidget: PGtkWidget;
|
|
begin
|
|
Result:=false;
|
|
if (AMenuItem=nil) or (not AMenuItem.HandleAllocated) then exit;
|
|
for i:=0 to AMenuItem.Count-1 do begin
|
|
Item:=AMenuItem[i];
|
|
if not Item.HandleAllocated then continue;
|
|
if not GTK_WIDGET_SENSITIVE(PGTKWidget(Item.Handle)) then continue;
|
|
if IsAccel(Msg.CharCode,Item.Caption) then begin
|
|
// found
|
|
Result:=true;
|
|
MenuItemWidget:=PGTKWidget(Item.Handle);
|
|
if GtkWidgetIsA(MenuItemWidget,gtk_menu_item_get_type) then begin
|
|
//DebugLn(['CheckMenuChilds popup: ',dbgsName(Item)]);
|
|
// popup the submenu
|
|
gtk_signal_emit_by_name(PGtkObject(MenuItemWidget),'activate-item');
|
|
end;
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
var
|
|
AComponent: TComponent;
|
|
AControl: TControl;
|
|
AForm: TCustomForm;
|
|
begin
|
|
Result:=false;
|
|
//debugln('KeyActivatedAccelerator A');
|
|
if not SysKey then exit;
|
|
// it is a system key -> try menus
|
|
if (Msg.CharCode in [VK_A..VK_Z]) then begin
|
|
if (TObject(TargetObj) is TComponent) then begin
|
|
AComponent:=TComponent(TargetObj);
|
|
//DebugLn(['KeyActivatedAccelerator ',dbgsName(AComponent)]);
|
|
if AComponent is TControl then begin
|
|
AControl:=TControl(AComponent);
|
|
repeat
|
|
AForm:=GetFirstParentForm(AControl);
|
|
if AForm<>nil then begin
|
|
if AForm.Menu<>nil then begin
|
|
Result:=CheckMenuChilds(AForm.Menu.Items);
|
|
if Result then exit;
|
|
end;
|
|
end;
|
|
AControl:=AForm.Parent;
|
|
until AControl=nil;
|
|
|
|
{$IFDEF Gtk2}
|
|
// check main menu of MainForm
|
|
if (Application.MainForm<>nil) then begin
|
|
AControl:=TControl(AComponent);
|
|
AForm:=GetParentForm(AControl);
|
|
if (AForm<>nil)
|
|
and (not (fsModal in AForm.FormState))
|
|
and (not Application.MainForm.IsParentOf(AControl))
|
|
and (Application.MainForm.Menu<>nil) then begin
|
|
Result:=CheckMenuChilds(Application.MainForm.Menu.Items);
|
|
if Result then exit;
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure EmulateEatenKeys;
|
|
begin
|
|
// some widgets eats keys, but do not do anything useful for the LCL
|
|
// emulate the keys
|
|
if not ABeforeEvent then Exit;
|
|
if EventStopped then Exit;
|
|
|
|
//DebugLn(['EmulateEatenKeys TargetWidget=',dbghex(PtrInt(TargetWidget))]);
|
|
//DebugLn(['EmulateEatenKeys ',GetWidgetDebugReport(TargetWidget),' gdk_event_get_type(AEvent)=',gdk_event_get_type(AEvent),' GDK_KEY_PRESS=',GDK_KEY_PRESS,' VKey=',VKey]);
|
|
{$IFDEF Gtk2}
|
|
// the gtk2 gtkentry handles the return key and emits an activate signal
|
|
// The LCL does not use that and needs the return key event
|
|
// => emulate it
|
|
if GtkWidgetIsA(TargetWidget, gtk_type_entry)
|
|
and (gdk_event_get_type(AEvent) = GDK_KEY_PRESS)
|
|
and (VKey=13)
|
|
then begin
|
|
//DebugLn(['EmulateKeysEatenByGtk ']);
|
|
FillChar(Msg, SizeOf(Msg), 0);
|
|
Msg.CharCode := VKey;
|
|
if SysKey then
|
|
Msg.msg := LM_SYSKEYDOWN
|
|
else
|
|
Msg.msg := LM_KEYDOWN;
|
|
Msg.KeyData := CommonKeyData or (Flags shl 16) or $0001 {TODO: repeatcount};
|
|
|
|
// send the (Sys)KeyDown message directly to the LCL
|
|
NotifyApplicationUserInput(TControl(TargetObj), Msg.Msg);
|
|
DeliverKeyMessage(TargetObj, Msg);
|
|
end;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure CheckDeadKey;
|
|
begin
|
|
if ABeforeEvent then begin
|
|
{$IFDEF Gtk2}
|
|
if im_context_widget<>TargetWidget then begin
|
|
//DebugLn(['CheckDeadKey init im_context ',GetWidgetDebugReport(TargetWidget)]);
|
|
ResetDefaultIMContext;
|
|
im_context_widget:=TargetWidget;
|
|
gtk_im_context_set_client_window(im_context,GetControlWindow(TargetWidget));
|
|
//DebugLn(['CheckDeadKey im_context initialized']);
|
|
end;
|
|
// Note: gtk_im_context_filter_keypress understands keypress and keyrelease
|
|
gtk_im_context_filter_keypress (im_context, AEvent);
|
|
//DebugLn(['CheckDeadKey DeadKey=',DeadKey,' str="',im_context_string,'"']);
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
Result := CallBackDefaultReturn;
|
|
|
|
EventStopped := False;
|
|
HandledByLCL := KeyEventWasHandledByLCL(AEvent, ABeforeEvent);
|
|
|
|
{$IFDEF VerboseKeyboard}
|
|
DebugLn(['[HandleGTKKeyUpDown] ',DbgSName(TControl(AData)),
|
|
' ',(AEvent^.{$IFDEF GTK1}theType{$ELSE}_Type{$ENDIF}),' Widget=',GetWidgetClassName(AWidget),
|
|
' Before=',ABeforeEvent,' Down=',AHandleDown,' HandledByLCL=',HandledByLCL]);
|
|
{$ENDIF}
|
|
|
|
// handle every key event only once
|
|
if HandledByLCL then Exit;
|
|
|
|
TargetWidget := AWidget;
|
|
TargetObj := AData;
|
|
FocusedWinControl := nil;
|
|
FocusedWidget := nil;
|
|
|
|
// The gtk sends keys first to the gtkwindow and then to the focused control.
|
|
// The LCL expects only once to the focused control.
|
|
// And some gtk widgets (combo) eats keys, so that the LCL has no chance to
|
|
// handle it. Therefore keys to the form are immediately redirected to the
|
|
// focused control without changing the normal gtk event path.
|
|
if GtkWidgetIsA(AWidget, gtk_window_get_type)
|
|
then begin
|
|
FocusedWidget := PGtkWindow(AWidget)^.focus_widget;
|
|
if FocusedWidget <> nil
|
|
then begin
|
|
LCLObject := GetNearestLCLObject(FocusedWidget);
|
|
if LCLObject is TWinControl
|
|
then begin
|
|
FocusedWinControl := TWinControl(LCLObject);
|
|
if FocusedWidget <> AWidget
|
|
then begin
|
|
{$IFDEF VerboseKeyboard}
|
|
DebugLn('[HandleGTKKeyUpDown] REDIRECTING ',
|
|
' FocusedWidget=',GetWidgetClassName(FocusedWidget),
|
|
' Control=',FocusedWinControl.Name,':',FocusedWinControl.ClassName);
|
|
{$ENDIF}
|
|
// redirect key to lcl control
|
|
TargetWidget := FocusedWidget;
|
|
TargetObj := FocusedWinControl;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
// remember this event
|
|
RememberKeyEventWasHandledByLCL(AEvent, ABeforeEvent);
|
|
|
|
if TargetWidget = nil then Exit;
|
|
|
|
//DebugLn(['HandleGTKKeyUpDown TargetWidget=',GetWidgetDebugReport(TargetWidget)]);
|
|
|
|
|
|
//DebugLn(['HandleGTKKeyUpDown TargetWidget=',GetWidgetDebugReport(TargetWidget),' ',DbgStr(EventString),' state=',AEvent^.state,' keyval=',AEvent^.keyval]);
|
|
FillChar(Msg, SizeOf(Msg), 0);
|
|
|
|
gdk_event_key_get_string(AEvent, EventString);
|
|
//DebugLn(['HandleGTKKeyUpDown TargetWidget=',GetWidgetDebugReport(TargetWidget),' ',DbgStr(EventString),' state=',AEvent^.state,' keyval=',AEvent^.keyval]);
|
|
CheckDeadKey;
|
|
Flags := 0;
|
|
SysKey := False;
|
|
ShiftState := GTKEventStateToShiftState(AEvent^.state);
|
|
{$ifdef gtk1}
|
|
KeyCode := XKeysymToKeycode(gdk_display, AEvent^.keyval);
|
|
{$else}
|
|
KeyCode := AEvent^.hardware_keycode;
|
|
{$endif}
|
|
|
|
if (KeyCode = 0)
|
|
or (KeyCode > High(MKeyCodeInfo))
|
|
or (MKeyCodeInfo[KeyCode].VKey1 = 0)
|
|
then begin
|
|
// no VKey defined, maybe composed char ?
|
|
CommonKeyData := 0;
|
|
end
|
|
else begin
|
|
KCInfo := MKeyCodeInfo[KeyCode];
|
|
|
|
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;
|
|
|
|
if (KCInfo.Flags and KCINFO_FLAG_EXT) <> 0
|
|
then Flags := KF_EXTENDED;
|
|
|
|
|
|
// ssAlt + a key pressed is always a syskey
|
|
// ssAltGr + a key is only a syskey when the key pressed has no levelshift or when ssHift is pressed to0
|
|
SysKey := (ssAlt in ShiftState);
|
|
if not SysKey
|
|
then begin
|
|
// Check ssAltGr
|
|
if (KCInfo.Flags and KCINFO_FLAG_ALTGR) = 0
|
|
then begin
|
|
// VKey has no levelshift char so AltGr is syskey
|
|
SysKey := ssAltGr in ShiftState;
|
|
end
|
|
else begin
|
|
// VKey has levelshift char so AltGr + Shift is syskey
|
|
SysKey := ShiftState * [ssShift, ssAltGr] = [ssShift, ssAltGr]
|
|
end;
|
|
end;
|
|
if SysKey
|
|
then Flags := Flags or KF_ALTDOWN;
|
|
|
|
CommonKeyData := KeyCode shl 16; // Not really scancode, but will do
|
|
|
|
if AHandleDown
|
|
then begin
|
|
{$IFDEF VerboseKeyboard}
|
|
DebugLn('[HandleGTKKeyUpDown] GDK_KEY_PRESS VKey=',dbgs(VKey),' SysKey=',dbgs(SysKey));
|
|
{$ENDIF}
|
|
|
|
Msg.CharCode := VKey;
|
|
Msg.Msg := KEYDOWN_MAP[SysKey, ABeforeEvent];
|
|
|
|
// todo repeat
|
|
// Flags := Flags or KF_REPEAT;
|
|
|
|
Msg.KeyData := CommonKeyData or (Flags shl 16) or $0001 {TODO: repeatcount};
|
|
|
|
if not KeyAlreadyHandledByGtk
|
|
then begin
|
|
// send the (Sys)KeyDown message directly to the LCL
|
|
NotifyApplicationUserInput(TControl(TargetObj), Msg.Msg);
|
|
if DeliverKeyMessage(TargetObj, Msg)
|
|
and (Msg.CharCode <> Vkey) then
|
|
StopKeyEvent;
|
|
end;
|
|
|
|
if (not EventStopped) and ABeforeEvent
|
|
then begin
|
|
if KeyActivatedAccelerator then exit;
|
|
end;
|
|
end
|
|
else begin
|
|
{$IFDEF VerboseKeyboard}
|
|
DebugLn('[HandleGTKKeyUpDown] GDK_KEY_RELEASE VKey=',dbgs(VKey));
|
|
{$ENDIF}
|
|
|
|
Msg.CharCode := VKey;
|
|
Msg.Msg := KEYUP_MAP[SysKey, ABeforeEvent];
|
|
Flags := Flags or KF_UP or KF_REPEAT;
|
|
Msg.KeyData := CommonKeyData or (Flags shl 16) or $0001 {always};
|
|
|
|
// send the message directly to the LCL
|
|
Msg.Result:=0;
|
|
NotifyApplicationUserInput(TControl(TargetObj), Msg.Msg);
|
|
|
|
if DeliverKeyMessage(TargetObj, Msg)
|
|
and (Msg.CharCode <> VKey)
|
|
then begin
|
|
// key was handled by LCL
|
|
StopKeyEvent;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
// send keypresses
|
|
if not EventStopped and AHandleDown then begin
|
|
|
|
// send the UTF8 keypress
|
|
if ABeforeEvent then begin
|
|
// try to get the UTF8 representation of the key
|
|
{$IFDEF GTK1}
|
|
Character := '';
|
|
if (AEvent^.length > 0) and (AEvent^.length <= 8) //max composed UTF8 char has lenght 8
|
|
then begin
|
|
SetLength(Character, AEvent^.length);
|
|
System.Move(AEvent^.thestring^, Character[1], length(Character));
|
|
end;
|
|
{$ELSE GTK2}
|
|
if im_context_string <> '' then
|
|
begin
|
|
Character := UTF8Copy(im_context_string,1,1);
|
|
im_context_string:='';// clear, to avoid sending again
|
|
end
|
|
else
|
|
begin
|
|
KeyPressesChar := GetSpecialChar;
|
|
if KeyPressesChar <> #0 then
|
|
Character := KeyPressesChar
|
|
else
|
|
Character := '';
|
|
end;
|
|
{$ENDIF GTK2}
|
|
|
|
{$IFDEF VerboseKeyboard}
|
|
debugln('[HandleGTKKeyUpDown] GDK_KEY_PRESS UTF8="',DbgStr(Character),'"');
|
|
{$ENDIF}
|
|
|
|
if Character <> ''
|
|
then begin
|
|
LCLObject := GetNearestLCLObject(TargetWidget);
|
|
if LCLObject is TWinControl
|
|
then begin
|
|
// send the key after navigation keys were handled
|
|
Result := TWinControl(LCLObject).IntfUTF8KeyPress(Character, 1, SysKey);
|
|
if Result or (Character = '')
|
|
then StopKeyEvent
|
|
else if (Length(Character) = 1)
|
|
{$IFDEF Gtk1}
|
|
// GTK1 only supports normal ASCII characters (Note: #127 is delete)
|
|
and (Character[1] in [#32..#126])
|
|
{$ENDIF}
|
|
then begin
|
|
CharToKeyVal(Character[1], AEvent^.KeyVal, AEvent^.length);
|
|
if AEvent^.length = 1 then
|
|
begin
|
|
EventString^ := Character[1];
|
|
EventString[1] := #0;
|
|
end
|
|
else
|
|
EventString^ := #0;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
// send a normal KeyPress Event for Delphi compatibility
|
|
if not EventStopped and CanSendChar
|
|
then begin
|
|
{$IFDEF EventTrace}
|
|
EventTrace('char', data);
|
|
{$ENDIF}
|
|
|
|
KeyPressesChar := #0;
|
|
if AEvent^.Length = 1
|
|
then begin
|
|
// ASCII key was pressed
|
|
KeyPressesChar := EventString^;
|
|
end
|
|
else
|
|
KeyPressesChar := GetSpecialChar;
|
|
|
|
if KeyPressesChar <> #0
|
|
then begin
|
|
FillChar(Msg, SizeOf(Msg), 0);
|
|
|
|
Msg.KeyData := CommonKeyData;
|
|
Msg.Msg := CHAR_MAP[SysKey, ABeforeEvent];
|
|
|
|
// send the (Sys)Char message directly (not queued) to the LCL
|
|
Msg.Result:=0;
|
|
Msg.CharCode := Ord(KeyPressesChar);
|
|
if DeliverKeyMessage(TargetObj, Msg)
|
|
and (Ord(KeyPressesChar) <> Msg.CharCode)
|
|
then begin
|
|
// key was changed by lcl
|
|
if (Msg.CharCode=0) or (Msg.CharCode>=128)
|
|
then begin
|
|
// key set to invalid => just stop
|
|
StopKeyEvent;
|
|
end
|
|
else begin
|
|
// try to change the key
|
|
CharToKeyVal(chr(Msg.CharCode), AEvent^.KeyVal, AEvent^.length);
|
|
if AEvent^.length = 1 then
|
|
begin
|
|
EventString^ := Character[1];
|
|
EventString[1] := #0;
|
|
end
|
|
else
|
|
EventString^ := #0;
|
|
gdk_event_key_set_string(AEvent, EventString);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
EmulateEatenKeys;
|
|
|
|
{$IFDEF Gtk1}
|
|
Result:=true;
|
|
{$ELSE}
|
|
Result:=EventStopped;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Procedure: InitKeyboardTables
|
|
Params: none
|
|
Returns: none
|
|
|
|
Initializes the CharToVK and CKeyToVK tables
|
|
------------------------------------------------------------------------------}
|
|
procedure InitKeyboardTables;
|
|
|
|
procedure FindVKeyInfo(const AKeySym: Cardinal; var AVKey: Byte;
|
|
var AExtended, AHasMultiVK, ASecondKey: Boolean);
|
|
var
|
|
ByteKey: Byte;
|
|
begin
|
|
AExtended := False;
|
|
AHasMultiVK := False;
|
|
AVKey := VK_UNDEFINED;
|
|
ASecondKey := False;
|
|
|
|
case AKeySym of
|
|
32..255: begin
|
|
ByteKey:=Byte(AKeySym);
|
|
case Chr(ByteKey) of // Normal ASCII chars
|
|
//only unshifted values are checked
|
|
//'A'..'Z',
|
|
'0'..'9',
|
|
' ': AVKey := ByteKey;
|
|
'a'..'z': AVKey := ByteKey - Ord('a') + Ord('A');
|
|
'+': AVKey := VK_OEM_PLUS;
|
|
',': AVKey := VK_OEM_COMMA;
|
|
'-': AVKey := VK_OEM_MINUS;
|
|
'.': AVKey := VK_OEM_PERIOD;
|
|
|
|
// try the US keycodes first
|
|
';': AVKey := VK_OEM_1;
|
|
'/': AVKey := VK_OEM_2;
|
|
'`': AVKey := VK_OEM_3;
|
|
'[': AVKey := VK_OEM_4;
|
|
'\': AVKey := VK_OEM_5;
|
|
']': AVKey := VK_OEM_6;
|
|
'''': AVKey := VK_OEM_7;
|
|
end;
|
|
end;
|
|
|
|
GDK_KEY_Tab,
|
|
GDK_KEY_ISO_Left_Tab: AVKey := VK_TAB;
|
|
GDK_KEY_RETURN: AVKey := VK_RETURN;
|
|
// GDK_KEY_LINEFEED; AVKey := $0A;
|
|
|
|
// Cursor block / keypad
|
|
GDK_KEY_INSERT:
|
|
begin
|
|
AExtended := True;
|
|
AVKey := VK_INSERT;
|
|
end;
|
|
GDK_KEY_DELETE:
|
|
begin
|
|
AExtended := True;
|
|
AVKey := VK_DELETE;
|
|
end;
|
|
GDK_KEY_HOME:
|
|
begin
|
|
AExtended := True;
|
|
AVKey := VK_HOME;
|
|
end;
|
|
GDK_KEY_LEFT:
|
|
begin
|
|
AExtended := True;
|
|
AVKey := VK_LEFT;
|
|
end;
|
|
GDK_KEY_UP:
|
|
begin
|
|
AExtended := True;
|
|
AVKey := VK_UP;
|
|
end;
|
|
GDK_KEY_RIGHT:
|
|
begin
|
|
AExtended := True;
|
|
AVKey := VK_RIGHT;
|
|
end;
|
|
GDK_KEY_DOWN:
|
|
begin
|
|
AExtended := True;
|
|
AVKey := VK_DOWN;
|
|
end;
|
|
GDK_KEY_PAGE_UP:
|
|
begin
|
|
AExtended := True;
|
|
AVKey := VK_PRIOR;
|
|
end;
|
|
GDK_KEY_PAGE_DOWN:
|
|
begin
|
|
AExtended := True;
|
|
AVKey := VK_NEXT;
|
|
end;
|
|
GDK_KEY_END:
|
|
begin
|
|
AExtended := True;
|
|
AVKey := VK_END;
|
|
end;
|
|
|
|
// Keypad
|
|
GDK_KEY_KP_ENTER:
|
|
begin
|
|
AExtended := True;
|
|
AVKey := VK_Return;
|
|
end;
|
|
GDK_KEY_KP_Space, GDK_KEY_KP_Begin:
|
|
begin
|
|
AVKey := VK_CLEAR;
|
|
AHasMultiVK := True;
|
|
end;
|
|
GDK_KEY_KP_INSERT:
|
|
begin
|
|
// Keypad key is not extended
|
|
AVKey := VK_INSERT;
|
|
AHasMultiVK := True;
|
|
end;
|
|
GDK_KEY_KP_HOME:
|
|
begin
|
|
// Keypad key is not extended
|
|
AVKey := VK_HOME;
|
|
AHasMultiVK := True;
|
|
end;
|
|
GDK_KEY_KP_LEFT:
|
|
begin
|
|
// Keypad key is not extended
|
|
AVKey := VK_LEFT;
|
|
AHasMultiVK := True;
|
|
end;
|
|
GDK_KEY_KP_UP:
|
|
begin
|
|
// Keypad key is not extended
|
|
AVKey := VK_UP;
|
|
AHasMultiVK := True;
|
|
end;
|
|
GDK_KEY_KP_RIGHT:
|
|
begin
|
|
// Keypad key is not extended
|
|
AVKey := VK_RIGHT;
|
|
AHasMultiVK := True;
|
|
end;
|
|
GDK_KEY_KP_DOWN:
|
|
begin
|
|
// Keypad key is not extended
|
|
AVKey := VK_DOWN;
|
|
AHasMultiVK := True;
|
|
end;
|
|
GDK_KEY_KP_PAGE_UP:
|
|
begin
|
|
// Keypad key is not extended
|
|
AVKey := VK_PRIOR;
|
|
AHasMultiVK := True;
|
|
end;
|
|
GDK_KEY_KP_PAGE_DOWN:
|
|
begin
|
|
// Keypad key is not extended
|
|
AVKey := VK_NEXT;
|
|
AHasMultiVK := True;
|
|
end;
|
|
GDK_KEY_KP_END:
|
|
begin
|
|
// Keypad key is not extended
|
|
AVKey := VK_END;
|
|
AHasMultiVK := True;
|
|
end;
|
|
GDK_KEY_Num_Lock:
|
|
begin
|
|
AExtended := True;
|
|
AVKey := VK_NUMLOCK;
|
|
end;
|
|
GDK_KEY_KP_F1..GDK_KEY_KP_F4:
|
|
begin
|
|
// not on "normal" keyboard so defined extended to differentiate between normal Fn
|
|
AExtended := True;
|
|
AVKey := VK_F1 + AKeySym - GDK_KEY_KP_F1;
|
|
end;
|
|
GDK_KEY_KP_TAB:
|
|
begin
|
|
// not on "normal" keyboard so defined extended to differentiate between normal TAB
|
|
AExtended := True;
|
|
AVKey := VK_TAB;
|
|
end;
|
|
GDK_KEY_KP_Multiply:
|
|
begin
|
|
AVKey := VK_MULTIPLY;
|
|
end;
|
|
GDK_KEY_KP_Add:
|
|
begin
|
|
AVKey := VK_ADD;
|
|
end;
|
|
GDK_KEY_KP_Separator:
|
|
begin
|
|
// Keypad key is not extended
|
|
AVKey := VK_SEPARATOR;
|
|
AHasMultiVK := True;
|
|
end;
|
|
GDK_KEY_KP_Subtract:
|
|
begin
|
|
AVKey := VK_SUBTRACT;
|
|
end;
|
|
GDK_KEY_KP_Decimal:
|
|
begin
|
|
// Keypad key is not extended
|
|
AVKey := VK_DECIMAL;
|
|
AHasMultiVK := True;
|
|
end;
|
|
GDK_KEY_KP_Delete:
|
|
begin
|
|
// Keypad key is not extended
|
|
AVKey := VK_DELETE;
|
|
AHasMultiVK := True;
|
|
end;
|
|
GDK_KEY_KP_Divide:
|
|
begin
|
|
AExtended := True;
|
|
AVKey := VK_DIVIDE;
|
|
end;
|
|
GDK_KEY_KP_0..GDK_KEY_KP_9:
|
|
begin
|
|
// Keypad key is not extended, it is identified by VK
|
|
AVKey := VK_NUMPAD0 + AKeySym - GDK_KEY_KP_0;
|
|
AHasMultiVK := True;
|
|
end;
|
|
|
|
GDK_KEY_BackSpace: AVKey := VK_BACK;
|
|
GDK_KEY_Clear: AVKey := VK_CLEAR;
|
|
GDK_KEY_Pause: AVKey := VK_PAUSE;
|
|
GDK_KEY_Scroll_Lock: AVKey := VK_SCROLL;
|
|
GDK_KEY_Sys_Req: AVKey := VK_SNAPSHOT;
|
|
GDK_KEY_Escape: AVKey := VK_ESCAPE;
|
|
|
|
GDK_KEY_Kanji: AVKey := VK_KANJI;
|
|
|
|
GDK_Key_Select: AVKey := VK_SELECT;
|
|
GDK_Key_Print: AVKey := VK_PRINT;
|
|
GDK_Key_Execute: AVKey := VK_EXECUTE;
|
|
GDK_Key_Cancel: AVKey := VK_CANCEL;
|
|
GDK_Key_Help: AVKey := VK_HELP;
|
|
GDK_Key_Break: AVKey := VK_CANCEL;
|
|
GDK_Key_Mode_switch: AVKey := VK_MODECHANGE;
|
|
GDK_Key_Caps_Lock: AVKey := VK_CAPITAL;
|
|
GDK_Key_Shift_L: AVKey := VK_SHIFT;
|
|
GDK_Key_Shift_R:
|
|
begin
|
|
AVKey := VK_SHIFT;
|
|
ASecondKey := True;
|
|
end;
|
|
GDK_Key_Control_L: AVKey := VK_CONTROL;
|
|
GDK_Key_Control_R:
|
|
begin
|
|
AVKey := VK_CONTROL;
|
|
ASecondKey := True;
|
|
end;
|
|
// GDK_Key_Meta_L: AVKey := VK_MENU; //shifted alt, so it is found by alt
|
|
// GDK_Key_Meta_R: AVKey := VK_MENU;
|
|
GDK_Key_Alt_L: AVKey := VK_MENU;
|
|
GDK_Key_Alt_R:
|
|
begin
|
|
AVKey := VK_MENU;
|
|
ASecondKey := True;
|
|
end;
|
|
GDK_Key_Super_L: AVKey := VK_LWIN;
|
|
GDK_Key_Super_R: begin
|
|
AVKey := VK_RWIN;
|
|
ASecondKey := True;
|
|
end;
|
|
GDK_Key_Menu: AVKey := VK_APPS;
|
|
|
|
// function keys
|
|
GDK_KEY_F1..GDK_KEY_F24: AVKey := VK_F1 + AKeySym - GDK_Key_F1;
|
|
|
|
// Extra keys on a "internet" keyboard
|
|
GDKX_KEY_Sleep:
|
|
begin
|
|
AExtended := True;
|
|
AVKey := VK_SLEEP;
|
|
end;
|
|
GDKX_KEY_AudioLowerVolume:
|
|
begin
|
|
AExtended := True;
|
|
AVKey := VK_VOLUME_DOWN;
|
|
end;
|
|
GDKX_KEY_AudioMute:
|
|
begin
|
|
AExtended := True;
|
|
AVKey := VK_VOLUME_MUTE;
|
|
end;
|
|
GDKX_KEY_AudioRaiseVolume:
|
|
begin
|
|
AExtended := True;
|
|
AVKey := VK_VOLUME_UP;
|
|
end;
|
|
GDKX_KEY_AudioPlay:
|
|
begin
|
|
AExtended := True;
|
|
AVKey := VK_MEDIA_PLAY_PAUSE;
|
|
end;
|
|
GDKX_KEY_AudioStop:
|
|
begin
|
|
AExtended := True;
|
|
AVKey := VK_MEDIA_STOP;
|
|
end;
|
|
GDKX_KEY_AudioPrev:
|
|
begin
|
|
AExtended := True;
|
|
AVKey := VK_MEDIA_PREV_TRACK;
|
|
end;
|
|
GDKX_KEY_AudioNext:
|
|
begin
|
|
AExtended := True;
|
|
AVKey := VK_MEDIA_NEXT_TRACK;
|
|
end;
|
|
GDKX_KEY_Mail:
|
|
begin
|
|
AExtended := True;
|
|
AVKey := VK_LAUNCH_MAIL;
|
|
end;
|
|
GDKX_KEY_HomePage:
|
|
begin
|
|
AExtended := True;
|
|
AVKey := VK_BROWSER_HOME;
|
|
end;
|
|
GDKX_KEY_Back:
|
|
begin
|
|
AExtended := True;
|
|
AVKey := VK_BROWSER_BACK;
|
|
end;
|
|
GDKX_KEY_Forward:
|
|
begin
|
|
AExtended := True;
|
|
AVKey := VK_BROWSER_FORWARD;
|
|
end;
|
|
GDKX_KEY_Stop:
|
|
begin
|
|
AExtended := True;
|
|
AVKey := VK_BROWSER_STOP;
|
|
end;
|
|
GDKX_KEY_Refresh:
|
|
begin
|
|
AExtended := True;
|
|
AVKey := VK_BROWSER_REFRESH;
|
|
end;
|
|
GDKX_KEY_WWW:
|
|
begin
|
|
AExtended := True;
|
|
AVKey := VK_BROWSER_HOME;
|
|
end;
|
|
GDKX_KEY_Favorites:
|
|
begin
|
|
AExtended := True;
|
|
AVKey := VK_BROWSER_FAVORITES;
|
|
end;
|
|
GDKX_KEY_AudioMedia:
|
|
begin
|
|
AExtended := True;
|
|
AVKey := VK_LAUNCH_MEDIA_SELECT;
|
|
end;
|
|
GDKX_KEY_MyComputer:
|
|
begin
|
|
AExtended := True;
|
|
AVKey := VK_LAUNCH_APP1;
|
|
end;
|
|
GDKX_KEY_Calculator:
|
|
begin
|
|
AExtended := True;
|
|
AVKey := VK_LAUNCH_APP2;
|
|
end;
|
|
|
|
// For faster cases, group by families
|
|
$400..$4FF: begin
|
|
// Katakana
|
|
end;
|
|
|
|
$500..$5FF: begin
|
|
// Arabic
|
|
case AKeySym of
|
|
GDK_KEY_arabic_hamza: AVKey := VK_X;
|
|
GDK_KEY_arabic_hamzaonwaw: AVKey := VK_C;
|
|
GDK_KEY_arabic_hamzaonyeh: AVKey := VK_Z;
|
|
GDK_KEY_arabic_alef: AVKey := VK_H;
|
|
GDK_KEY_arabic_beh: AVKey := VK_F;
|
|
GDK_KEY_arabic_tehmarbuta: AVKey := VK_M;
|
|
GDK_KEY_arabic_teh: AVKey := VK_J;
|
|
GDK_KEY_arabic_theh: AVKey := VK_E;
|
|
GDK_KEY_arabic_jeem: AVKey := VK_OEM_4;
|
|
GDK_KEY_arabic_hah: AVKey := VK_P;
|
|
GDK_KEY_arabic_khah: AVKey := VK_O;
|
|
GDK_KEY_arabic_dal: AVKey := VK_OEM_6;
|
|
GDK_KEY_arabic_thal: AVKey := VK_OEM_3;
|
|
GDK_KEY_arabic_ra: AVKey := VK_V;
|
|
GDK_KEY_arabic_zain: AVKey := VK_OEM_PERIOD;
|
|
GDK_KEY_arabic_seen: AVKey := VK_S;
|
|
GDK_KEY_arabic_sheen: AVKey := VK_A;
|
|
GDK_KEY_arabic_sad: AVKey := VK_W;
|
|
GDK_KEY_arabic_dad: AVKey := VK_Q;
|
|
GDK_KEY_arabic_tah: AVKey := VK_OEM_7;
|
|
GDK_KEY_arabic_zah: AVKey := VK_OEM_2;
|
|
GDK_KEY_arabic_ain: AVKey := VK_U;
|
|
GDK_KEY_arabic_ghain: AVKey := VK_Y;
|
|
GDK_KEY_arabic_feh: AVKey := VK_T;
|
|
GDK_KEY_arabic_qaf: AVKey := VK_R;
|
|
GDK_KEY_arabic_kaf: AVKey := VK_OEM_1;
|
|
GDK_KEY_arabic_lam: AVKey := VK_G;
|
|
GDK_KEY_arabic_meem: AVKey := VK_L;
|
|
GDK_KEY_arabic_noon: AVKey := VK_K;
|
|
GDK_KEY_arabic_heh: AVKey := VK_I;
|
|
GDK_KEY_arabic_waw: AVKey := VK_OEM_COMMA;
|
|
GDK_KEY_arabic_alefmaksura: AVKey := VK_N;
|
|
GDK_KEY_arabic_yeh: AVKey := VK_D;
|
|
end;
|
|
end;
|
|
|
|
$600..$6FF: begin
|
|
// Cyrillic
|
|
|
|
// MWE:
|
|
// These VK codes are not compatible with all cyrillic KBlayouts
|
|
// Example:
|
|
// VK_A on a russian layout generates a cyrillic_EF
|
|
// VK_A on a serbian layout generates a cyrillic_A
|
|
//
|
|
// Mapping cyrillic_A to VK_A is easier so that encoding is used.
|
|
// Maybe in future we can take the KBLayout into account
|
|
case AKeySym of
|
|
GDK_KEY_cyrillic_a..GDK_KEY_cyrillic_ze:
|
|
begin
|
|
AVKey := VK_A + AKeySym - GDK_KEY_cyrillic_a;
|
|
end;
|
|
// Capital is not needed, the lower will match
|
|
//GDK_KEY_cyrillic_A..GDK_KEY_cyrillic_ZE:
|
|
//begin
|
|
// AVKey := VK_A + AKeySym - GDK_KEY_cyrillic_A;
|
|
//end;
|
|
end;
|
|
end;
|
|
|
|
$700..$7FF: begin
|
|
// Greek
|
|
case AKeySym of
|
|
// Capital is not needed, the lower will match
|
|
GDK_KEY_greek_alpha: AVKey := VK_A;
|
|
GDK_KEY_greek_beta: AVKey := VK_B;
|
|
GDK_KEY_greek_gamma: AVKey := VK_G;
|
|
GDK_KEY_greek_delta: AVKey := VK_D;
|
|
GDK_KEY_greek_epsilon: AVKey := VK_E;
|
|
GDK_KEY_greek_zeta: AVKey := VK_Z;
|
|
GDK_KEY_greek_eta: AVKey := VK_H;
|
|
GDK_KEY_greek_theta: AVKey := VK_U;
|
|
GDK_KEY_greek_iota: AVKey := VK_I;
|
|
GDK_KEY_greek_kappa: AVKey := VK_K;
|
|
GDK_KEY_greek_lamda: AVKey := VK_L;
|
|
GDK_KEY_greek_mu: AVKey := VK_M;
|
|
GDK_KEY_greek_nu: AVKey := VK_N;
|
|
GDK_KEY_greek_xi: AVKey := VK_J;
|
|
GDK_KEY_greek_omicron: AVKey := VK_O;
|
|
GDK_KEY_greek_pi: AVKey := VK_P;
|
|
GDK_KEY_greek_rho: AVKey := VK_R;
|
|
GDK_KEY_greek_sigma: AVKey := VK_S;
|
|
GDK_KEY_greek_finalsmallsigma: AVKey := VK_W;
|
|
GDK_KEY_greek_tau: AVKey := VK_T;
|
|
GDK_KEY_greek_upsilon: AVKey := VK_Y;
|
|
GDK_KEY_greek_phi: AVKey := VK_F;
|
|
GDK_KEY_greek_chi: AVKey := VK_X;
|
|
GDK_KEY_greek_psi: AVKey := VK_C;
|
|
GDK_KEY_greek_omega: AVKey := VK_V;
|
|
end;
|
|
end;
|
|
|
|
$C00..$CFF: begin
|
|
// Hebrew
|
|
// Shifted keys will produce A..Z so the VK codes will be assigned there
|
|
end;
|
|
|
|
$D00..$DFF: begin
|
|
// Thai
|
|
// To many differences to assign VK codes through lookup
|
|
// Thai Kedmanee and Thai Pattachote are complete different layouts
|
|
end;
|
|
|
|
$E00..$EFF: begin
|
|
// Korean
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function IgnoreShifted(const AUnshiftKeySym: Cardinal): Boolean;
|
|
begin
|
|
case AUnshiftKeySym of
|
|
GDK_KEY_END,
|
|
GDK_KEY_HOME,
|
|
GDK_KEY_LEFT,
|
|
GDK_KEY_RIGHT,
|
|
GDK_KEY_UP,
|
|
GDK_KEY_DOWN,
|
|
GDK_KEY_PAGE_UP,
|
|
GDK_KEY_PAGE_DOWN: Result := True;
|
|
else
|
|
Result := False;
|
|
end;
|
|
end;
|
|
|
|
procedure NextFreeVK(var AFreeVK: Byte);
|
|
begin
|
|
case AFreeVK of
|
|
$96: AFreeVK := $E1;
|
|
$E1: AFreeVK := $E3;
|
|
$E4: AFreeVK := $E6;
|
|
$E6: AFreeVK := $E9;
|
|
$F5: begin
|
|
{$ifndef HideKeyTableWarnings}
|
|
DebugLn('[WARNING] Out of OEM specific VK codes, changing to unassigned');
|
|
{$endif}
|
|
AFreeVK := $88;
|
|
end;
|
|
$8F: AFreeVK := $97;
|
|
$9F: AFreeVK := $D8;
|
|
$DA: AFreeVK := $E5;
|
|
$E5: AFreeVK := $E8;
|
|
$E8: begin
|
|
{$ifndef HideKeyTableWarnings}
|
|
DebugLn('[WARNING] Out of unassigned VK codes, assigning $FF');
|
|
{$endif}
|
|
AFreeVK := $FF;
|
|
end;
|
|
$FF: AFreeVK := $FF; // stay there
|
|
else
|
|
Inc(AFreeVK);
|
|
end;
|
|
end;
|
|
|
|
|
|
const
|
|
KEYFLAGS: array[0..3] of Byte = (
|
|
$00,
|
|
KCINFO_FLAG_SHIFT,
|
|
KCINFO_FLAG_ALTGR,
|
|
KCINFO_FLAG_ALTGR or KCINFO_FLAG_SHIFT
|
|
);
|
|
EXTFLAG: array[Boolean] of Byte = (
|
|
$00,
|
|
KCINFO_FLAG_EXT
|
|
);
|
|
MULTIFLAG: array[Boolean] of Byte = (
|
|
$00,
|
|
KCINFO_FLAG_SHIFT_XOR_NUM
|
|
);
|
|
|
|
{$ifdef HasX}
|
|
{
|
|
Starting gdk 2.10 Alt, meta, hyper are reported by a own mask. Since we support
|
|
older versions, we need to create the modifiermap ourselves for X and we cannot
|
|
ise them
|
|
}
|
|
type
|
|
TModMap = array[Byte] of Cardinal;
|
|
|
|
procedure SetupModifiers(ADisplay: Pointer; var AModMap: TModMap);
|
|
const
|
|
MODIFIERS: array[0..7] of Cardinal = (
|
|
GDK_SHIFT_MASK,
|
|
GDK_LOCK_MASK,
|
|
GDK_CONTROL_MASK,
|
|
GDK_MOD1_MASK,
|
|
GDK_MOD2_MASK,
|
|
GDK_MOD3_MASK,
|
|
GDK_MOD4_MASK,
|
|
GDK_MOD5_MASK
|
|
);
|
|
var
|
|
Map: PXModifierKeymap;
|
|
KeyCode: PKeyCode;
|
|
Modifier, n: Integer;
|
|
begin
|
|
FillByte(AModMap, SizeOf(AModMap), 0);
|
|
|
|
Map := XGetModifierMapping(ADisplay);
|
|
KeyCode := Map^.modifiermap;
|
|
|
|
for Modifier := Low(MODIFIERS) to High(MODIFIERS) do
|
|
begin
|
|
for n := 1 to Map^.max_keypermod do
|
|
begin
|
|
if KeyCode^ <> 0
|
|
then begin
|
|
AModMap[KeyCode^] := MODIFIERS[Modifier];
|
|
{$ifdef VerboseModifiermap}
|
|
DebugLn('Mapped keycode=%u to modifier=$%2.2x', [KeyCode^, MODIFIERS[Modifier]]);
|
|
{$endif}
|
|
end;
|
|
Inc(KeyCode);
|
|
end;
|
|
end;
|
|
|
|
XFreeModifiermap(Map);
|
|
end;
|
|
|
|
procedure UpdateModifierMap(const AModMap: TModMap; AKeyCode: Byte; AKeySym: Cardinal);
|
|
var
|
|
{$ifdef VerboseModifiermap}
|
|
s: string;
|
|
{$endif}
|
|
ShiftState: TShiftStateEnum;
|
|
begin
|
|
if AModMap[AKeyCode] = 0 then Exit;
|
|
|
|
case AKeySym of
|
|
GDK_KEY_Caps_Lock,
|
|
GDK_KEY_Shift_Lock: ShiftState := ssCaps;
|
|
GDK_KEY_Num_Lock: ShiftState := ssNum;
|
|
GDK_KEY_Scroll_Lock: ShiftState := ssScroll;
|
|
GDK_Key_Shift_L,
|
|
GDK_Key_Shift_R: ShiftState := ssShift;
|
|
GDK_KEY_Control_L,
|
|
GDK_KEY_Control_R: ShiftState := ssCtrl;
|
|
{$ifndef UseOwnShiftState}
|
|
// UseOwnShiftState will track these, so we don't have to put them in the modmap
|
|
GDK_KEY_Meta_L,
|
|
GDK_KEY_Meta_R: ShiftState := ssMeta;
|
|
GDK_KEY_Alt_L,
|
|
GDK_KEY_Alt_R: ShiftState := ssAlt;
|
|
GDK_KEY_Super_L,
|
|
GDK_KEY_Super_R: ShiftState := ssSuper;
|
|
GDK_KEY_Hyper_L,
|
|
GDK_KEY_Hyper_R: ShiftState := ssHyper;
|
|
GDK_KEY_ISO_Level3_Shift{,
|
|
GDK_KEY_Mode_switch}: ShiftState := ssAltGr;
|
|
{$endif}
|
|
else
|
|
Exit;
|
|
end;
|
|
|
|
MModifiers[ShiftState].Mask := AModMap[AKeyCode];
|
|
MModifiers[ShiftState].UseValue := False;
|
|
|
|
{$ifdef VerboseModifiermap}
|
|
WriteStr(s, ShiftState);
|
|
DebugLn('Mapped keycode=%u, keysym=$%x, modifier=$%2.2x to shiftstate %s',
|
|
[AKeyCode, AKeySym, AModMap[AKeyCode], s]);
|
|
{$endif}
|
|
|
|
end;
|
|
|
|
{$ifdef UseOwnShiftState}
|
|
procedure UpdateKeyStateMap(var AIndex: integer; AKeyCode: Byte; AKeySym: Cardinal);
|
|
var
|
|
Enum: TShiftStateEnum;
|
|
begin
|
|
case AKeySym of
|
|
GDK_KEY_Alt_L, GDK_KEY_Alt_R: Enum := ssAlt;
|
|
GDK_KEY_Meta_L, GDK_KEY_Meta_R: Enum := ssMeta;
|
|
GDK_KEY_Super_L, GDK_KEY_Super_R: Enum := ssSuper;
|
|
GDK_KEY_Hyper_L, GDK_KEY_Hyper_R: Enum := ssHyper;
|
|
GDK_KEY_ISO_Level3_Shift: Enum := ssAltGr;
|
|
else
|
|
Exit;
|
|
end;
|
|
|
|
if High(MKeyStateMap) < AIndex
|
|
then SetLength(MKeyStateMap, AIndex + 8);
|
|
|
|
MKeyStateMap[AIndex].Index := AKeyCode shr 3;
|
|
MKeyStateMap[AIndex].Mask := 1 shl (AKeyCode and 7);
|
|
MKeyStateMap[AIndex].Enum := Enum;
|
|
Inc(AIndex)
|
|
end;
|
|
{$endif UseOwnShiftState}
|
|
|
|
{$endif HasX}
|
|
|
|
const
|
|
// first OEM specific VK
|
|
VK_FIRST_OEM = $92;
|
|
|
|
var
|
|
{$ifdef gtk1}
|
|
XKeyEvent: TXKeyEvent;
|
|
KeySymStart, KeySymNext: PKeySym;
|
|
UpKeySym, LoKeySym: TKeySym;
|
|
KeySyms: array of TKeySym = nil;
|
|
{$else}
|
|
KeySyms: array of guint;
|
|
KeyVals: Pguint;
|
|
KeymapKeys: PGdkKeymapKey;
|
|
UniChar: gunichar;
|
|
{$endif}
|
|
KeySymCount: Integer;
|
|
KeySymChars: array[0..16] of Char;
|
|
KeySymCharLen: Integer;
|
|
|
|
{$ifdef HasX}
|
|
XDisplay: Pointer;
|
|
ModMap: TModMap;
|
|
{$endif}
|
|
{$ifdef UseOwnShiftState}
|
|
KeyStateMapIndex: Integer;
|
|
{$endif}
|
|
|
|
KeyCode: Byte;
|
|
m: Integer;
|
|
LoKey, HiKey, I: Integer;
|
|
|
|
VKey, FreeVK: Byte;
|
|
HasMultiVK, DummyBool, Extended, SecondKey, HasKey, ComputeVK: Boolean;
|
|
begin
|
|
{$ifdef HasX}
|
|
XDisplay := gdk_display;
|
|
if XDisplay = nil then Exit;
|
|
|
|
FillByte(MKeyStateMap, SizeOF(MKeyStateMap), 0);
|
|
SetupModifiers(XDisplay, ModMap);
|
|
{$endif}
|
|
|
|
{$ifdef gtk1}
|
|
// Init dummy XEvent to retrieve the char corresponding to a key
|
|
FillChar(XKeyEvent, SizeOf(XKeyEvent), 0);
|
|
XKeyEvent._Type := GDK_KEY_PRESS;
|
|
XKeyEvent.Display := XDisplay;
|
|
XKeyEvent.Same_Screen := 1;
|
|
|
|
// Retrieve the KeyCode bounds
|
|
XDisplayKeyCodes(XDisplay, @LoKey, @HiKey);
|
|
if LoKey < 0
|
|
then begin
|
|
DebugLn('[WARNING] Low keycode (%d) negative, adjusting to 0', [LoKey]);
|
|
LoKey := 0;
|
|
end;
|
|
if HiKey > 255
|
|
then begin
|
|
DebugLn('[WARNING] High keycode (%d) larget than 255, adjusting to 255', [HiKey]);
|
|
HiKey := 255;
|
|
end;
|
|
|
|
KeySymCount := 0;
|
|
KeySymStart := XGetKeyboardMapping(XDisplay, LoKey, HiKey - LoKey + 1, @KeySymCount);
|
|
KeySymNext := KeySymStart;
|
|
|
|
if (KeySymCount = 0) or (KeySymStart = nil)
|
|
then begin
|
|
DebugLn('[WARNING] failed to retrieve keyboardmapping');
|
|
if KeySymStart <> nil
|
|
then XFree(KeySymStart);
|
|
Exit;
|
|
end;
|
|
// The code in Accelerate below assumes at least 2 items in the KeySym array
|
|
if KeySymCount > 2 then begin
|
|
for I:=Low(MVKeyInfo) to High(MVKeyInfo) do
|
|
SetLength(MVKeyInfo[I].KeySym, KeySymCount);
|
|
end else begin
|
|
for I:=Low(MVKeyInfo) to High(MVKeyInfo) do
|
|
SetLength(MVKeyInfo[I].KeySym, 2);
|
|
end;
|
|
SetLength(KeySyms, KeySymCount);
|
|
{$else gtk1}
|
|
LoKey := 0;
|
|
HiKey := 255;
|
|
{$endif}
|
|
|
|
{$ifdef UseOwnShiftState}
|
|
KeyStateMapIndex := 0;
|
|
{$endif}
|
|
FreeVK := VK_FIRST_OEM;
|
|
for KeyCode := LoKey to HiKey do
|
|
begin
|
|
{$ifdef gtk1}
|
|
Move(KeySymNext^, KeySyms[0], SizeOf(KeySyms[0]) * KeySymCount);
|
|
Inc(KeySymNext, KeySymCount);
|
|
|
|
HasKey := False;
|
|
m := 0;
|
|
while m < KeySymCount do
|
|
begin
|
|
// there might be only uppercase chars are in the map,
|
|
// so we have to add the lowercase ourselves
|
|
// when a group consists of one char(next =0)
|
|
if KeySyms[m] <> 0
|
|
then begin
|
|
HasKey := True;
|
|
if KeySyms[m+1] = 0
|
|
then begin
|
|
XConvertCase(KeySyms[m], @LoKeySym, @UpKeySym);
|
|
if LoKeySym <> UpKeySym
|
|
then begin
|
|
KeySyms[m] := LoKeySym;
|
|
KeySyms[m+1] := UpKeySym;
|
|
end;
|
|
end;
|
|
end;
|
|
Inc(m, 2);
|
|
end;
|
|
|
|
{$else}
|
|
if not gdk_keymap_get_entries_for_keycode(nil, KeyCode, KeymapKeys, KeyVals, @KeySymCount) then Continue;
|
|
SetLength(KeySyms, KeySymCount);
|
|
Move(KeyVals^, KeySyms[0], SizeOf(KeySyms[0]) * KeySymCount);
|
|
g_free(KeymapKeys); // unused but we cannot pass a nil as param
|
|
g_free(KeyVals);
|
|
HasKey := KeySyms[0] <> 0;
|
|
//DebugLn(['InitKeyboardTables ',KeyCode,' ',HasKey,' ',KeySyms[0]]);
|
|
{$endif}
|
|
|
|
{$ifdef HasX}
|
|
// Check if this keycode is in the modifiers map
|
|
// loop through all keysyms till one found.
|
|
// Some maps have a modifier with an undefined first keysym. It is checked for
|
|
// modifiers, but not for vkeys
|
|
for m := 0 to KeySymCount - 1 do
|
|
begin
|
|
if KeySyms[m] = 0 then Continue;
|
|
UpdateModifierMap(ModMap, KeyCode, KeySyms[m]);
|
|
{$ifdef UseOwnShiftState}
|
|
UpdateKeyStateMap(KeyStateMapIndex, KeyCode, KeySyms[m]);
|
|
{$endif}
|
|
Break;
|
|
end;
|
|
{$endif}
|
|
|
|
// Continue if there is no keysym found
|
|
if not HasKey then Continue;
|
|
|
|
// Start looking for a VKcode
|
|
VKey := VK_UNDEFINED;
|
|
for m := 0 to KeySymCount - 1 do
|
|
begin
|
|
if KeySyms[m] = 0 then Continue;
|
|
FindVKeyInfo(KeySyms[m], VKey, Extended, HasMultiVK, SecondKey);
|
|
{$ifdef Windows}
|
|
// on windows, the keycode is perdef the VK,
|
|
// we only enter this loop to set the correct flags
|
|
VKey := KeyCode;
|
|
Break;
|
|
{$else}
|
|
if HasMultiVK then Break; // has VK per def
|
|
if VKey = VK_UNDEFINED then Continue;
|
|
if MVKeyInfo[VKey].KeyCode[SecondKey or Extended] = 0 then Break; // found unused VK
|
|
|
|
// already in use
|
|
VKey := VK_UNDEFINED;
|
|
{$endif}
|
|
end;
|
|
|
|
ComputeVK := VKey = VK_UNDEFINED;
|
|
if ComputeVK and not HasMultiVK
|
|
then begin
|
|
VKey := FreeVK;
|
|
NextFreeVK(FreeVK);
|
|
end;
|
|
|
|
if VKey = VK_UNDEFINED
|
|
then begin
|
|
MKeyCodeInfo[KeyCode].Flags := $FF
|
|
end
|
|
else begin
|
|
MKeyCodeInfo[KeyCode].Flags := EXTFLAG[Extended] or MULTIFLAG[HasMultiVK];
|
|
MVKeyInfo[VKey].KeyCode[SecondKey] := KeyCode;
|
|
end;
|
|
MKeyCodeInfo[KeyCode].VKey1 := VKey;
|
|
|
|
for m := 0 to Min(High(MVKeyInfo[0].KeyChar), KeySymCount - 1) do
|
|
begin
|
|
if KeySyms[m] = 0 then Continue;
|
|
if (m >= 2) and (KeySyms[m] = KeySyms[m - 2]) then Continue;
|
|
|
|
if HasMultiVK
|
|
then begin
|
|
if m >= 2 then Break; // Only process shift
|
|
|
|
// The keypadkeys have 2 VK_keycodes :(
|
|
// In that case we have to FIndKeyInfo for every keysym
|
|
if m = 1
|
|
then begin
|
|
FindVKeyInfo(KeySyms[m], VKey, Extended, DummyBool, DummyBool);
|
|
MKeyCodeInfo[KeyCode].VKey2 := VKey;
|
|
end;
|
|
end;
|
|
if VKey = VK_UNDEFINED then Continue;
|
|
|
|
MKeyCodeInfo[KeyCode].Flags := MKeyCodeInfo[KeyCode].Flags or KEYFLAGS[m];
|
|
|
|
FillByte(KeySymChars, SizeOf(KeySymChars), 0);
|
|
{$ifdef gtk1}
|
|
// Retrieve the chars for this KeySym
|
|
XKeyEvent.KeyCode := KeyCode;
|
|
case m of
|
|
0: XKeyEvent.State := 0;
|
|
1: XKeyEvent.State := MModifiers[ssShift].Mask;
|
|
2: XKeyEvent.State := MModifiers[ssAltGr].Mask;
|
|
3: XKeyEvent.State := MModifiers[ssAltGr].Mask or MModifiers[ssShift].Mask;
|
|
else
|
|
// TODO: m > 3 ??
|
|
Continue;
|
|
end;
|
|
|
|
KeySymCharLen := XLookupString(@XKeyEvent, KeySymChars, SizeOf(KeySymChars), nil, nil);
|
|
if (KeySymCharLen > 0) and (KeySymChars[KeySymCharLen - 1] = #0)
|
|
then Dec(KeySymCharLen);
|
|
if (KeySymCharLen <= 0) then Continue;
|
|
{$else gtk1}
|
|
UniChar := gdk_keyval_to_unicode(KeySyms[m]);
|
|
if UniChar = 0 then Continue;
|
|
KeySymCharLen := g_unichar_to_utf8(UniChar, @KeySymChars[0]);
|
|
{$endif}
|
|
if (KeySymCharLen > SizeOf(TVKeyUTF8Char))
|
|
then DebugLn('[WARNING] InitKeyboardTables - Keysymstring for keycode=%u longer than %u bytes: %s', [KeyCode, SizeOf(TVKeyUTF8Char), KeySymChars]);
|
|
Move(KeySymChars[0], MVKeyInfo[VKey].KeyChar[m], SizeOf(TVKeyUTF8Char));
|
|
end;
|
|
end;
|
|
{$ifdef UseOwnShiftState}
|
|
SetLength(MKeyStateMap, KeyStateMapIndex);
|
|
{$endif}
|
|
|
|
{$ifdef gtk1}
|
|
XFree(KeySymStart);
|
|
{$endif}
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Procedure: DoneKeyboardTables
|
|
Params: none
|
|
Returns: none
|
|
|
|
Frees the dynamic keyboard tables
|
|
------------------------------------------------------------------------------}
|
|
procedure DoneKeyboardTables;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
if LCLHandledKeyEvents<>nil then begin
|
|
for i:=0 to LCLHandledKeyEvents.Count-1 do
|
|
TObject(LCLHandledKeyEvents[i]).Free;
|
|
LCLHandledKeyEvents.Free;
|
|
LCLHandledKeyEvents:=nil;
|
|
end;
|
|
if LCLHandledKeyAfterEvents<>nil then begin
|
|
for i:=0 to LCLHandledKeyAfterEvents.Count-1 do
|
|
TObject(LCLHandledKeyAfterEvents[i]).Free;
|
|
LCLHandledKeyAfterEvents.Free;
|
|
LCLHandledKeyAfterEvents:=nil;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Function: GetVKeyInfo
|
|
Params: AVKey: A virtual key to get the info for
|
|
Returns: A Info record
|
|
|
|
This function is more a safety to make sure MVkeyInfo isn't accessed out of
|
|
it's bounds
|
|
------------------------------------------------------------------------------}
|
|
function GetVKeyInfo(const AVKey: Byte): TVKeyInfo;
|
|
begin
|
|
Result := MVKeyInfo[AVKey];
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Procedure: GTKEventState2ShiftState
|
|
Params: KeyState: The gtk keystate
|
|
Returns: the TShiftState for the given KeyState
|
|
|
|
GTKEventStateToShiftState converts a GTK event state to a LCL/Delphi TShiftState
|
|
------------------------------------------------------------------------------}
|
|
function GTKEventStateToShiftState(KeyState: Word): TShiftState;
|
|
{$ifdef HasX}
|
|
function GetState: TShiftState;
|
|
var
|
|
Keys: chararr32;
|
|
n: Integer;
|
|
begin
|
|
Result := [];
|
|
keys:='';
|
|
XQueryKeyMap(gdk_display, Keys);
|
|
for n := Low(MKeyStateMap) to High(MKeyStateMap) do
|
|
begin
|
|
if Ord(Keys[MKeyStateMap[n].Index]) and MKeyStateMap[n].Mask = 0 then Continue;
|
|
Include(Result, MKeyStateMap[n].Enum);
|
|
Break;
|
|
end;
|
|
end;
|
|
{$else}
|
|
{$ifdef windows}
|
|
function GetState: TShiftState;
|
|
begin
|
|
Result := [];
|
|
if GetKeyState(VK_MENU) < 0 then Include(Result, ssAlt);
|
|
if (GetKeyState(VK_LWIN) < 0) or (GetKeyState(VK_RWIN) < 0) then Include(Result, ssMeta);
|
|
end;
|
|
{$else}
|
|
function GetState: TShiftState;
|
|
begin
|
|
Result := [];
|
|
end;
|
|
{$endif}
|
|
{$endif}
|
|
|
|
var
|
|
State: TShiftStateEnum;
|
|
begin
|
|
{$ifdef UseOwnShiftState}
|
|
Result := GetState;
|
|
{$else}
|
|
Result := [];
|
|
{$endif}
|
|
for State := Low(State) to High(State) do
|
|
begin
|
|
if MModifiers[State].Mask = 0 then Continue;
|
|
if MModifiers[State].UseValue
|
|
then begin
|
|
if KeyState and MModifiers[State].Mask = MModifiers[State].Value
|
|
then Include(Result, State);
|
|
end
|
|
else begin
|
|
if KeyState and MModifiers[State].Mask <> 0
|
|
then Include(Result, State);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Procedure: StoreCommonDialogSetup
|
|
Params: ADialog: TCommonDialog
|
|
Returns: none
|
|
|
|
Stores the size of a TCommonDialog.
|
|
------------------------------------------------------------------------------}
|
|
procedure StoreCommonDialogSetup(ADialog: TCommonDialog);
|
|
var DlgWindow: PGtkWidget;
|
|
begin
|
|
if (ADialog=nil) or (ADialog.Handle=0) then exit;
|
|
DlgWindow:=PGtkWidget(ADialog.Handle);
|
|
if DlgWindow^.Allocation.Width>0 then
|
|
ADialog.Width:=DlgWindow^.Allocation.Width;
|
|
if DlgWindow^.Allocation.Height>0 then
|
|
ADialog.Height:=DlgWindow^.Allocation.Height;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Procedure: DestroyCommonDialogAddOns
|
|
Params: ADialog: TCommonDialog
|
|
Returns: none
|
|
|
|
Free the memory of additional data of a TCommonDialog
|
|
------------------------------------------------------------------------------}
|
|
procedure DestroyCommonDialogAddOns(ADialog: TCommonDialog);
|
|
var
|
|
DlgWindow: PGtkWidget;
|
|
HistoryList: TFPList; // list of TFileSelHistoryListEntry
|
|
AHistoryEntry: PFileSelHistoryEntry;
|
|
i: integer;
|
|
FileSelWidget: PGtkFileSelection;
|
|
LCLHistoryMenu: PGTKWidget;
|
|
{$IFDEF Gtk1}
|
|
//AFilterEntry: TFileSelFilterEntry;
|
|
FilterList: TFPList; // list of TFileSelFilterListEntry
|
|
LCLFilterMenu: PGTKWidget;
|
|
{$ENDIF}
|
|
begin
|
|
if (ADialog=nil) or (not ADialog.HandleAllocated) then exit;
|
|
DlgWindow:=PGtkWidget(ADialog.Handle);
|
|
{$IFDEF VerboseTransient}
|
|
DebugLn('DestroyCommonDialogAddOns ',ADialog.Name,':',ADialog.ClassName);
|
|
{$ENDIF}
|
|
gtk_window_set_transient_for(PGtkWindow(DlgWindow),nil);
|
|
if ADialog is TOpenDialog then begin
|
|
{$IFDEF GTK2}
|
|
FileSelWidget:=GTK_FILE_CHOOSER(DlgWindow);
|
|
{$ELSE}
|
|
FileSelWidget:=GTK_FILE_SELECTION(DlgWindow);
|
|
FreeWidgetInfo(FileSelWidget^.selection_entry);
|
|
FreeWidgetInfo(FileSelWidget^.dir_list);
|
|
FreeWidgetInfo(FileSelWidget^.file_list);
|
|
LCLFilterMenu:=PGTKWidget(gtk_object_get_data(PGtkObject(FileSelWidget),
|
|
'LCLFilterMenu'));
|
|
if LCLFilterMenu<>nil then FreeWidgetInfo(LCLFilterMenu);
|
|
{$ENDIF}
|
|
LCLHistoryMenu:=PGTKWidget(gtk_object_get_data(PGtkObject(FileSelWidget),
|
|
'LCLHistoryMenu'));
|
|
if LCLHistoryMenu<>nil then FreeWidgetInfo(LCLHistoryMenu);
|
|
|
|
// free history
|
|
HistoryList:=TFPList(gtk_object_get_data(PGtkObject(DlgWindow),
|
|
'LCLHistoryList'));
|
|
if HistoryList<>nil then begin
|
|
for i:=0 to HistoryList.Count-1 do begin
|
|
AHistoryEntry:=PFileSelHistoryEntry(HistoryList[i]);
|
|
StrDispose(AHistoryEntry^.Filename);
|
|
AHistoryEntry^.Filename:=nil;
|
|
Dispose(AHistoryEntry);
|
|
end;
|
|
HistoryList.Free;
|
|
gtk_object_set_data(PGtkObject(DlgWindow),'LCLHistoryList',nil);
|
|
end;
|
|
|
|
{$IFDEF GTK1}
|
|
// free filter
|
|
FilterList:=TFPList(gtk_object_get_data(PGtkObject(DlgWindow),
|
|
'LCLFilterList'));
|
|
if FilterList<>nil then begin
|
|
for i:=0 to FilterList.Count-1 do
|
|
TObject(FilterList[i]).Free;
|
|
FilterList.Free;
|
|
gtk_object_set_data(PGtkObject(DlgWindow),'LCLFilterList',nil);
|
|
end;
|
|
{$ENDIF}
|
|
|
|
// free preview handle
|
|
if ADialog is TPreviewFileDialog then begin
|
|
if TPreviewFileDialog(ADialog).PreviewFileControl<>nil then
|
|
TPreviewFileDialog(ADialog).PreviewFileControl.Handle:=0;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Procedure: PopulateFileAndDirectoryLists
|
|
Params: FileSelection: PGtkFileSelection;
|
|
Mask: string (File mask, such as *.txt)
|
|
Returns: none
|
|
|
|
Populate the directory and file lists according to the given mask
|
|
------------------------------------------------------------------------------}
|
|
procedure PopulateFileAndDirectoryLists(FileSelection: PGtkFileSelection;
|
|
const Mask: string);
|
|
var
|
|
Dirs, Files: PGtkCList;
|
|
Text: array [0..1] of Pgchar;
|
|
Info: TSearchRec;
|
|
DirName: PChar;
|
|
Dir: string;
|
|
StrList: TStringList;
|
|
CurFileMask: String;
|
|
|
|
procedure Add(List: PGtkCList; const s: string);
|
|
begin
|
|
Text[0] := PChar(s);
|
|
gtk_clist_append(List, Text);
|
|
end;
|
|
|
|
procedure AddList(List: PGtkCList);
|
|
var
|
|
i: integer;
|
|
begin
|
|
StrList.Sorted := True;
|
|
//DebugLn(['AddList ',StrList.Text]);
|
|
for i:=0 to StrList.Count-1 do
|
|
Add(List, StrList[i]);
|
|
StrList.Sorted := False;
|
|
end;
|
|
|
|
begin
|
|
StrList := TStringList.Create;
|
|
dirs := PGtkCList(FileSelection^.dir_list);
|
|
files := PGtkCList(FileSelection^.file_list);
|
|
DirName := gtk_file_selection_get_filename(FileSelection);
|
|
if DirName <> nil then begin
|
|
SetString(Dir, DirName, strlen(DirName));
|
|
SetLength(Dir, LastDelimiter(PathDelim,Dir));
|
|
end else
|
|
Dir := '';
|
|
//DebugLn(['PopulateFileAndDirectoryLists ',Dir]);
|
|
Text[1] := nil;
|
|
gtk_clist_freeze(Dirs);
|
|
gtk_clist_clear(Dirs);
|
|
gtk_clist_freeze(Files);
|
|
gtk_clist_clear(Files);
|
|
{ Add all directories }
|
|
Strlist.Add('..'+PathDelim);
|
|
if FindFirstUTF8(AppendPathDelim(Dir)+GetAllFilesMask, faAnyFile and faDirectory,
|
|
Info) = 0
|
|
then begin
|
|
repeat
|
|
if ((Info.Attr and faDirectory) = faDirectory) and (Info.Name <> '.')
|
|
and (Info.Name <> '..') and (Info.Name<>'') then
|
|
StrList.Add(AppendPathDelim(Info.Name));
|
|
until FindNextUTF8(Info) <> 0;
|
|
end;
|
|
FindCloseUTF8(Info);
|
|
AddList(Dirs);
|
|
// add required files
|
|
StrList.Clear;
|
|
CurFileMask:=Mask;
|
|
if CurFileMask='' then CurFileMask:=GetAllFilesMask;
|
|
if FindFirstUTF8(AppendPathDelim(Dir)+GetAllFilesMask, faAnyFile, Info) = 0 then
|
|
begin
|
|
repeat
|
|
if ((Info.Attr and faDirectory) <> faDirectory) then begin
|
|
//debugln('PopulateFileAndDirectoryLists CurFileMask="',CurFileMask,'" Info.Name="',Info.Name,'" ',dbgs(MatchesMaskList(Info.Name,CurFileMask)));
|
|
if (CurFileMask='') or (MatchesMaskList(Info.Name,CurFileMask)) then
|
|
begin
|
|
Strlist.Add(Info.Name);
|
|
end;
|
|
end;
|
|
until FindNextUTF8(Info) <> 0;
|
|
end;
|
|
FindCloseUTF8(Info);
|
|
AddList(Files);
|
|
StrList.Free;
|
|
gtk_clist_thaw(Dirs);
|
|
gtk_clist_thaw(Files);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Procedure: DeliverMessage
|
|
Params: Message: the message to process
|
|
Returns: True if handled
|
|
|
|
Generic function which calls the WindowProc if defined, otherwise the
|
|
dispatcher
|
|
------------------------------------------------------------------------------}
|
|
function DeliverMessage(const Target: Pointer; var AMessage): PtrInt;
|
|
begin
|
|
if (TLMessage(AMessage).Msg = LM_PAINT) or
|
|
(TLMessage(AMessage).Msg = LM_GTKPAINT) then
|
|
CurrentSentPaintMessageTarget := TObject(Target);
|
|
|
|
Result := LCLMessageGlue.DeliverMessage(TObject(Target), AMessage);
|
|
|
|
CurrentSentPaintMessageTarget := nil;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Function: ObjectToGTKObject
|
|
Params: AnObject: A LCL Object
|
|
Returns: The GTKObject of the given object
|
|
|
|
Returns the GTKObject of the given object, nil if no object available
|
|
------------------------------------------------------------------------------}
|
|
function ObjectToGTKObject(const AnObject: TObject): PGtkObject;
|
|
var
|
|
handle : HWND;
|
|
begin
|
|
Handle := 0;
|
|
if not assigned(AnObject) then
|
|
begin
|
|
assert (false, 'TRACE: [ObjectToGtkObject] Object not assigned');
|
|
end
|
|
else if (AnObject is TWinControl) then
|
|
begin
|
|
if TWinControl(AnObject).HandleAllocated then
|
|
handle := TWinControl(AnObject).Handle;
|
|
end
|
|
else if (AnObject is TMenuItem) then
|
|
begin
|
|
if TMenuItem(AnObject).HandleAllocated then
|
|
handle := TMenuItem(AnObject).Handle;
|
|
end
|
|
else if (AnObject is TMenu) then
|
|
begin
|
|
if TMenu(AnObject).HandleAllocated then
|
|
handle := TMenu(AnObject).Items.Handle;
|
|
end
|
|
else if (AnObject is TCommonDialog) then
|
|
begin
|
|
{if TCommonDialog(AObject).HandleAllocated then }
|
|
handle := TCommonDialog(AnObject).Handle;
|
|
end
|
|
else begin
|
|
//DebugLn(Format('Trace: [ObjectToGtkObject] Message received with unhandled class-type <%s>', [AnObject.ClassName]));
|
|
end;
|
|
Result := PGTKObject(handle);
|
|
if handle = 0 then
|
|
Assert (false, 'Trace: [ObjectToGtkObject]****** Warning: handle = 0 *******');
|
|
end;
|
|
|
|
|
|
(***********************************************************************
|
|
Widget member functions
|
|
************************************************************************)
|
|
|
|
// ----------------------------------------------------------------------
|
|
// the main widget is the widget passed as handle to the winAPI
|
|
// main data is stored in the fixed form to get a reference to its parent
|
|
// ----------------------------------------------------------------------
|
|
function GetMainWidget(const Widget: Pointer): Pointer;
|
|
begin
|
|
if Widget = nil
|
|
then raise EInterfaceException.Create('GetMainWidget Widget=nil');
|
|
|
|
Result := gtk_object_get_data(Widget, 'Main');
|
|
if Result = nil then Result := Widget; // the widget is the main widget itself.
|
|
end;
|
|
|
|
procedure SetMainWidget(const ParentWidget, ChildWidget: Pointer);
|
|
begin
|
|
if ParentWidget = nil
|
|
then raise EInterfaceException.Create('SetMainWidget ParentWidget=nil');
|
|
if ChildWidget = nil
|
|
then raise EInterfaceException.Create('SetMainWidget ChildWidget=nil');
|
|
if ParentWidget = ChildWidget
|
|
then raise EInterfaceException.Create('SetMainWidget ParentWidget=ChildWidget');
|
|
{$IFDEF Gtk2}
|
|
if PGtkWidget(ParentWidget)^.parent=ChildWidget
|
|
then raise EInterfaceException.Create('SetMainWidget Parent^.Parent=ChildWidget');
|
|
{$ENDIF}
|
|
|
|
gtk_object_set_data(ChildWidget, 'Main', ParentWidget)
|
|
end;
|
|
|
|
{ ------------------------------------------------------------------------------
|
|
Get the fixed widget of a widget.
|
|
Every LCL control with a clientarea, has at least a main widget for the control
|
|
and a fixed widget for the client area. If the Fixed widget is not set, use
|
|
try to get it trough WinWidgetInfo
|
|
------------------------------------------------------------------------------ }
|
|
//TODO: remove when WinWidgetInfo implementation is complete
|
|
function GetFixedWidget(const Widget: Pointer): Pointer;
|
|
var
|
|
WidgetInfo: PWinWidgetInfo;
|
|
begin
|
|
if Widget = nil
|
|
then raise EInterfaceException.Create('GetFixedWidget Widget=nil');
|
|
|
|
WidgetInfo := GetWidgetInfo(Widget, False);
|
|
if WidgetInfo <> nil
|
|
then Result := WidgetInfo^.ClientWidget
|
|
else Result := nil;
|
|
if Result <> nil then Exit;
|
|
|
|
Result := gtk_object_get_data(Widget, 'Fixed');
|
|
// A last resort
|
|
if Result = nil then Result := Widget;
|
|
end;
|
|
|
|
{ ------------------------------------------------------------------------------
|
|
Set the fixed widget of a widget.
|
|
Every LCL control with a clientarea, has at least a main widget for the control
|
|
and a fixed widget for the client area.
|
|
------------------------------------------------------------------------------ }
|
|
procedure SetFixedWidget(const ParentWidget, FixedWidget: Pointer);
|
|
var
|
|
WidgetInfo: PWinWidgetInfo;
|
|
begin
|
|
if ParentWidget = nil
|
|
then raise EInterfaceException.Create('SetFixedWidget ParentWidget=nil');
|
|
|
|
WidgetInfo := GetWidgetInfo(ParentWidget, True);
|
|
WidgetInfo^.ClientWidget := FixedWidget;
|
|
//TODO: remove old compatebility
|
|
gtk_object_set_data(ParentWidget, 'Fixed', FixedWidget)
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
Set the LCLobject which created this widget.
|
|
|
|
-------------------------------------------------------------------------------}
|
|
procedure SetLCLObject(const Widget: Pointer; const AnObject: TObject);
|
|
var
|
|
WidgetInfo: PWinWidgetInfo;
|
|
begin
|
|
if Widget = nil
|
|
then raise EInterfaceException.Create('SetLCLObject Widget=nil');
|
|
if AnObject = nil
|
|
then raise EInterfaceException.Create('SetLCLObject AnObject=nil');
|
|
|
|
WidgetInfo := GetWidgetInfo(Widget, True);
|
|
WidgetInfo^.LCLObject := AnObject;
|
|
end;
|
|
|
|
function GetLCLObject(const Widget: Pointer): TObject;
|
|
var
|
|
WidgetInfo: PWinWidgetInfo;
|
|
begin
|
|
if Widget = nil
|
|
then raise EInterfaceException.Create('GetLCLObject Widget=nil');
|
|
|
|
WidgetInfo := GetWidgetInfo(Widget);
|
|
if WidgetInfo <> nil
|
|
then Result := WidgetInfo^.LCLObject
|
|
else Result := nil;
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
Some need the HiddenLCLobject which created a parent of this widget.
|
|
|
|
MWE: is this obsolete ?
|
|
-------------------------------------------------------------------------------}
|
|
procedure SetHiddenLCLObject(const Widget: Pointer; const AnObject: TObject);
|
|
begin
|
|
if (Widget <> nil) then
|
|
gtk_object_set_data(Widget, 'LCLHiddenClass', Pointer(AnObject));
|
|
end;
|
|
|
|
function GetHiddenLCLObject(const Widget: Pointer): TObject;
|
|
begin
|
|
Result := TObject(gtk_object_get_data(Widget, 'LCLHiddenClass'));
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
function GetNearestLCLObject(Widget: PGtkWidget): TObject;
|
|
|
|
Retrieves the LCLObject belonging to the widget. If the widget is created as
|
|
child of a main widget, the parent is queried.
|
|
|
|
This function probably obsoletes Get/SetMainWidget
|
|
-------------------------------------------------------------------------------}
|
|
//TODO: check if Get/SetMainWidget is still required
|
|
function GetNearestLCLObject(Widget: PGtkWidget): TObject;
|
|
begin
|
|
while (Widget<>nil) do begin
|
|
Result:=GetLCLObject(Widget);
|
|
if Result<>nil then exit;
|
|
Widget:=Widget^.Parent;
|
|
end;
|
|
Result:=nil;
|
|
end;
|
|
|
|
function CreateFixedClientWidget(WithWindow: Boolean = True): PGTKWidget;
|
|
begin
|
|
Result := gtk_fixed_new();
|
|
{$IFDEF GTK2}
|
|
if WithWindow then
|
|
gtk_fixed_set_has_window(PGtkFixed(Result), true);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure FixedMoveControl(Parent, Child : PGTKWidget; Left, Top : Longint);
|
|
|
|
Move a childwidget on a client area (fixed or layout widget).
|
|
------------------------------------------------------------------------------}
|
|
procedure FixedMoveControl(Parent, Child : PGTKWidget; Left, Top : Longint);
|
|
begin
|
|
If GTKWidgetIsA(Parent, GTK_Layout_Get_Type) then begin
|
|
// parent is layout
|
|
gtk_Layout_move(PGtkLayout(Parent), Child, Left, Top)
|
|
end else If GTKWidgetIsA(Parent, GTK_Fixed_Get_Type) then begin
|
|
// parent is fixed
|
|
gtk_fixed_move(PGtkFixed(Parent), Child, gint16(Left), gint16(Top));
|
|
end else begin
|
|
// parent is invalid
|
|
DebugLn('[FixedMoveControl] WARNING: Invalid Fixed Widget');
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure FixedPutControl(Parent, Child : PGTKWIdget; Left, Top : Longint);
|
|
|
|
Add a childwidget onto a client area (fixed or layout widget).
|
|
------------------------------------------------------------------------------}
|
|
procedure FixedPutControl(Parent, Child: PGTKWidget; Left, Top: Longint);
|
|
|
|
procedure RaiseInvalidFixedWidget;
|
|
begin
|
|
// this is in a separate procedure for optimisation
|
|
DebugLn('[FixedPutControl] WARNING: Invalid Fixed Widget.',
|
|
' Parent=',DbgS(Parent),
|
|
' Child=',DbgS(Child)
|
|
);
|
|
end;
|
|
|
|
begin
|
|
if GtkWidgetIsA(Parent, gtk_fixed_get_type) then
|
|
gtk_fixed_put(PGtkFixed(Parent), Child, gint16(Left), gint16(Top))
|
|
else
|
|
if GtkWidgetIsA(Parent, gtk_layout_get_type) then
|
|
gtk_layout_put(PGtkLayout(Parent), Child, Left, Top)
|
|
else
|
|
RaiseInvalidFixedWidget;
|
|
end;
|
|
|
|
function GetWinControlWidget(Child: PGtkWidget): PGtkWidget;
|
|
// return the first widget, which is associated with a TWinControl handle
|
|
var
|
|
LCLParent: TObject;
|
|
begin
|
|
Result:=nil;
|
|
LCLParent:=GetNearestLCLObject(Child);
|
|
if (LCLParent=nil) or (not (LCLParent is TWinControl))
|
|
or (not TWinControl(LCLParent).HandleAllocated)
|
|
then exit;
|
|
Result:=PGtkWidget(TWinControl(LCLParent).Handle);
|
|
end;
|
|
|
|
function GetWinControlFixedWidget(Child: PGtkWidget): PGtkWidget;
|
|
begin
|
|
Result:=GetWinControlWidget(Child);
|
|
if Result=nil then exit;
|
|
Result:=GetFixedWidget(Result);
|
|
end;
|
|
|
|
function FindFixedChildListItem(ParentFixed: PGtkFixed; Child: PGtkWidget): PGList;
|
|
begin
|
|
Result:=ParentFixed^.children;
|
|
while (Result<>nil) do begin
|
|
if (Result^.Data<>nil) and (PGtkFixedChild(Result^.Data)^.Widget=Child) then
|
|
exit;
|
|
Result:=Result^.Next;
|
|
end;
|
|
end;
|
|
|
|
function FindFixedLastChildListItem(ParentFixed: PGtkFixed): PGList;
|
|
begin
|
|
Result:=g_list_last(ParentFixed^.children);
|
|
end;
|
|
|
|
function GetFixedChildListWidget(Item: PGList): PGtkWidget;
|
|
begin
|
|
Result:=PGtkFixedChild(Item^.Data)^.Widget;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure MoveGListLinkBehind(First, Item, After: PGList);
|
|
|
|
Move the list item 'Item' behind the list item 'After'.
|
|
If After=nil then insert as first item.
|
|
------------------------------------------------------------------------------}
|
|
procedure MoveGListLinkBehind(First, Item, After: PGList);
|
|
var
|
|
Data: Pointer;
|
|
NewPos: Integer;
|
|
begin
|
|
if (Item=After) or (Item^.Next=After) then exit;
|
|
if (g_list_position(First,Item)<0) then
|
|
RaiseGDBException('MoveGListLinkBehind Item not found');
|
|
if (After<>nil) and (g_list_position(First,After)<0) then
|
|
RaiseGDBException('MoveGListLinkBehind After not found');
|
|
Data:=Item^.Data;
|
|
g_list_remove_link(First,Item);
|
|
if After<>nil then begin
|
|
NewPos:=g_list_position(First,After)+1;
|
|
end else begin
|
|
NewPos:=0;
|
|
end;
|
|
g_list_insert(First,Data,NewPos);
|
|
end;
|
|
|
|
procedure MoveGListLink(First: PGList; FromIndex, ToIndex: integer);
|
|
var
|
|
Item: PGList;
|
|
InsertAfter: PGList;
|
|
i: Integer;
|
|
begin
|
|
if (FromIndex=ToIndex) then exit;
|
|
Item:=First;
|
|
i:=0;
|
|
while (i<FromIndex) do begin
|
|
Item:=Item^.next;
|
|
inc(i);
|
|
end;
|
|
// unbind
|
|
if Item^.next<>nil then Item^.next^.prev:=Item^.prev;
|
|
if Item^.prev<>nil then Item^.prev^.next:=Item^.next;
|
|
Item^.next:=nil;
|
|
Item^.prev:=nil;
|
|
// insert
|
|
if ToIndex=0 then begin
|
|
Item^.next:=First;
|
|
First^.prev:=Item;
|
|
end else begin
|
|
i:=0;
|
|
InsertAfter:=First;
|
|
while (i<ToIndex-1) do begin
|
|
if InsertAfter^.next=nil then break;
|
|
InsertAfter:=InsertAfter^.next;
|
|
inc(i);
|
|
end;
|
|
Item^.prev:=InsertAfter;
|
|
Item^.next:=InsertAfter^.next;
|
|
InsertAfter^.next:=Item;
|
|
if Item^.next<>nil then Item^.next^.prev:=Item;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function GetControlWindow(Widget: Pointer) : PGDKWindow;
|
|
|
|
Get the gdkwindow of a widget.
|
|
------------------------------------------------------------------------------}
|
|
function GetControlWindow(Widget: Pointer) : PGDKWindow;
|
|
begin
|
|
if Widget <> nil then
|
|
begin
|
|
If not GTKWidgetIsA(PGTKWidget(Widget), GTK_Layout_Get_Type) then
|
|
Result := PGTKWidget(Widget)^.Window
|
|
else
|
|
Result := PGtkLayout(Widget)^.bin_window;
|
|
{$IFDEF Gtk2}
|
|
if (Result=nil) and (GTK_WIDGET_NO_WINDOW(Widget)) then
|
|
Result:=gtk_widget_get_parent_window(Widget);
|
|
{$ENDIF}
|
|
end else
|
|
RaiseGDBException('GetControlWindow Widget=nil');
|
|
end;
|
|
|
|
|
|
{------------------------------------------------------------------------------
|
|
function CreateWidgetInfo(const AWidget: Pointer): PWidgetInfo;
|
|
|
|
Creates a WidgetInfo structure for the given widget
|
|
Info needed by the API of a HWND (=Widget)
|
|
|
|
This structure obsoletes all other object data, like
|
|
"core-child", "fixed", "class"
|
|
------------------------------------------------------------------------------}
|
|
function CreateWidgetInfo(const AWidget: Pointer): PWidgetInfo;
|
|
begin
|
|
if AWidget = nil then Result:= nil
|
|
else begin
|
|
New(Result);
|
|
FillChar(Result^, SizeOf(Result^), 0);
|
|
gtk_object_set_data(AWidget, 'widgetinfo', Result);
|
|
Result^.DefaultCursor := HCursor(-1);
|
|
end;
|
|
end;
|
|
|
|
function CreateWidgetInfo(const AWidget: Pointer; const AObject: TObject;
|
|
const AParams: TCreateParams): PWidgetInfo;
|
|
begin
|
|
Result := CreateWidgetInfo(AWidget);
|
|
if Result = nil then Exit;
|
|
|
|
Result^.LCLObject := AObject;
|
|
// in most cases the created widget is the core widget
|
|
// so default to it
|
|
Result^.CoreWidget := AWidget;
|
|
Result^.Style := AParams.Style;
|
|
Result^.ExStyle := AParams.ExStyle;
|
|
Result^.WndProc := PtrUInt(AParams.WindowClass.lpfnWndProc);
|
|
end;
|
|
|
|
function GetWidgetInfo(const AWidget: Pointer {; const Create: Boolean = False}): PWidgetInfo;
|
|
begin
|
|
Result := GetWidgetInfo(AWidget, False);
|
|
end;
|
|
|
|
function GetWidgetInfo(const AWidget: Pointer;
|
|
const ACreate: Boolean): PWidgetInfo;
|
|
var
|
|
MainWidget: PGtkObject;
|
|
begin
|
|
if AWidget <> nil then
|
|
begin
|
|
MainWidget := GetMainWidget(AWidget);
|
|
Result := gtk_object_get_data(MainWidget, 'widgetinfo');
|
|
if (Result = nil) and ACreate then
|
|
begin
|
|
Result := CreateWidgetInfo(MainWidget);
|
|
// use the main widget as default
|
|
Result^.CoreWidget := PGtkWidget(MainWidget);
|
|
end;
|
|
end
|
|
else Result := nil;
|
|
end;
|
|
|
|
procedure FreeWidgetInfo(AWidget: Pointer);
|
|
var
|
|
Info: PWidgetInfo;
|
|
begin
|
|
if AWidget = nil then Exit;
|
|
//DebugLn(['FreeWidgetInfo ',GetWidgetDebugReport(AWidget)]);
|
|
Info := gtk_object_get_data(AWidget, 'widgetinfo');
|
|
if Info = nil then Exit;
|
|
|
|
if Info^.DoubleBuffer <> nil then
|
|
gdk_pixmap_unref(Info^.DoubleBuffer);
|
|
|
|
if (Info^.UserData <> nil) and (Info^.DataOwner) then begin
|
|
FreeMem(Info^.UserData);
|
|
//Info^.UserData := nil; // see below the whole memory is cleared by Fillchar
|
|
end;
|
|
gtk_object_set_data(AWidget,'widgetinfo',nil);
|
|
|
|
// Set WidgetInfo memory to nil. This will expose bugs that use widgetinfo after
|
|
// it has been freed and is still referenced by something!
|
|
FillChar(Info^, SizeOf(TWidgetInfo), 0);
|
|
|
|
Dispose(Info);
|
|
//DebugLn(['FreeWidgetInfo END']);
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
procedure DestroyWidget(Widget: PGtkWidget);
|
|
|
|
- sends LM_DESTROY
|
|
- frees the WidgetInfo
|
|
- destroys the widget in the gtk
|
|
|
|
IMPORTANT:
|
|
The above order must be kept, to avoid callbacks working with dangling
|
|
pointers.
|
|
|
|
Some widgets have a LM_DESTROY set, so if the gtk or some other code
|
|
destroys those widget, the above is done in gtkdestroyCB.
|
|
-------------------------------------------------------------------------------}
|
|
procedure DestroyWidget(Widget: PGtkWidget);
|
|
var
|
|
Info: PWidgetInfo;
|
|
AWinControl: TWinControl;
|
|
Mess: TLMessage;
|
|
begin
|
|
//DebugLn(['DestroyWidget A ',GetWidgetDebugReport(Widget)]);
|
|
{$IFDEF DebugLCLComponents}
|
|
if DebugGtkWidgets.FindInfo(Widget)=nil then
|
|
DebugLn(['DestroyWidget ',GetWidgetDebugReport(Widget)]);
|
|
{$ENDIF}
|
|
Info:=GetWidgetInfo(Widget);
|
|
if Info<>nil then begin
|
|
if (Info^.LCLObject is TWinControl) then begin
|
|
AWinControl:=TWinControl(Info^.LCLObject);
|
|
if AWinControl.HandleAllocated
|
|
and (PGtkWidget(AWinControl.Handle)=Widget) then begin
|
|
// send the LM_DESTROY message before destroying the widget
|
|
FillChar(Mess,SizeOf(Mess),0);
|
|
Mess.msg := LM_DESTROY;
|
|
DeliverMessage(Info^.LCLObject, Mess);
|
|
end;
|
|
end;
|
|
FreeWidgetInfo(Widget);
|
|
end;
|
|
{$IFDEF DebugLCLComponents}
|
|
DebugGtkWidgets.MarkDestroyed(Widget);
|
|
{$ENDIF}
|
|
gtk_widget_destroy(Widget);
|
|
//DebugLn(['DestroyWidget B']);
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
function GetGtkNoteBookDummyPage(ANoteBookWidget: PGtkNoteBook): PGtkWidget;
|
|
|
|
Retrieves the DummyWidget associated with the ANoteBookWidget
|
|
-------------------------------------------------------------------------------}
|
|
function GetGtkNoteBookDummyPage(ANoteBookWidget: PGtkNoteBook): PGtkWidget;
|
|
begin
|
|
Result:=gtk_object_get_data(PGtkObject(ANoteBookWidget),'LCLDummyPage');
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
procedure SetGtkNoteBookDummyPage(ANoteBookWidget: PGtkNoteBook;
|
|
DummyWidget: PGtkWidget): PGtkWidget;
|
|
|
|
Associates the DummyWidget with the ANoteBookWidget
|
|
-------------------------------------------------------------------------------}
|
|
procedure SetGtkNoteBookDummyPage(ANoteBookWidget: PGtkNoteBook;
|
|
DummyWidget: PGtkWidget);
|
|
begin
|
|
gtk_object_set_data(PGtkObject(ANoteBookWidget),'LCLDummyPage',DummyWidget);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
UpdateNoteBookClientWidget
|
|
Params: ANoteBook: TObject
|
|
|
|
This procedure updates the 'Fixed' object data.
|
|
* obsolete *
|
|
------------------------------------------------------------------------------}
|
|
procedure UpdateNoteBookClientWidget(ANoteBook: TObject);
|
|
var
|
|
ClientWidget: PGtkWidget;
|
|
NoteBookWidget: PGtkNotebook;
|
|
begin
|
|
if not TCustomTabControl(ANoteBook).HandleAllocated then exit;
|
|
NoteBookWidget := PGtkNotebook(TCustomTabControl(ANoteBook).Handle);
|
|
ClientWidget := nil;
|
|
SetFixedWidget(NoteBookWidget, ClientWidget);
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
function GetGtkNoteBookPageCount(ANoteBookWidget: PGtkNoteBook): integer;
|
|
|
|
Returns the number of pages in a PGtkNotebook
|
|
-------------------------------------------------------------------------------}
|
|
function GetGtkNoteBookPageCount(ANoteBookWidget: PGtkNoteBook): integer;
|
|
var
|
|
AListItem: PGList;
|
|
begin
|
|
Result:=0;
|
|
if ANoteBookWidget=nil then exit;
|
|
AListItem:=ANoteBookWidget^.children;
|
|
while AListItem<>nil do begin
|
|
inc(Result);
|
|
AListItem:=AListItem^.Next;
|
|
end;
|
|
end;
|
|
|
|
{$IFDef GTK1}
|
|
var
|
|
NoteBookCloseBtnPixmapImg: PGdkPixmap = nil;
|
|
NoteBookCloseBtnPixmapMask: PGdkPixmap = nil;
|
|
{$EndIf}
|
|
|
|
{-------------------------------------------------------------------------------
|
|
procedure RemoveDummyNoteBookPage(NoteBookWidget: PGtkNotebook);
|
|
|
|
Removes the dummy page.
|
|
See also AddDummyNoteBookPage
|
|
-------------------------------------------------------------------------------}
|
|
procedure RemoveDummyNoteBookPage(NoteBookWidget: PGtkNotebook);
|
|
var
|
|
DummyWidget: PGtkWidget;
|
|
begin
|
|
DummyWidget:=GetGtkNoteBookDummyPage(NoteBookWidget);
|
|
if DummyWidget=nil then exit;
|
|
gtk_notebook_remove_page(NoteBookWidget,
|
|
gtk_notebook_page_num(NoteBookWidget,DummyWidget));
|
|
DummyWidget:=nil;
|
|
SetGtkNoteBookDummyPage(NoteBookWidget,DummyWidget);
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
method GetNoteBookCloseBtnImage
|
|
Params:
|
|
Result: none
|
|
|
|
Loads the image for the close button in the tabs of the TCustomTabControl(s).
|
|
-------------------------------------------------------------------------------}
|
|
{$IfDef GTK1}
|
|
procedure GetNoteBookCloseBtnImage(Window: PGdkWindow;
|
|
var Img, Mask: PGdkPixmap);
|
|
begin
|
|
if (NoteBookCloseBtnPixmapImg=nil)
|
|
and (Window<>nil) then begin
|
|
LoadXPMFromLazResource('tnotebook_close_tab',Window,
|
|
NoteBookCloseBtnPixmapImg,NoteBookCloseBtnPixmapMask);
|
|
end;
|
|
Img:=NoteBookCloseBtnPixmapImg;
|
|
Mask:=NoteBookCloseBtnPixmapMask;
|
|
end;
|
|
{$EndIF}
|
|
|
|
{-------------------------------------------------------------------------------
|
|
method UpdateNotebookPageTab
|
|
Params: ANoteBook: TCustomTabControl; APage: TCustomPage
|
|
Result: none
|
|
|
|
Updates the tab of a page of a notebook. This contains the image to the left
|
|
side, the label, the close button, the menu image and the menu label.
|
|
-------------------------------------------------------------------------------}
|
|
procedure UpdateNotebookPageTab(ANoteBook, APage: TObject);
|
|
var
|
|
TheNoteBook: TCustomTabControl;
|
|
ThePage: TCustomPage;
|
|
|
|
NoteBookWidget: PGtkWidget; // the notebook
|
|
PageWidget: PGtkWidget; // the page (content widget)
|
|
TabWidget: PGtkWidget; // the tab (hbox containing a pixmap, a label
|
|
// and a close button)
|
|
TabImageWidget: PGtkWidget; // the icon widget in the tab (a fixed widget)
|
|
TabLabelWidget: PGtkWidget; // the label in the tab
|
|
TabCloseBtnWidget: PGtkWidget;// the close button in the tab
|
|
TabCloseBtnImageWidget: PGtkWidget; // the pixmap in the close button
|
|
MenuWidget: PGtkWidget; // the popup menu (hbox containing a pixmap and
|
|
// a label)
|
|
MenuImageWidget: PGtkWidget; // the icon widget in the popup menu item (a fixed widget)
|
|
MenuLabelWidget: PGtkWidget; // the label in the popup menu item
|
|
|
|
procedure UpdateTabImage;
|
|
var
|
|
HasIcon: Boolean;
|
|
IconSize: TPoint;
|
|
ImageIndex: Integer;
|
|
begin
|
|
HasIcon:=false;
|
|
IconSize:=Point(0,0);
|
|
ImageIndex := TheNoteBook.GetImageIndex(ThePage.PageIndex);
|
|
if (TheNoteBook.Images<>nil)
|
|
and (ImageIndex >= 0)
|
|
and (ImageIndex < TheNoteBook.Images.Count) then
|
|
begin
|
|
// page has valid image
|
|
IconSize := Point(TheNoteBook.Images.Width, TheNoteBook.Images.Height);
|
|
HasIcon := (IconSize.X>0) and (IconSize.Y>0);
|
|
end;
|
|
|
|
if HasIcon then
|
|
begin
|
|
// page has an image
|
|
if TabImageWidget <> nil then
|
|
begin
|
|
// there is already an icon widget for the image in the tab
|
|
// -> resize the icon widget
|
|
gtk_widget_set_usize(TabImageWidget,IconSize.X,IconSize.Y);
|
|
end else
|
|
begin
|
|
// there is no pixmap for the image in the tab
|
|
// -> insert one ot the left side of the label
|
|
TabImageWidget := gtk_label_new(#0);
|
|
g_signal_connect(PgtkObject(TabImageWidget), 'expose_event',
|
|
TGTKSignalFunc(@PageIconWidgetExposeAfter), ThePage);
|
|
{$IFNDEF GTK2}
|
|
g_signal_connect(PgtkObject(TabImageWidget), 'draw',
|
|
TGTKSignalFunc(@PageIconWidgetDrawAfter), ThePage);
|
|
{$ENDIF}
|
|
gtk_object_set_data(PGtkObject(TabWidget), 'TabImage', TabImageWidget);
|
|
gtk_widget_set_usize(TabImageWidget, IconSize.X, IconSize.Y);
|
|
gtk_widget_show(TabImageWidget);
|
|
gtk_box_pack_start_defaults(PGtkBox(TabWidget), TabImageWidget);
|
|
gtk_box_reorder_child(PGtkBox(TabWidget), TabImageWidget, 0);
|
|
end;
|
|
if MenuImageWidget<>nil then
|
|
begin
|
|
// there is already an icon widget for the image in the menu
|
|
// -> resize the icon widget
|
|
gtk_widget_set_usize(MenuImageWidget, IconSize.X, IconSize.Y);
|
|
end else
|
|
begin
|
|
// there is no icon widget for the image in the menu
|
|
// -> insert one at the left side of the label
|
|
MenuImageWidget:=gtk_label_new(#0);
|
|
g_signal_connect_after(PgtkObject(MenuImageWidget), 'expose_event',
|
|
TGTKSignalFunc(@PageIconWidgetExposeAfter), ThePage);
|
|
{$IFNDEF GTK2}
|
|
g_signal_connect_after(PgtkObject(MenuImageWidget), 'draw',
|
|
TGTKSignalFunc(@PageIconWidgetDrawAfter), ThePage);
|
|
{$ENDIF}
|
|
gtk_widget_set_usize(MenuImageWidget,IconSize.X,IconSize.Y);
|
|
gtk_object_set_data(PGtkObject(MenuWidget),'TabImage',MenuImageWidget);
|
|
gtk_widget_show(MenuImageWidget);
|
|
gtk_box_pack_start_defaults(PGtkBox(MenuWidget),MenuImageWidget);
|
|
gtk_box_reorder_child(PGtkBox(MenuWidget),MenuImageWidget,0);
|
|
end;
|
|
end else
|
|
begin
|
|
// page does not have an image
|
|
if TabImageWidget<>nil then
|
|
begin
|
|
// there is a pixmap for an old image in the tab
|
|
// -> remove the icon widget
|
|
DestroyWidget(TabImageWidget);
|
|
gtk_object_set_data(PGtkObject(TabWidget), 'TabImage', nil);
|
|
TabImageWidget:=nil;
|
|
end;
|
|
if MenuImageWidget<>nil then
|
|
begin
|
|
// there is a pixmap for an old image in the menu
|
|
// -> remove the icon widget
|
|
DestroyWidget(MenuImageWidget);
|
|
gtk_object_set_data(PGtkObject(MenuWidget), 'TabImage', nil);
|
|
MenuImageWidget:=nil;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure UpdateTabLabel;
|
|
var
|
|
ACaption: String;
|
|
begin
|
|
ACaption := ThePage.Caption;
|
|
GTKWidgetSet.SetLabelCaption(PGtkLabel(TabLabelWidget), ACaption);
|
|
|
|
if MenuLabelWidget <> nil then
|
|
GTKWidgetSet.SetLabelCaption(PGtkLabel(MenuLabelWidget), ACaption);
|
|
end;
|
|
|
|
procedure UpdateTabCloseBtn;
|
|
var
|
|
{$IfDef GTK1}
|
|
Img: PGdkPixmap;
|
|
Mask: PGdkBitmap;
|
|
{$Else}
|
|
style: PGtkRcStyle;
|
|
{$EndIf}
|
|
begin
|
|
{$IfDef GTK1}
|
|
//debugln('UpdateTabCloseBtn ',GetWidgetDebugReport(NoteBookWidget));
|
|
Img:=nil;
|
|
Mask:=nil;
|
|
GetNoteBookCloseBtnImage(GetControlWindow(NoteBookWidget), Img, Mask);
|
|
{$EndIf}
|
|
//debugln('UpdateTabCloseBtn ',dbgs(nboShowCloseButtons in TheNotebook.Options),' ',dbgs(Img<>nil));
|
|
if (nboShowCloseButtons in TheNotebook.Options)
|
|
{$ifdef GTK1}and (Img <> nil){$ENDIF} then
|
|
begin
|
|
// close buttons enabled
|
|
if TabCloseBtnWidget = nil then
|
|
begin
|
|
// there is no close button yet
|
|
// -> add one to the right side of the label in the tab
|
|
TabCloseBtnWidget := gtk_button_new;
|
|
gtk_button_set_relief(PGtkButton(TabCloseBtnWidget), GTK_RELIEF_NONE);
|
|
{$ifdef gtk2}
|
|
gtk_button_set_focus_on_click(PGtkButton(TabCloseBtnWidget), False);
|
|
style := gtk_widget_get_modifier_style(TabCloseBtnWidget);
|
|
style^.xthickness := 0;
|
|
style^.ythickness := 0;
|
|
gtk_widget_modify_style(TabCloseBtnWidget, style);
|
|
{$endif}
|
|
gtk_object_set_data(PGtkObject(TabWidget), 'TabCloseBtn',
|
|
TabCloseBtnWidget);
|
|
// put a pixmap into the button
|
|
{$IfDef GTK1}
|
|
TabCloseBtnImageWidget:=gtk_pixmap_new(Img,Mask);
|
|
{$Else}
|
|
TabCloseBtnImageWidget:=gtk_image_new_from_stock(GTK_STOCK_CLOSE, GTK_ICON_SIZE_MENU);
|
|
{$EndIf}
|
|
gtk_object_set_data(PGtkObject(TabCloseBtnWidget),'TabCloseBtnImage',
|
|
TabCloseBtnImageWidget);
|
|
gtk_widget_show(TabCloseBtnImageWidget);
|
|
gtk_container_add(PGtkContainer(TabCloseBtnWidget),
|
|
TabCloseBtnImageWidget);
|
|
gtk_widget_show(TabCloseBtnWidget);
|
|
g_signal_connect(PGtkObject(TabCloseBtnWidget), 'clicked',
|
|
TGTKSignalFunc(@gtkNoteBookCloseBtnClicked), APage);
|
|
gtk_box_pack_start(PGtkBox(TabWidget), TabCloseBtnWidget, False, False, 0);
|
|
end;
|
|
end else begin
|
|
// close buttons disabled
|
|
if TabCloseBtnWidget<>nil then begin
|
|
// there is a close button
|
|
// -> remove it
|
|
gtk_object_set_data(PGtkObject(TabWidget), 'TabCloseBtn',
|
|
nil);
|
|
DestroyWidget(TabCloseBtnWidget);
|
|
TabCloseBtnWidget:=nil;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
ThePage := TCustomPage(APage);
|
|
TheNoteBook := TCustomTabControl(ANoteBook);
|
|
if (APage=nil) or (not ThePage.HandleAllocated) then exit;
|
|
if TheNoteBook=nil then begin
|
|
TheNoteBook:=TCustomTabControl(ThePage.Parent);
|
|
if TheNoteBook=nil then exit;
|
|
end;
|
|
NoteBookWidget:=PGtkWidget(TWinControl(TheNoteBook).Handle);
|
|
PageWidget:=PGtkWidget(TWinControl(ThePage).Handle);
|
|
|
|
// get the tab container and the tab components: pixmap, label and closebtn
|
|
TabWidget:=gtk_notebook_get_tab_label(PGtkNoteBook(NotebookWidget),
|
|
PageWidget);
|
|
if TabWidget=nil then exit;
|
|
|
|
TabImageWidget:=gtk_object_get_data(PGtkObject(TabWidget), 'TabImage');
|
|
TabLabelWidget:=gtk_object_get_data(PGtkObject(TabWidget), 'TabLabel');
|
|
TabCloseBtnWidget:=gtk_object_get_data(PGtkObject(TabWidget),'TabCloseBtn');
|
|
|
|
// get the menu container and its components: pixmap and label
|
|
MenuWidget:=gtk_notebook_get_menu_label(PGtkNoteBook(NotebookWidget),
|
|
PageWidget);
|
|
if MenuWidget<>nil then begin
|
|
MenuImageWidget:=gtk_object_get_data(PGtkObject(MenuWidget), 'TabImage');
|
|
MenuLabelWidget:=gtk_object_get_data(PGtkObject(MenuWidget), 'TabLabel');
|
|
end else begin
|
|
MenuImageWidget:=nil;
|
|
MenuLabelWidget:=nil;
|
|
end;
|
|
|
|
UpdateTabImage;
|
|
UpdateTabLabel;
|
|
UpdateTabCloseBtn;
|
|
end;
|
|
|
|
|
|
{-------------------------------------------------------------------------------
|
|
GetWidgetScreenPos
|
|
|
|
Returns the absolute left top position of a widget on the screen.
|
|
-------------------------------------------------------------------------------}
|
|
function GetWidgetOrigin(TheWidget: PGtkWidget): TPoint;
|
|
var
|
|
TheWindow: PGdkWindow;
|
|
{$IFDEF RaiseExceptionOnNilPointers}
|
|
LCLObject: TObject;
|
|
{$ENDIF}
|
|
begin
|
|
TheWindow:=GetControlWindow(TheWidget);
|
|
if TheWindow<>nil then begin
|
|
BeginGDKErrorTrap;
|
|
gdk_window_get_origin(TheWindow,@Result.X,@Result.Y);
|
|
EndGDKErrorTrap;
|
|
end else begin
|
|
{$IFDEF RaiseExceptionOnNilPointers}
|
|
LCLobject:=GetLCLObject(TheWidget);
|
|
DbgOut('GetWidgetOrigin ');
|
|
if LCLObject=nil then
|
|
DbgOut(' LCLObject=nil')
|
|
else if LCLObject is TControl then
|
|
DbgOut(' LCLObject=',TControl(LCLObject).Name,':',TControl(LCLObject).ClassName)
|
|
else
|
|
DbgOut(' LCLObject=',TControl(LCLObject).ClassName);
|
|
DebugLn('');
|
|
RaiseException('GetWidgetOrigin Window=nil');
|
|
{$ENDIF}
|
|
Result.X:=0;
|
|
Result.Y:=0;
|
|
end;
|
|
// check if the gdkwindow is the clientwindow of the parent
|
|
if (TheWidget^.Parent<>nil) and (gtk_widget_get_parent_window(TheWidget)=TheWindow) then begin
|
|
// the widget is using its parent window
|
|
// -> adjust the coordinates
|
|
inc(Result.X,TheWidget^.Allocation.X);
|
|
inc(Result.Y,TheWidget^.Allocation.Y);
|
|
end;
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
GetWidgetClientScreenPos
|
|
|
|
Returns the absolute left top position of a widget's client area
|
|
on the screen.
|
|
-------------------------------------------------------------------------------}
|
|
function GetWidgetClientOrigin(TheWidget: PGtkWidget): TPoint;
|
|
|
|
{$IFDEF Gtk2}
|
|
procedure GetNoteBookClientOrigin(NBWidget: PGtkNotebook);
|
|
var
|
|
PageIndex: LongInt;
|
|
PageWidget: PGtkWidget;
|
|
ClientWidget: PGTKWidget;
|
|
FrameBorders: TRect;
|
|
begin
|
|
// get current page
|
|
PageIndex:=gtk_notebook_get_current_page(NBWidget);
|
|
if PageIndex>=0 then
|
|
PageWidget:=gtk_notebook_get_nth_page(NBWidget,PageIndex)
|
|
else
|
|
PageWidget:=nil;
|
|
|
|
// get client widget of page
|
|
if (PageWidget<>nil) then
|
|
ClientWidget:=GetFixedWidget(PageWidget)
|
|
else
|
|
ClientWidget:=nil;
|
|
|
|
// Be careful while using ClientWidget here, it may be nil
|
|
if (ClientWidget<>nil) and (ClientWidget^.window<>nil) then
|
|
begin
|
|
// get the position of the current page
|
|
gdk_window_get_origin(ClientWidget^.window,@Result.X,@Result.Y);
|
|
if GTK_WIDGET_NO_WINDOW(ClientWidget)
|
|
then begin
|
|
Inc(Result.X, ClientWidget^.Allocation.X);
|
|
Inc(Result.Y, ClientWidget^.Allocation.Y);
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
// use defaults
|
|
Result:=GetWidgetOrigin(TheWidget);
|
|
FrameBorders:=GetStyleNotebookFrameBorders;
|
|
GetWidgetClientOrigin.x:=Result.x+FrameBorders.Left;
|
|
GetWidgetClientOrigin.y:=Result.y+FrameBorders.Top;
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
var
|
|
ClientWidget: PGtkWidget;
|
|
ClientWindow: PGdkWindow;
|
|
begin
|
|
ClientWidget := GetFixedWidget(TheWidget);
|
|
if ClientWidget <> TheWidget then
|
|
begin
|
|
ClientWindow := GetControlWindow(ClientWidget);
|
|
if ClientWindow <> nil then
|
|
begin
|
|
{$IFDEF DebugGDK}
|
|
BeginGDKErrorTrap;
|
|
{$ENDIF}
|
|
gdk_window_get_origin(ClientWindow, @Result.X, @Result.Y);
|
|
{$Ifdef GTK2}
|
|
if GTK_WIDGET_NO_WINDOW(ClientWidget) then
|
|
begin
|
|
Inc(Result.X, ClientWidget^.Allocation.X);
|
|
Inc(Result.Y, ClientWidget^.Allocation.Y);
|
|
end;
|
|
{$EndIf}
|
|
{$IFDEF DebugGDK}
|
|
EndGDKErrorTrap;
|
|
{$ENDIF}
|
|
exit;
|
|
end;
|
|
{$IFDEF Gtk2}
|
|
end
|
|
else
|
|
if GtkWidgetIsA(TheWidget,GTK_TYPE_NOTEBOOK) then
|
|
begin
|
|
GetNoteBookClientOrigin(PGtkNoteBook(TheWidget));
|
|
Exit;
|
|
{$ENDIF}
|
|
end;
|
|
Result := GetWidgetOrigin(TheWidget);
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
TranslateGdkPointToClientArea
|
|
|
|
Translates SourcePos relative to SourceWindow to a coordinate relative to the
|
|
client area of the LCL WinControl.
|
|
-------------------------------------------------------------------------------}
|
|
function TranslateGdkPointToClientArea(SourceWindow: PGdkWindow;
|
|
SourcePos: TPoint; DestinationWidget: PGtkWidget): TPoint;
|
|
var
|
|
SrcWindowOrigin: TPoint;
|
|
ClientAreaWindowOrigin: TPoint;
|
|
Src2ClientAreaVector: TPoint;
|
|
begin
|
|
if SourceWindow = nil then
|
|
begin
|
|
{$IFDEF RaiseExceptionOnNilPointers}
|
|
RaiseException('TranslateGdkPointToClientArea Window=nil');
|
|
{$ENDIF}
|
|
DebugLn('WARNING: TranslateGdkPointToClientArea SourceWindow=nil');
|
|
end;
|
|
gdk_window_get_origin(SourceWindow, @SrcWindowOrigin.X, @SrcWindowOrigin.Y);
|
|
|
|
ClientAreaWindowOrigin := GetWidgetClientOrigin(DestinationWidget);
|
|
Src2ClientAreaVector.X := ClientAreaWindowOrigin.X - SrcWindowOrigin.X;
|
|
Src2ClientAreaVector.Y := ClientAreaWindowOrigin.Y - SrcWindowOrigin.Y;
|
|
Result.X := SourcePos.X - Src2ClientAreaVector.X;
|
|
Result.Y := SourcePos.Y - Src2ClientAreaVector.Y;
|
|
end;
|
|
|
|
function SubtractScoll(AWidget: PGtkWidget; APosition: TPoint): TPoint;
|
|
begin
|
|
Result := APosition;
|
|
AWidget := gtk_object_get_data(PGTKObject(AWidget), odnScrollArea);
|
|
if GTK_IS_SCROLLED_WINDOW(AWidget) then
|
|
begin
|
|
with gtk_scrolled_window_get_hadjustment(PGtkScrolledWindow(AWidget))^ do
|
|
dec(Result.x, Trunc(value - lower));
|
|
with gtk_scrolled_window_get_vadjustment(PGtkScrolledWindow(AWidget))^ do
|
|
dec(Result.y, Trunc(value - lower));
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Function: UpdateMouseCaptureControl
|
|
Params: none
|
|
Returns: none
|
|
|
|
Sets MouseCaptureWidget to the current capturing widget.
|
|
------------------------------------------------------------------------------}
|
|
procedure UpdateMouseCaptureControl;
|
|
var
|
|
OldMouseCaptureWidget,
|
|
CurMouseCaptureWidget: PGtkWidget;
|
|
begin
|
|
OldMouseCaptureWidget:=MouseCaptureWidget;
|
|
CurMouseCaptureWidget:=gtk_grab_get_current;
|
|
|
|
if OldMouseCaptureWidget<>CurMouseCaptureWidget then begin
|
|
// the mouse grab changed
|
|
// -> this means the gtk itself has changed the mouse grab
|
|
{$IFDEF VerboseMouseCapture}
|
|
DebugLn('UpdateMouseCaptureControl Capture changed from ',
|
|
'[',GetWidgetDebugReport(OldMouseCaptureWidget),' type=',MouseCaptureTypeNames[MouseCaptureType],']',
|
|
' to [',GetWidgetDebugReport(CurMouseCaptureWidget),' type=GTK]');
|
|
if CurMouseCaptureWidget<>nil then
|
|
DebugLn('parent ', GetWidgetDebugReport(CurMouseCaptureWidget^.Parent));
|
|
{$ENDIF}
|
|
|
|
// notify the new capture control
|
|
MouseCaptureWidget:=CurMouseCaptureWidget;
|
|
MouseCaptureType:=mctGTK;
|
|
if MouseCaptureWidget<>nil then begin
|
|
// the MouseCaptureWidget is probably not a main widget
|
|
SendMessage(HWnd(PtrUInt(MouseCaptureWidget)), LM_CAPTURECHANGED, 0,
|
|
HWnd(PtrUInt(OldMouseCaptureWidget)));
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure IncreaseMouseCaptureIndex;
|
|
begin
|
|
if MouseCaptureIndex<$ffffffff then
|
|
inc(MouseCaptureIndex)
|
|
else
|
|
MouseCaptureIndex:=0;
|
|
end;
|
|
|
|
procedure CaptureMouseForWidget(Widget: PGtkWidget; Owner: TMouseCaptureType);
|
|
var
|
|
CaptureWidget: PGtkWidget;
|
|
NowIndex: Cardinal;
|
|
begin
|
|
{$IFDEF VerboseMouseCapture}
|
|
DebugLn('CaptureMouseForWidget START ',GetWidgetDebugReport(Widget));
|
|
{$ENDIF}
|
|
if not (Owner in [mctGTKIntf,mctLCL]) then exit;
|
|
// not every widget can capture the mouse
|
|
CaptureWidget:=GetDefaultMouseCaptureWidget(Widget);
|
|
if CaptureWidget=nil then exit;
|
|
|
|
UpdateMouseCaptureControl;
|
|
if (MouseCaptureType<>mctGTK) then begin
|
|
// we are capturing
|
|
if (MouseCaptureWidget=CaptureWidget) then begin
|
|
// we are already capturing this widget
|
|
exit;
|
|
end;
|
|
// release old capture
|
|
ReleaseMouseCapture;
|
|
end;
|
|
|
|
{$IFDEF VerboseMouseCapture}
|
|
DebugLn('CaptureMouseForWidget Start Capturing for ',GetWidgetDebugReport(CaptureWidget));
|
|
{$ENDIF}
|
|
IncreaseMouseCaptureIndex;
|
|
NowIndex:=MouseCaptureIndex;
|
|
if not gtk_widget_has_focus(CaptureWidget) then
|
|
gtk_widget_grab_focus(CaptureWidget);
|
|
if NowIndex=MouseCaptureIndex then begin
|
|
{$IFDEF VerboseMouseCapture}
|
|
DebugLn('CaptureMouseForWidget Commit Capturing for ',GetWidgetDebugReport(CaptureWidget));
|
|
{$ENDIF}
|
|
MouseCaptureWidget:=CaptureWidget;
|
|
MouseCaptureType:=Owner;
|
|
gtk_grab_add(CaptureWidget);
|
|
end;
|
|
end;
|
|
|
|
function GetDefaultMouseCaptureWidget(Widget: PGtkWidget
|
|
): PGtkWidget;
|
|
var
|
|
WidgetInfo: PWinWidgetInfo;
|
|
LCLObject: TObject;
|
|
begin
|
|
Result:=nil;
|
|
if Widget=nil then exit;
|
|
if GtkWidgetIsA(Widget,GTKAPIWidget_Type) then begin
|
|
WidgetInfo:=GetWidgetInfo(Widget,false);
|
|
if WidgetInfo<>nil then
|
|
Result:=WidgetInfo^.CoreWidget;
|
|
exit;
|
|
end;
|
|
LCLObject:=GetNearestLCLObject(Widget);
|
|
if LCLObject=nil then exit;
|
|
if (TWinControl(LCLObject) is TCustomSplitter) and (TWinControl(LCLObject).HandleAllocated)
|
|
then begin
|
|
WidgetInfo:=GetWidgetInfo(PGtkWidget(TWinControl(LCLObject).Handle),false);
|
|
if WidgetInfo<>nil then
|
|
Result:=WidgetInfo^.CoreWidget;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure ReleaseMouseCapture;
|
|
|
|
If the current mouse capture was captured by the LCL or the gtk intf, release
|
|
the capture. Don't release mouse captures of the gtk, because captures must
|
|
be balanced and this is already done by the gtk.
|
|
------------------------------------------------------------------------------}
|
|
procedure ReleaseMouseCapture;
|
|
var
|
|
OldMouseCaptureWidget: PGtkWidget;
|
|
Info: PWidgetInfo;
|
|
begin
|
|
{$IFDEF VerboseMouseCapture}
|
|
DebugLn('ReleaseMouseCapture ',dbgs(ord(MouseCaptureType)),' MouseCaptureWidget=[',GetWidgetDebugReport(MouseCaptureWidget),']');
|
|
{$ENDIF}
|
|
if MouseCaptureType=mctGTK then
|
|
begin
|
|
Info := GetWidgetInfo(gtk_grab_get_current, false);
|
|
if (Info <> nil) and (Info^.CoreWidget <> nil) then
|
|
begin
|
|
if GtkWidgetIsA(Info^.CoreWidget, gtk_list_get_type) then
|
|
begin
|
|
// Paul Ishenin:
|
|
// listbox grabs pointer and other control for itself, when we click on listbox item
|
|
// also it changes its state to drag_selection
|
|
// this is not expected in LCL and as result cause bugs, such as 7892
|
|
// so we need end drag selection manually
|
|
OldMouseCaptureWidget := Info^.CoreWidget;
|
|
gtk_list_end_drag_selection(PGtkList(OldMouseCaptureWidget));
|
|
end;
|
|
end;
|
|
exit;
|
|
end;
|
|
OldMouseCaptureWidget:=MouseCaptureWidget;
|
|
MouseCaptureWidget:=nil;
|
|
MouseCaptureType:=mctGTK;
|
|
if OldMouseCaptureWidget<>nil then
|
|
gtk_grab_remove(OldMouseCaptureWidget);
|
|
// tell the LCL
|
|
SetCaptureControl(nil);
|
|
end;
|
|
|
|
procedure ReleaseCaptureWidget(Widget : PGtkWidget);
|
|
begin
|
|
if (Widget=nil)
|
|
or ((MouseCaptureWidget<>Widget) and (MouseCaptureWidget<>Widget^.parent))
|
|
then
|
|
exit;
|
|
DebugLn('ReleaseCaptureWidget ',GetWidgetDebugReport(Widget));
|
|
ReleaseMouseCapture;
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
procedure: SignalConnect
|
|
Params: AWidget: PGTKWidget
|
|
ASignal: PChar
|
|
AProc: Pointer
|
|
AInfo: PWidgetInfo
|
|
Returns: Nothing
|
|
|
|
Connects a gtk signal handler.
|
|
This is a wrapper to get around gtk casting
|
|
-------------------------------------------------------------------------------}
|
|
procedure SignalConnect(const AWidget: PGTKWidget; const ASignal: PChar;
|
|
const AProc: Pointer; const AInfo: PWidgetInfo);
|
|
begin
|
|
g_signal_connect(PGtkObject(AWidget), ASignal, TGTKSignalFunc(AProc), AInfo);
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
procedure: SignalConnectAfter
|
|
Params: AWidget: PGTKWidget
|
|
ASignal: PChar
|
|
AProc: Pointer
|
|
AInfo: PGtkWSWidgetInfo
|
|
Returns: Nothing
|
|
|
|
Connects a gtk signal after handler.
|
|
This is a wrapper to get around gtk casting
|
|
-------------------------------------------------------------------------------}
|
|
procedure SignalConnectAfter(const AWidget:PGTKWidget; const ASignal: PChar;
|
|
const AProc: Pointer; const AInfo: PWidgetInfo);
|
|
begin
|
|
g_signal_connect_after(PGTKObject(AWidget), ASignal, TGTKSignalFunc(AProc), AInfo);
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
procedure ConnectSignal(const AnObject:PGTKObject; const ASignal: PChar;
|
|
const ACallBackProc: Pointer; const ReqSignalMask: TGdkEventMask;
|
|
Flags: TConnectSignalFlags);
|
|
|
|
Connects a gtk signal handler.
|
|
-------------------------------------------------------------------------------}
|
|
procedure InitDesignSignalMasks;
|
|
var
|
|
SignalType: TDesignSignalType;
|
|
begin
|
|
DesignSignalMasks[dstUnknown]:=0;
|
|
for SignalType:=Low(TDesignSignalType) to High(TDesignSignalType) do
|
|
DesignSignalMasks[SignalType]:=1 shl ord(SignalType);
|
|
end;
|
|
|
|
function DesignSignalNameToType(Name: PChar; After: boolean): TDesignSignalType;
|
|
begin
|
|
for Result:=Low(TDesignSignalType) to High(TDesignSignalType) do
|
|
if SamePChar(DesignSignalNames[Result],Name)
|
|
and (DesignSignalAfter[Result]=After) then exit;
|
|
Result:=dstUnknown;
|
|
end;
|
|
|
|
function GetDesignSignalMask(Widget: PGtkWidget): TDesignSignalMask;
|
|
begin
|
|
Result:=TDesignSignalMask(PtrUInt(gtk_object_get_data(PGtkObject(Widget),
|
|
'LCLDesignMask')));
|
|
end;
|
|
|
|
procedure SetDesignSignalMask(Widget: PGtkWidget; NewMask: TDesignSignalMask);
|
|
begin
|
|
gtk_object_set_data(PGtkObject(Widget),'LCLDesignMask',Pointer(PtrInt(NewMask)));
|
|
end;
|
|
|
|
function GetDesignOnlySignalFlag(Widget: PGtkWidget;
|
|
DesignSignalType: TDesignSignalType): boolean;
|
|
begin
|
|
Result:=(GetDesignSignalMask(Widget)
|
|
and DesignSignalMasks[DesignSignalType])<>0;
|
|
end;
|
|
|
|
function SignalConnected(const AnObject:PGTKObject; const ASignal: PChar;
|
|
const ACallBackProc: Pointer; const ALCLObject: TObject;
|
|
const ASFlags: TConnectSignalFlags): boolean;
|
|
{$IFDEF Gtk1}
|
|
var
|
|
Handler: PGTKHandler;
|
|
SignalID: guint;
|
|
begin
|
|
Handler := gtk_object_get_data_by_id (AnObject, gtk_handler_quark);
|
|
SignalID := g_signal_lookup(ASignal, GTK_OBJECT_TYPE(AnObject));
|
|
if SignalID>$ffffff then
|
|
RaiseGDBException('SignalConnected');
|
|
|
|
while (Handler <> nil) do begin
|
|
with Handler^ do
|
|
begin
|
|
// check if signal is already connected
|
|
//debugln('ConnectSignal Id=',dbgs(Id));
|
|
if (Id > 0)
|
|
and (Signal_ID = SignalID)
|
|
and (Func = TGTKSignalFunc(ACallBackProc))
|
|
and (func_data = Pointer(ALCLObject))
|
|
and (((flags and bmSignalAfter)<>0)=(csfAfter in ASFlags))
|
|
then begin
|
|
// signal is already connected
|
|
Result:=true;
|
|
Exit;
|
|
end;
|
|
|
|
Handler := Next;
|
|
end;
|
|
end;
|
|
Result:=false;
|
|
end;
|
|
{$ELSE}
|
|
begin
|
|
Result:=g_signal_handler_find(AnObject,
|
|
G_SIGNAL_MATCH_FUNC or G_SIGNAL_MATCH_DATA,
|
|
0,0,nil,ACallBackProc,ALCLObject)<>0;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
procedure ConnectSignal(const AnObject:PGTKObject; const ASignal: PChar;
|
|
const ACallBackProc: Pointer; const ALCLObject: TObject;
|
|
const AReqSignalMask: TGdkEventMask; const ASFlags: TConnectSignalFlags);
|
|
var
|
|
WinWidgetInfo: PWinWidgetInfo;
|
|
MainWidget: PGtkWidget;
|
|
OldDesignMask, NewDesignMask: TDesignSignalMask;
|
|
DesignSignalType: TDesignSignalType;
|
|
RealizeConnected: Boolean;
|
|
HasRealizeSignal: Boolean;
|
|
begin
|
|
if ACallBackProc = nil then
|
|
RaiseGDBException('ConnectSignal');
|
|
|
|
// first loop through the handlers to:
|
|
// - check if a handler already exists
|
|
// - Find the realize handler to change data
|
|
DesignSignalType:=DesignSignalNameToType(ASignal,csfAfter in ASFlags);
|
|
if SignalConnected(AnObject,ASignal,ACallBackProc,ALCLObject,ASFlags) then
|
|
begin
|
|
// signal is already connected
|
|
// update the DesignSignalMask
|
|
if (DesignSignalType <> dstUnknown)
|
|
and (not (csfDesignOnly in ASFlags))
|
|
then begin
|
|
OldDesignMask := GetDesignSignalMask(PGtkWidget(AnObject));
|
|
NewDesignMask :=OldDesignMask and not DesignSignalMasks[DesignSignalType];
|
|
if OldDesignMask <> NewDesignMask
|
|
then SetDesignSignalMask(PGtkWidget(AnObject),NewDesignMask);
|
|
end;
|
|
Exit;
|
|
end;
|
|
|
|
// if we are here, then no handler was defined yet
|
|
// -> register handler
|
|
//if (Msg=LM_LBUTTONUP) then DebugLn('CONNECT ',ReqSignalMask,' Widget=',DbgS(AnObject));
|
|
//debugln('ConnectSignal ',DbgSName(ALCLObject),' ',ASignal,' After=',dbgs(csfAfter in ASFlags));
|
|
if csfAfter in ASFlags then
|
|
g_signal_connect_after(AnObject, ASignal,
|
|
TGTKSignalFunc(ACallBackProc), ALCLObject)
|
|
else
|
|
g_signal_connect (AnObject, ASignal,
|
|
TGTKSignalFunc(ACallBackProc), ALCLObject);
|
|
|
|
// update signal mask which will be set in the realize handler
|
|
if (csfUpdateSignalMask in ASFlags) and (AReqSignalMask <> 0)
|
|
then begin
|
|
MainWidget := GetMainWidget(PGtkWidget(AnObject));
|
|
if MainWidget=nil
|
|
then MainWidget := PGtkWidget(AnObject);
|
|
WinWidgetInfo := GetWidgetInfo(MainWidget,true);
|
|
WinWidgetInfo^.EventMask := WinWidgetInfo^.EventMask or AReqSignalMask;
|
|
end;
|
|
|
|
// -> register realize handler
|
|
if (csfConnectRealize in ASFlags) then begin
|
|
HasRealizeSignal:=g_signal_lookup('realize', GTK_OBJECT_TYPE(AnObject))>0;
|
|
if HasRealizeSignal then begin
|
|
RealizeConnected:=SignalConnected(AnObject,'realize',@GTKRealizeCB,
|
|
ALCLObject,[]);
|
|
if not RealizeConnected then begin
|
|
g_signal_connect(AnObject, 'realize',
|
|
TGTKSignalFunc(@GTKRealizeCB), ALCLObject);
|
|
g_signal_connect_after(AnObject, 'realize',
|
|
TGTKSignalFunc(@GTKRealizeAfterCB), ALCLObject);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
// update the DesignSignalMask
|
|
if (DesignSignalType <> dstUnknown)
|
|
then begin
|
|
OldDesignMask:=GetDesignSignalMask(PGtkWidget(AnObject));
|
|
if csfDesignOnly in ASFlags then
|
|
NewDesignMask:=OldDesignMask or DesignSignalMasks[DesignSignalType]
|
|
else
|
|
NewDesignMask:=OldDesignMask and not DesignSignalMasks[DesignSignalType];
|
|
if OldDesignMask<>NewDesignMask then
|
|
SetDesignSignalMask(PGtkWidget(AnObject),NewDesignMask);
|
|
end;
|
|
end;
|
|
|
|
procedure ConnectSignal(const AnObject:PGTKObject; const ASignal: PChar;
|
|
const ACallBackProc: Pointer; const ALCLObject: TObject;
|
|
const AReqSignalMask: TGdkEventMask);
|
|
begin
|
|
ConnectSignal(AnObject,ASignal,ACallBackProc, ALCLObject, AReqSignalMask,
|
|
[csfConnectRealize,csfUpdateSignalMask]);
|
|
end;
|
|
|
|
procedure ConnectSignalAfter(const AnObject:PGTKObject; const ASignal: PChar;
|
|
const ACallBackProc: Pointer; const ALCLObject: TObject;
|
|
const AReqSignalMask: TGdkEventMask);
|
|
begin
|
|
ConnectSignal(AnObject,ASignal,ACallBackProc, ALCLObject, AReqSignalMask,
|
|
[csfConnectRealize,csfUpdateSignalMask,csfAfter]);
|
|
end;
|
|
|
|
procedure ConnectSignal(const AnObject:PGTKObject; const ASignal: PChar;
|
|
const ACallBackProc: Pointer; const ALCLObject: TObject);
|
|
begin
|
|
ConnectSignal(AnObject,ASignal,ACallBackProc, ALCLObject, 0);
|
|
end;
|
|
|
|
procedure ConnectSignalAfter(const AnObject:PGTKObject; const ASignal: PChar;
|
|
const ACallBackProc: Pointer; const ALCLObject: TObject);
|
|
begin
|
|
ConnectSignalAfter(AnObject,ASignal,ACallBackProc, ALCLObject, 0);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure: ConnectInternalWidgetsSignals
|
|
Params: AWidget: PGtkWidget; AWinControl: TWinControl
|
|
Returns: Nothing
|
|
|
|
Connects hidden child widgets signals.
|
|
Many gtk widgets create internally child widgets (e.g. scrollbars). In
|
|
Design mode these widgets should not auto react themselves, but instead send
|
|
messages to the lcl. Therefore these widgets are connected also to our
|
|
signal handlers.
|
|
This procedure is called by the realize-after handler of all LCL widgets
|
|
and each time the design mode of a LCL control changes.
|
|
------------------------------------------------------------------------------}
|
|
procedure ConnectInternalWidgetsSignals(AWidget: PGtkWidget;
|
|
AWinControl: TWinControl);
|
|
|
|
function WidgetIsInternal(TheWidget: PGtkWidget): boolean;
|
|
begin
|
|
Result:=(TheWidget<>nil)
|
|
and (PGtkWidget(AWinControl.Handle)<>TheWidget)
|
|
and (GetMainWidget(TheWidget)=nil);
|
|
end;
|
|
|
|
procedure ConnectSignals(TheWidget: PGtkWidget); forward;
|
|
|
|
procedure ConnectChilds(TheWidget: PGtkWidget);
|
|
var
|
|
ScrolledWindow: PGtkScrolledWindow;
|
|
BinWidget: PGtkBin;
|
|
{$IFDEF Gtk2}
|
|
ChildEntry2: PGList;
|
|
{$ELSE}
|
|
ChildEntry: PGSList;
|
|
{$ENDIF}
|
|
ChildWidget: PGtkWidget;
|
|
begin
|
|
//if AWinControl is TListView then DebugLn('ConnectChilds A ',DbgS(TheWidget));
|
|
if GtkWidgetIsA(TheWidget,GTK_TYPE_CONTAINER) then begin
|
|
//if AWinControl is TListView then DebugLn('ConnectChilds B ');
|
|
// this is a container widget -> connect all children
|
|
{$IFDEF Gtk2}
|
|
ChildEntry2:=gtk_container_get_children(PGtkContainer(TheWidget));
|
|
while ChildEntry2<>nil do begin
|
|
ChildWidget:=PGtkWidget(ChildEntry2^.Data);
|
|
if ChildWidget<>TheWidget then
|
|
ConnectSignals(ChildWidget);
|
|
ChildEntry2:=ChildEntry2^.Next;
|
|
end;
|
|
{$ELSE}
|
|
ChildEntry:=PGtkContainer(TheWidget)^.resize_widgets;
|
|
while ChildEntry<>nil do begin
|
|
ChildWidget:=PGtkWidget(ChildEntry^.Data);
|
|
ConnectSignals(ChildWidget);
|
|
ChildEntry:=ChildEntry^.Next;
|
|
end;
|
|
{$endif}
|
|
end;
|
|
if GtkWidgetIsA(TheWidget,GTK_TYPE_BIN) then begin
|
|
//if AWinControl is TListView then DebugLn('ConnectChilds C ');
|
|
BinWidget:=PGtkBin(TheWidget);
|
|
ConnectSignals(BinWidget^.child);
|
|
end;
|
|
if GtkWidgetIsA(TheWidget,GTK_TYPE_SCROLLED_WINDOW) then begin
|
|
//if AWinControl is TListView then DebugLn('ConnectChilds D ');
|
|
ScrolledWindow:=PGtkScrolledWindow(TheWidget);
|
|
ConnectSignals(ScrolledWindow^.hscrollbar);
|
|
ConnectSignals(ScrolledWindow^.vscrollbar);
|
|
end;
|
|
if GtkWidgetIsA(TheWidget,GTK_TYPE_COMBO) then begin
|
|
//if AWinControl is TListView then DebugLn('ConnectChilds E ');
|
|
ConnectSignals(PGtkCombo(TheWidget)^.entry);
|
|
ConnectSignals(PGtkCombo(TheWidget)^.button);
|
|
end;
|
|
end;
|
|
|
|
procedure ConnectSignals(TheWidget: PGtkWidget);
|
|
var
|
|
LCLObject, HiddenLCLObject: TObject;
|
|
DesignSignalType: TDesignSignalType;
|
|
DesignFlags: TConnectSignalFlags;
|
|
begin
|
|
//if AWinControl is TListView then DebugLn('ConnectSignals A ',DbgS(TheWidget));
|
|
if TheWidget=nil then exit;
|
|
|
|
// check if TheWidget belongs to another LCL object
|
|
LCLObject:=GetLCLObject(TheWidget);
|
|
HiddenLCLObject:=GetHiddenLCLObject(TheWidget);
|
|
if (LCLObject<>nil) and (LCLObject<>AWinControl) then begin
|
|
exit;
|
|
end;
|
|
if (HiddenLCLObject<>nil) and (HiddenLCLObject<>AWinControl) then begin
|
|
exit;
|
|
end;
|
|
|
|
//if AWinControl is TListView then DebugLn('ConnectSignals B ',DbgS(TheWidget));
|
|
// connect signals needed for design mode:
|
|
for DesignSignalType:=Low(TDesignSignalType) to High(TDesignSignalType) do
|
|
begin
|
|
if DesignSignalType=dstUnknown then continue;
|
|
if (not DesignSignalBefore[DesignSignalType])
|
|
and (not DesignSignalAfter[DesignSignalType]) then
|
|
continue;
|
|
|
|
DesignFlags:=[csfDesignOnly];
|
|
if DesignSignalAfter[DesignSignalType] then
|
|
Include(DesignFlags,csfAfter);
|
|
ConnectSignal(PGtkObject(TheWidget),DesignSignalNames[DesignSignalType],
|
|
DesignSignalFuncs[DesignSignalType],AWinControl,0,
|
|
DesignFlags);
|
|
end;
|
|
|
|
if WidgetIsInternal(TheWidget) then
|
|
// mark widget as 'hidden' connected
|
|
SetHiddenLCLObject(TheWidget,AWinControl);
|
|
|
|
// connect recursively ...
|
|
ConnectChilds(TheWidget);
|
|
end;
|
|
|
|
begin
|
|
if (AWinControl=nil) or (AWidget=nil)
|
|
or (not (csDesigning in AWinControl.ComponentState)) then exit;
|
|
ConnectSignals(AWidget);
|
|
end;
|
|
|
|
// ----------------------------------------------------------------------
|
|
// The Accelgroup and AccelKey is needed by menus
|
|
// ----------------------------------------------------------------------
|
|
function GetAccelGroup(const Widget: PGtkWidget;
|
|
CreateIfNotExists: boolean): PGTKAccelGroup;
|
|
begin
|
|
Result := PGTKAccelGroup(gtk_object_get_data(PGtkObject(Widget),'AccelGroup'));
|
|
if (Result=nil) and CreateIfNotExists then begin
|
|
{$IFDEF VerboseAccelerator}
|
|
DebugLn('GetAccelGroup CREATING Widget=',DbgS(Widget),' CreateIfNotExists=',dbgs(CreateIfNotExists));
|
|
{$ENDIF}
|
|
Result:=gtk_accel_group_new;
|
|
SetAccelGroup(Widget,Result);
|
|
if GtkWidgetIsA(Widget,GTK_TYPE_WINDOW) then
|
|
ShareWindowAccelGroups(Widget);
|
|
end;
|
|
end;
|
|
|
|
procedure SetAccelGroup(const Widget: PGtkWidget;
|
|
const AnAccelGroup: PGTKAccelGroup);
|
|
begin
|
|
if (Widget = nil) then exit;
|
|
gtk_object_set_data(PGtkObject(Widget), 'AccelGroup', AnAccelGroup);
|
|
if AnAccelGroup<>nil then begin
|
|
// attach group to widget
|
|
{$IFDEF VerboseAccelerator}
|
|
DebugLn(['SetAccelGroup AnAccelGroup=',DbgS(AnAccelGroup),' IsMenu=',GtkWidgetIsA(Widget,GTK_TYPE_MENU)]);
|
|
{$ENDIF}
|
|
if GtkWidgetIsA(Widget,GTK_TYPE_MENU) then
|
|
gtk_menu_set_accel_group(PGtkMenu(Widget), AnAccelGroup)
|
|
else begin
|
|
{$IfDef GTK2}
|
|
Assert(GtkWidgetIsA(Widget,GTK_TYPE_WINDOW));
|
|
gtk_window_add_accel_group(GTK_WINDOW(widget), AnAccelGroup);
|
|
{$else}
|
|
gtk_accel_group_attach(AnAccelGroup, PGtkObject(Widget));
|
|
{$endif}
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure FreeAccelGroup(const Widget: PGtkWidget);
|
|
var
|
|
AccelGroup: PGTKAccelGroup;
|
|
begin
|
|
AccelGroup:=GetAccelGroup(Widget,false);
|
|
if AccelGroup<>nil then begin
|
|
{$IFDEF VerboseAccelerator}
|
|
DebugLn('FreeAccelGroup AccelGroup=',DbgS(AccelGroup));
|
|
{$ENDIF}
|
|
gtk_accel_group_unref(AccelGroup);
|
|
SetAccelGroup(Widget,nil);
|
|
end;
|
|
end;
|
|
|
|
procedure ShareWindowAccelGroups(AWindow: PGtkWidget);
|
|
|
|
procedure AttachUnique(TheWindow: PGtkWidget; TheAccelGroup: PGTKAccelGroup);
|
|
begin
|
|
{$IfDef GTK2}
|
|
if (TheWindow=nil) or (TheAccelGroup=nil)
|
|
or (TheAccelGroup^.acceleratables=nil)
|
|
or (g_slist_find(TheAccelGroup^.acceleratables, TheWindow)=nil)
|
|
then
|
|
exit;
|
|
gtk_window_add_accel_group(GTK_WINDOW(TheWindow), TheAccelGroup);
|
|
{$else}
|
|
if (TheAccelGroup=nil)
|
|
or ((TheAccelGroup^.attach_objects<>nil)
|
|
and (g_slist_find(TheAccelGroup^.attach_objects, TheWindow)<>nil))
|
|
then
|
|
exit;
|
|
gtk_accel_group_attach(TheAccelGroup, PGtkObject(TheWindow));
|
|
{$endif}
|
|
end;
|
|
|
|
var
|
|
TheForm, CurForm: TCustomForm;
|
|
i: integer;
|
|
TheAccelGroup, CurAccelGroup: PGTKAccelGroup;
|
|
CurWindow: PGtkWidget;
|
|
begin
|
|
TheForm:=TCustomForm(GetLCLObject(AWindow));
|
|
|
|
// check if visible TCustomForm (not frame)
|
|
if (TheForm=nil) or (not (TheForm is TCustomForm))
|
|
or (not TheForm.Visible) or (TheForm.Parent<>nil)
|
|
or (csDesigning in TheForm.ComponentState)
|
|
then
|
|
exit;
|
|
|
|
// check if modal form
|
|
if fsModal in TheForm.FormState then begin
|
|
// a modal form does not share accelerators
|
|
exit;
|
|
end;
|
|
|
|
// check if there is an accelerator group
|
|
TheAccelGroup:=GetAccelGroup(AWindow,false);
|
|
|
|
// this is a normal form
|
|
// -> share accelerators with all other visible normal forms
|
|
for i:=0 to Screen.FormCount-1 do begin
|
|
CurForm:=Screen.Forms[i];
|
|
if (CurForm=TheForm)
|
|
or (not CurForm.HandleAllocated)
|
|
or (not CurForm.Visible)
|
|
or (fsModal in CurForm.FormState)
|
|
or (CurForm.Parent<>nil)
|
|
or (csDesigning in CurForm.ComponentState)
|
|
then continue;
|
|
|
|
CurWindow:=PGtkWidget(CurForm.Handle);
|
|
CurAccelGroup:=GetAccelGroup(CurWindow,false);
|
|
{$IFDEF VerboseAccelerator}
|
|
DebugLn('ShareWindowAccelGroups ',TheForm.Name,':',TheForm.ClassName,
|
|
' <-> ',CurForm.Name,':',CurForm.ClassName);
|
|
{$ENDIF}
|
|
|
|
// cross connect
|
|
AttachUnique(CurWindow,TheAccelGroup);
|
|
AttachUnique(AWindow,CurAccelGroup);
|
|
end;
|
|
end;
|
|
|
|
procedure UnshareWindowAccelGroups(AWindow: PGtkWidget);
|
|
|
|
procedure Detach(TheWindow: PGtkWidget; TheAccelGroup: PGTKAccelGroup);
|
|
begin
|
|
{$IfDef GTK2}
|
|
if (TheWindow=nil) or (TheAccelGroup=nil)
|
|
or (TheAccelGroup^.acceleratables=nil)
|
|
or (g_slist_find(TheAccelGroup^.acceleratables, TheWindow)=nil)
|
|
then
|
|
exit;
|
|
gtk_window_remove_accel_group(GTK_WINDOW(TheWindow), TheAccelGroup);
|
|
{$else}
|
|
if (TheAccelGroup=nil)
|
|
or (TheAccelGroup^.attach_objects=nil)
|
|
or (g_slist_find(TheAccelGroup^.attach_objects, TheWindow)=nil)
|
|
then
|
|
exit;
|
|
gtk_accel_group_detach(TheAccelGroup, PGtkObject(TheWindow));
|
|
{$endif}
|
|
end;
|
|
|
|
var
|
|
TheForm, CurForm: TCustomForm;
|
|
i: integer;
|
|
TheAccelGroup, CurAccelGroup: PGTKAccelGroup;
|
|
CurWindow: PGtkWidget;
|
|
begin
|
|
TheForm:=TCustomForm(GetLCLObject(AWindow));
|
|
|
|
// check if TCustomForm
|
|
if (TheForm=nil) or (not (TheForm is TCustomForm))
|
|
then exit;
|
|
|
|
TheAccelGroup:=GetAccelGroup(AWindow,false);
|
|
|
|
// -> unshare accelerators with all other forms
|
|
for i:=0 to Screen.FormCount-1 do begin
|
|
CurForm:=Screen.Forms[i];
|
|
if (CurForm=TheForm)
|
|
or (not CurForm.HandleAllocated)
|
|
then continue;
|
|
|
|
CurWindow:=PGtkWidget(CurForm.Handle);
|
|
CurAccelGroup:=GetAccelGroup(CurWindow,false);
|
|
{$IFDEF VerboseAccelerator}
|
|
DebugLn('UnshareWindowAccelGroups ',TheForm.Name,':',TheForm.ClassName,
|
|
' <-> ',CurForm.Name,':',CurForm.ClassName);
|
|
{$ENDIF}
|
|
|
|
// unlink
|
|
Detach(CurWindow,TheAccelGroup);
|
|
Detach(AWindow,CurAccelGroup);
|
|
end;
|
|
end;
|
|
|
|
function GetAccelGroupForComponent(Component: TComponent;
|
|
CreateIfNotExists: boolean): PGTKAccelGroup;
|
|
var
|
|
Control: TControl;
|
|
MenuItem: TMenuItem;
|
|
Form: TCustomForm;
|
|
Menu: TMenu;
|
|
begin
|
|
Result:=nil;
|
|
if Component=nil then exit;
|
|
|
|
if Component is TMenuItem then begin
|
|
MenuItem:=TMenuItem(Component);
|
|
Menu:=MenuItem.GetParentMenu;
|
|
if (Menu=nil) or (Menu.Parent=nil) then exit;
|
|
{$IFDEF VerboseAccelerator}
|
|
DebugLn('GetAccelGroupForComponent A ',Component.Name,':',Component.ClassName);
|
|
{$ENDIF}
|
|
Result:=GetAccelGroupForComponent(Menu.Parent,CreateIfNotExists);
|
|
end else if Component is TControl then begin
|
|
Control:=TControl(Component);
|
|
while Control.Parent<>nil do Control:=Control.Parent;
|
|
if Control is TCustomForm then begin
|
|
Form:=TCustomForm(Control);
|
|
if Form.HandleAllocated then begin
|
|
Result:=GetAccelGroup(PGtkWidget(Form.Handle),CreateIfNotExists);
|
|
{$IFDEF VerboseAccelerator}
|
|
DebugLn('GetAccelGroupForComponent C ',Component.Name,':',Component.ClassName);
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
end;
|
|
{$IFDEF VerboseAccelerator}
|
|
DebugLn('GetAccelGroupForComponent END ',Component.Name,':',Component.ClassName,' Result=',DbgS(Result));
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function GetAccelKey(Widget: PGtkWidget): PAcceleratorKey;
|
|
begin
|
|
Result := PAcceleratorKey(gtk_object_get_data(PGtkObject(Widget),'AccelKey'));
|
|
end;
|
|
|
|
function SetAccelKey(const Widget: PGtkWidget;
|
|
Key: guint; Mods: TGdkModifierType; const Signal: string): PAcceleratorKey;
|
|
begin
|
|
if (Widget = nil) then exit(nil);
|
|
Result:=GetAccelKey(Widget);
|
|
if Result=nil then begin
|
|
if Key>0 then begin
|
|
New(Result);
|
|
FillChar(Result^,SizeOf(Result),0);
|
|
end;
|
|
end else begin
|
|
if Key=0 then begin
|
|
Dispose(Result);
|
|
Result:=nil;
|
|
end;
|
|
end;
|
|
if (Result<>nil) then begin
|
|
Result^.Key:=Key;
|
|
Result^.Mods:=Mods;
|
|
Result^.Signal:=Signal;
|
|
Result^.Realized:=false;
|
|
end;
|
|
{$IFDEF VerboseAccelerator}
|
|
DebugLn('SetAccelKey Widget=',DbgS(Widget),
|
|
' Key=',dbgs(Key),' Mods=',DbgS(Mods),
|
|
' Signal="',Signal,'" Result=',DbgS(Result));
|
|
{$ENDIF}
|
|
gtk_object_set_data(PGtkObject(Widget), 'AccelKey', Result);
|
|
end;
|
|
|
|
procedure ClearAccelKey(Widget: PGtkWidget);
|
|
begin
|
|
SetAccelKey(Widget,0,0,'');
|
|
end;
|
|
|
|
procedure RealizeAccelerator(Component: TComponent; Widget : PGtkWidget);
|
|
var
|
|
AccelKey: PAcceleratorKey;
|
|
AccelGroup: PGTKAccelGroup;
|
|
begin
|
|
if (Component=nil) or (Widget=nil) then
|
|
RaiseGDBException('RealizeAccelerate: invalid input');
|
|
|
|
// Set the accelerator
|
|
AccelKey:=GetAccelKey(Widget);
|
|
if (AccelKey=nil) or (AccelKey^.Realized) then exit;
|
|
|
|
if AccelKey^.Key>0 then begin
|
|
AccelGroup:=GetAccelGroupForComponent(Component,true);
|
|
if AccelGroup<>nil then begin
|
|
{$IFDEF VerboseAccelerator}
|
|
DebugLn('RealizeAccelerator Add Accelerator ',
|
|
Component.Name,':',Component.ClassName,
|
|
' Widget=',DbgS(Widget),
|
|
' Signal=',AccelKey^.Signal,
|
|
' Key=',dbgs(AccelKey^.Key),' Mods=',dbgs(AccelKey^.Mods),
|
|
'');
|
|
{$ENDIF}
|
|
gtk_widget_add_accelerator(Widget, PChar(AccelKey^.Signal),
|
|
AccelGroup, AccelKey^.Key, AccelKey^.Mods, GTK_ACCEL_VISIBLE);
|
|
AccelKey^.Realized:=true;
|
|
end else begin
|
|
AccelKey^.Realized:=false;
|
|
end;
|
|
end else begin
|
|
AccelKey^.Realized:=true;
|
|
end;
|
|
end;
|
|
|
|
procedure UnrealizeAccelerator(Widget : PGtkWidget);
|
|
var
|
|
AccelKey: PAcceleratorKey;
|
|
begin
|
|
if (Widget=nil) then
|
|
RaiseGDBException('UnrealizeAccelerate: invalid input');
|
|
|
|
AccelKey:=GetAccelKey(Widget);
|
|
if (AccelKey=nil) or (not AccelKey^.Realized) then exit;
|
|
|
|
if AccelKey^.Signal<>'' then begin
|
|
{$IFDEF VerboseAccelerator}
|
|
DebugLn('UnrealizeAccelerator ',
|
|
' Widget=',DbgS(Widget),
|
|
' Signal=',AccelKey^.Signal,
|
|
' Key=',dbgs(AccelKey^.Key),' Mods=',dbgs(AccelKey^.Mods),
|
|
'');
|
|
{$ENDIF}
|
|
{$Ifdef GTK2}
|
|
DebugLn('ToDo: gtkproc.inc UnrealizeAccelerator');
|
|
{$else}
|
|
gtk_widget_remove_accelerators(Widget, PChar(AccelKey^.Signal), false);
|
|
{$EndIf}
|
|
end;
|
|
AccelKey^.Realized:=false;
|
|
end;
|
|
|
|
procedure RegroupAccelerator(Widget: PGtkWidget);
|
|
begin
|
|
UnrealizeAccelerator(Widget);
|
|
RealizeAccelerator(TComponent(GetLCLObject(Widget)),Widget);
|
|
end;
|
|
|
|
procedure Accelerate(Component: TComponent; const Widget : PGtkWidget;
|
|
const Key: guint; Mods: TGdkModifierType; const Signal : string);
|
|
var
|
|
OldAccelKey: PAcceleratorKey;
|
|
begin
|
|
if (Component=nil) or (Widget=nil) or (Signal='') then
|
|
RaiseGDBException('Accelerate: invalid input');
|
|
{$IFDEF VerboseAccelerator}
|
|
DebugLn('Accelerate ',DbgSName(Component),' Key=',dbgs(Key),' Mods=',DbgS(Mods),' Signal=',Signal);
|
|
{$ENDIF}
|
|
|
|
// delete old accelerator key
|
|
OldAccelKey:=GetAccelKey(Widget);
|
|
if (OldAccelKey <> nil) then begin
|
|
if (OldAccelKey^.Key=Key) and (OldAccelKey^.Mods=Mods)
|
|
and (OldAccelKey^.Signal=Signal)
|
|
then begin
|
|
// no change
|
|
exit;
|
|
end;
|
|
|
|
UnrealizeAccelerator(Widget);
|
|
end;
|
|
|
|
// Set the accelerator
|
|
SetAccelKey(Widget,Key,Mods,Signal);
|
|
if (Key>0) and (not (csDesigning in Component.ComponentState))
|
|
then
|
|
RealizeAccelerator(Component,Widget);
|
|
end;
|
|
|
|
procedure Accelerate(Component: TComponent; const Widget : PGtkWidget;
|
|
const NewShortCut: TShortCut; const Signal : string);
|
|
var
|
|
GDKModifier: TGdkModifierType;
|
|
GDKKey: guint;
|
|
NewKey: word;
|
|
NewModifier: TShiftState;
|
|
Shift: TShiftStateEnum;
|
|
begin
|
|
{ Map the shift states }
|
|
GDKModifier := 0;
|
|
ShortCutToKey(NewShortCut, NewKey, NewModifier);
|
|
for Shift := Low(Shift) to High(Shift) do
|
|
begin
|
|
if Shift in NewModifier
|
|
then GDKModifier := GDKModifier or MModifiers[Shift].Mask;
|
|
end;
|
|
|
|
// Send the unmodified keysym ?
|
|
if (ssShift in NewModifier)
|
|
and ((NewKey < VK_F1) or (NewKey > VK_F24))
|
|
then GDKKey := GetVKeyInfo(NewKey).KeySym[1]
|
|
else GDKKey := GetVKeyInfo(NewKey).KeySym[0];
|
|
|
|
Accelerate(Component,Widget,GDKKey,GDKModifier,Signal);
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
method TGtkWidgetSet LoadPixbufFromLazResource
|
|
Params: const ResourceName: string;
|
|
var Pixbuf: PGdkPixbuf
|
|
Result: none
|
|
|
|
Loads a pixbuf from a lazarus resource. The resource must be a XPM file.
|
|
-------------------------------------------------------------------------------}
|
|
procedure LoadPixbufFromLazResource(const ResourceName: string;
|
|
var Pixbuf: PGdkPixbuf);
|
|
var
|
|
ImgData: PPChar;
|
|
begin
|
|
Pixbuf:=nil;
|
|
try
|
|
ImgData:=LazResourceXPMToPPChar(ResourceName);
|
|
except
|
|
on e: Exception do
|
|
DebugLn('WARNING: TGtkWidgetSet.LoadXPMFromLazResource: '+e.Message);
|
|
end;
|
|
{$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF}
|
|
{$IFDEF VerboseGdkPixbuf}
|
|
debugln('LoadPixbufFromLazResource A1');
|
|
{$ENDIF}
|
|
pixbuf:=gdk_pixbuf_new_from_xpm_data(ImgData);
|
|
{$IFDEF VerboseGdkPixbuf}
|
|
debugln('LoadPixbufFromLazResource A2');
|
|
{$ENDIF}
|
|
{$IFDEF DebugGDK}EndGDKErrorTrap;{$ENDIF}
|
|
FreeMem(ImgData);
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
method CreatePixbufFromDrawable
|
|
Params: ASource: The source drawable
|
|
AColorMap: The colormap to use, when nil a matching colormap is passed
|
|
AIncludeAplha: If set, the resulting pixmap has an alpha channel
|
|
ASrcX, ASrcY: Offset within the source
|
|
ADstX, ADstY: Offset within destination
|
|
AWidth, AHeight: Size of the new image
|
|
Result: New Pixbuf with refcount = 1
|
|
|
|
Replaces the gdk_pixbuf_get_from_drawable function which is buggy on big endian
|
|
X servers when an alpha channel is requested.
|
|
-------------------------------------------------------------------------------}
|
|
function CreatePixbufFromDrawable(ASource: PGdkDrawable; AColorMap:PGdkColormap; AIncludeAplha: Boolean; ASrcX, ASrcY, ADstX, ADstY, AWidth, AHeight: longint): PGdkPixbuf;
|
|
{$ifndef HasX}
|
|
const
|
|
CanRequestAlpha: Boolean = True;
|
|
var
|
|
{$else}
|
|
var
|
|
CanRequestAlpha: Boolean;
|
|
{$endif}
|
|
PixBuf: PGdkPixBuf;
|
|
{$ifdef Windows}
|
|
Image: PGdkImage;
|
|
{$endif}
|
|
begin
|
|
{$ifdef HasX}
|
|
CanRequestAlpha := BitmapBitOrder(gdk_display) = LSBFirst;
|
|
{$endif}
|
|
|
|
// If Source is GdkBitmap then gdk_pixbuf_get_from_drawable will get
|
|
// pixbuf with 2 colors: transparent and white, but we need only Black and White.
|
|
// If we all alpha at the end then problem is gone.
|
|
CanRequestAlpha := CanRequestAlpha and (gdk_drawable_get_depth(ASource) > 1);
|
|
|
|
if CanRequestAlpha and AIncludeAplha
|
|
then Pixbuf := gdk_pixbuf_new(GDK_COLORSPACE_RGB, True, 8, AWidth, AHeight)
|
|
else Pixbuf := nil;
|
|
|
|
// gtk1 requires always a colormap and fails when none passed
|
|
// gtk2 fails when the colormap depth is different than the drawable depth.
|
|
// It wil use the correct system map when none passed.
|
|
// Bitmaps (depth = 1) don't need a colormap
|
|
{$ifdef gtk1}
|
|
if AColormap = nil
|
|
then AColorMap := gdk_colormap_get_system;
|
|
{$else}
|
|
if (AColorMap = nil)
|
|
and (gdk_drawable_get_depth(ASource) > 1)
|
|
and (gdk_drawable_get_colormap(ASource) = nil)
|
|
then AColorMap := gdk_colormap_get_system;
|
|
{$endif}
|
|
{$ifdef Windows}
|
|
if gdk_drawable_get_depth(ASource) = 1 then
|
|
begin
|
|
// Fix gdk error in converter. For 1 bit Byte order is not significant
|
|
Image := gdk_drawable_get_image(ASource, ASrcX, ASrcY, AWidth, AHeight);
|
|
Image^.byte_order := GDK_MSB_FIRST;
|
|
Result := gdk_pixbuf_get_from_image(Pixbuf, Image, nil, ASrcX, ASrcY, ADstX, ADstY, AWidth, AHeight);
|
|
gdk_image_unref(Image);
|
|
end
|
|
else
|
|
{$endif}
|
|
Result := gdk_pixbuf_get_from_drawable(Pixbuf, ASource, AColorMap, ASrcX, ASrcY, ADstX, ADstY, AWidth, AHeight);
|
|
//DbgDumpPixbuf(Result, '');
|
|
|
|
if CanRequestAlpha then Exit; // we're done
|
|
if not AIncludeAplha then Exit;
|
|
|
|
pixbuf := gdk_pixbuf_add_alpha(Result, false, guchar(0),guchar(0),guchar(0));
|
|
gdk_pixbuf_unref(Result);
|
|
Result := pixbuf;
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
method LoadXPMFromLazResource
|
|
Params: const ResourceName: string;
|
|
Window: PGdkWindow;
|
|
var PixmapImg, PixmapMask: PGdkPixmap
|
|
Result: none
|
|
|
|
Loads a pixmap from a lazarus resource. The resource must be a XPM file.
|
|
-------------------------------------------------------------------------------}
|
|
procedure LoadXPMFromLazResource(const ResourceName: string;
|
|
Window: PGdkWindow; var PixmapImg, PixmapMask: PGdkPixmap);
|
|
var
|
|
ImgData: PPGChar;
|
|
begin
|
|
PixmapImg:=nil;
|
|
PixmapMask:=nil;
|
|
try
|
|
ImgData:=PPGChar(LazResourceXPMToPPChar(ResourceName));
|
|
except
|
|
on e: Exception do
|
|
DebugLn('WARNING: TGtkWidgetSet.LoadXPMFromLazResource: '+e.Message);
|
|
end;
|
|
{$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF}
|
|
PixmapImg:=gdk_pixmap_create_from_xpm_d(Window,PixmapMask,nil,ImgData);
|
|
{$IFDEF DebugGDK}EndGDKErrorTrap;{$ENDIF}
|
|
FreeMem(ImgData);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function MENU_ITEM_CLASS(widget: PGtkWidget): PGtkMenuItemClass;
|
|
|
|
Returns the gtk klass of a menuitem widget.
|
|
------------------------------------------------------------------------------}
|
|
function MENU_ITEM_CLASS(widget: PGtkWidget): PGtkMenuItemClass;
|
|
begin
|
|
Result:=GTK_MENU_ITEM_CLASS(gtk_object_get_class(widget));
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function CHECK_MENU_ITEM_CLASS(widget: PGtkWidget): PGtkCheckMenuItemClass;
|
|
|
|
Returns the gtk klass of a checkmenuitem widget.
|
|
------------------------------------------------------------------------------}
|
|
function CHECK_MENU_ITEM_CLASS(widget: PGtkWidget): PGtkCheckMenuItemClass;
|
|
begin
|
|
Result:=GTK_CHECK_MENU_ITEM_CLASS(gtk_object_get_class(widget));
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure LockRadioGroupOnChange(RadioGroup: PGSList; const ADelta: Integer);
|
|
|
|
Calls LockOnChange for all groupmembers
|
|
------------------------------------------------------------------------------}
|
|
procedure LockRadioGroupOnChange(RadioGroup: PGSList; const ADelta: Integer);
|
|
begin
|
|
while RadioGroup <> nil do
|
|
begin
|
|
if RadioGroup^.Data <> nil
|
|
then LockOnChange(PgtkObject(RadioGroup^.Data), ADelta);
|
|
RadioGroup := RadioGroup^.Next;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure UpdateRadioGroupChecks(RadioGroup: PGSList);
|
|
|
|
Set 'checked' for all menuitems in the group
|
|
------------------------------------------------------------------------------}
|
|
procedure UpdateRadioGroupChecks(RadioGroup: PGSList);
|
|
var
|
|
CurListItem: PGSList;
|
|
MenuItem: PGtkCheckMenuItem;
|
|
LCLMenuItem: TMenuItem;
|
|
begin
|
|
// Check if it is a single entry
|
|
if (RadioGroup = nil) or (RadioGroup^.Next = nil)
|
|
then Exit;
|
|
|
|
// Lock whole group for update
|
|
LockRadioGroupOnChange(RadioGroup, +1);
|
|
CurListItem := RadioGroup;
|
|
try
|
|
// set active radiomenuitem
|
|
while CurListItem <> nil do
|
|
begin
|
|
MenuItem := PGtkCheckMenuItem(CurListItem^.Data);
|
|
if MenuItem<>nil
|
|
then begin
|
|
LCLMenuItem := TMenuItem(GetLCLObject(MenuItem));
|
|
if (LCLMenuItem <> nil)
|
|
and (gtk_check_menu_item_get_active(MenuItem) <> LCLMenuItem.Checked)
|
|
then gtk_check_menu_item_set_active(MenuItem, LCLMenuItem.Checked);
|
|
end;
|
|
CurListItem := CurListItem^.Next;
|
|
end;
|
|
finally
|
|
// Unlock whole group for update
|
|
LockRadioGroupOnChange(RadioGroup, -1);
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure DrawMenuItemIcon(MenuItem: PGtkCheckMenuItem;
|
|
area: PGdkRectangle); cdecl;
|
|
|
|
Handler for drawing the icon of a menuitem.
|
|
------------------------------------------------------------------------------}
|
|
procedure DrawMenuItemIcon(MenuItem: PGtkCheckMenuItem;
|
|
Area: PGdkRectangle); cdecl;
|
|
var
|
|
Widget: PGtkWidget;
|
|
Container: PgtkContainer;
|
|
ALeft, ATop, BorderWidth: gint;
|
|
LCLMenuItem: TMenuItem;
|
|
AWindow: PGdkWindow;
|
|
IconWidth, IconHeight: integer;
|
|
IconSize: TPoint;
|
|
{$IFDEF Gtk2}
|
|
HorizPadding, ToggleSpacing: Integer;
|
|
{$ENDIF}
|
|
|
|
AEffect: TGraphicsDrawEffect;
|
|
AImageList: TCustomImageList;
|
|
FreeImageList: Boolean;
|
|
AImageIndex: Integer;
|
|
ItemBmp: TBitmap;
|
|
begin
|
|
if (MenuItem=nil) then
|
|
exit;
|
|
if not (GTK_WIDGET_DRAWABLE (PGtkWidget(MenuItem))) then
|
|
exit;
|
|
|
|
// get icon
|
|
LCLMenuItem:=TMenuItem(GetLCLObject(MenuItem));
|
|
if LCLMenuItem=nil then begin // needed for gtk2 dialog
|
|
if GtkWidgetIsA(PGtkWidget(MenuItem), gtk_check_menu_item_get_type) then
|
|
OldCheckMenuItemDrawProc(MenuItem, Area);
|
|
Exit;
|
|
end;
|
|
if not LCLMenuItem.HasIcon then
|
|
begin
|
|
// call default draw function
|
|
if LCLMenuItem.IsCheckItem then
|
|
OldCheckMenuItemDrawProc(MenuItem,Area);
|
|
exit;
|
|
end;
|
|
IconSize:=LCLMenuItem.GetIconSize(0);
|
|
IconWidth:=IconSize.X;
|
|
IconHeight:=IconSize.Y;
|
|
|
|
// calculate left and top
|
|
Widget := PGtkWidget(MenuItem);
|
|
AWindow:=GetControlWindow(Widget);
|
|
if AWindow = nil then
|
|
exit;
|
|
Container := GTK_CONTAINER (MenuItem);
|
|
BorderWidth := Container^.flag0 and bm_TGtkContainer_border_width;
|
|
|
|
{$IFDEF Gtk2}
|
|
gtk_widget_style_get(PGtkWidget(MenuItem),
|
|
'horizontal-padding', @HorizPadding,
|
|
'toggle-spacing', @ToggleSpacing,
|
|
nil);
|
|
|
|
ALeft := BorderWidth +
|
|
gtk_widget_get_xthickness(gtk_widget_get_style(Widget)) +
|
|
HorizPadding +
|
|
((PGtkMenuItem(MenuItem)^.toggle_size-ToggleSpacing-IconWidth) div 2);
|
|
|
|
if gtk_widget_get_direction(Widget) = GTK_TEXT_DIR_RTL then
|
|
ALeft := Widget^.Allocation.width - IconWidth - ALeft; //not sure it is the correct Width
|
|
{$ELSE}
|
|
ALeft := (BorderWidth + gtk_widget_get_xthickness(gtk_widget_get_style(Widget)) + 2)
|
|
+((PGtkMenuItem(MenuItem)^.toggle_size-IconWidth) div 2);
|
|
{$ENDIF}
|
|
|
|
ATop := (Widget^.Allocation.Height - IconHeight) div 2;
|
|
|
|
// draw icon
|
|
AImageList := LCLMenuItem.GetImageList;
|
|
if AImageList = nil then
|
|
begin
|
|
AImageList := TImageList.Create(nil);
|
|
// prevent multiple calls to GetBitmap;
|
|
ItemBmp := LCLMenuItem.Bitmap;
|
|
AImageList.Width := ItemBmp.Width; // maybe height to prevent too wide bitmaps?
|
|
AImageList.Height := ItemBmp.Height;
|
|
if ItemBmp.Masked
|
|
then AImageIndex := AImageList.AddMasked(ItemBmp, ItemBmp.TransparentColor)
|
|
else AImageIndex := AImageList.Add(ItemBmp, nil);
|
|
FreeImageList := True;
|
|
end
|
|
else
|
|
begin
|
|
FreeImageList := False;
|
|
AImageIndex := LCLMenuItem.ImageIndex;
|
|
end;
|
|
|
|
if not LCLMenuItem.Enabled then
|
|
AEffect := gdeDisabled
|
|
else
|
|
AEffect := gdeNormal;
|
|
|
|
if AImageIndex < AImageList.Count then
|
|
{$IFDEF VerboseGtkToDos}{$note reimplement}{$ENDIF}
|
|
DrawImageListIconOnWidget(AImageList, AImageIndex, AEffect,
|
|
Widget, false, false, ALeft, ATop);
|
|
|
|
if FreeImageList then
|
|
AImageList.Free;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure MenuSizeRequest(widget:PGtkWidget;
|
|
requisition:PGtkRequisition); cdecl;
|
|
|
|
SizeAllocate Handler for check menuitem widgets.
|
|
------------------------------------------------------------------------------}
|
|
procedure MenuSizeRequest(widget:PGtkWidget; requisition:PGtkRequisition); cdecl;
|
|
var
|
|
CurToggleSize, MaxToggleSize: integer;
|
|
MenuShell: PGtkMenuShell;
|
|
ListItem: PGList;
|
|
MenuItem: PGtkMenuItem;
|
|
CheckMenuItem: PGtkMenuItem;
|
|
LCLMenuItem: TMenuItem;
|
|
IconSize: TPoint;
|
|
begin
|
|
MaxToggleSize:=0;
|
|
MenuShell:=GTK_MENU_SHELL(widget);
|
|
ListItem:=MenuShell^.Children;
|
|
CheckMenuItem:=nil;
|
|
while ListItem<>nil do begin
|
|
MenuItem:=PGtkMenuItem(ListItem^.Data);
|
|
if GTK_IS_CHECK_MENU_ITEM(PGtkWidget(MenuItem)) then begin
|
|
CheckMenuItem:=MenuItem;
|
|
CurToggleSize:=1;
|
|
LCLMenuItem:=TMenuItem(GetLCLObject(MenuItem));
|
|
if LCLMenuItem<>nil then begin
|
|
IconSize:=LCLMenuItem.GetIconSize(0);
|
|
{if IconSize.X>100 then
|
|
debugln('MenuSizeRequest LCLMenuItem=',LCLMenuItem.Name,' ',LCLMenuItem.Caption,
|
|
' ');}
|
|
if CurToggleSize<IconSize.X then
|
|
CurToggleSize:=IconSize.X;
|
|
end;
|
|
if MaxToggleSize<CurToggleSize then
|
|
MaxToggleSize:=CurToggleSize;
|
|
end;
|
|
ListItem:=ListItem^.Next;
|
|
end;
|
|
//DebugLn('MenuSizeRequest A MaxToggleSize=',MaxToggleSize);
|
|
{$IFDEF Gtk2}
|
|
// Gtk2ToDo
|
|
if CheckMenuItem<>nil then begin
|
|
GTK_MENU_ITEM(CheckMenuItem)^.toggle_size := 0;
|
|
gtk_menu_item_toggle_size_allocate(GTK_MENU_ITEM(CheckMenuItem),MaxToggleSize);
|
|
GTK_MENU_ITEM(CheckMenuItem)^.toggle_size := MaxToggleSize;
|
|
end;
|
|
{$ELSE}
|
|
if CheckMenuItem<>nil then
|
|
MENU_ITEM_CLASS(PGtkWidget(CheckMenuItem))^.toggle_size:=MaxToggleSize;
|
|
{$ENDIF}
|
|
//DebugLn('MenuSizeRequest B ',GetWidgetDebugReport(widget),' ',requisition^.width,',',requisition^.height);
|
|
OldMenuSizeRequestProc(Widget,requisition);
|
|
//DebugLn('MenuSizeRequest C ',GetWidgetDebugReport(widget),' ',requisition^.width,',',requisition^.height);
|
|
end;
|
|
|
|
procedure UpdateInnerMenuItem(LCLMenuItem: TMenuItem; MenuItemWidget: PGtkWidget);
|
|
begin
|
|
UpdateInnerMenuItem(LCLMenuItem, MenuItemWidget, LCLMenuItem.ShortCut, LCLMenuItem.ShortCutKey2);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Update the inner widgets of a menuitem widget.
|
|
------------------------------------------------------------------------------}
|
|
procedure UpdateInnerMenuItem(LCLMenuItem: TMenuItem; MenuItemWidget: PGtkWidget;
|
|
NewShortCut, ShortCutKey2: TShortCut);
|
|
{$ifdef GTK2}
|
|
const
|
|
WidgetDirection : array[boolean] of longint = (GTK_TEXT_DIR_LTR, GTK_TEXT_DIR_RTL);
|
|
{$endif}
|
|
function UseRTL: Boolean;
|
|
begin
|
|
Result := LCLMenuItem.GetIsRightToLeft;
|
|
end;
|
|
var
|
|
HBoxWidget: PGtkWidget;
|
|
|
|
procedure SetMenuItemLabelText(LCLMenuItem: TMenuItem;
|
|
MenuItemWidget: PGtkWidget);
|
|
var
|
|
LabelWidget: PGtkLabel;
|
|
begin
|
|
if (MenuItemWidget = nil) or (LCLMenuItem = nil) then
|
|
Exit;
|
|
LabelWidget := gtk_object_get_data(PGtkObject(MenuItemWidget), 'LCLLabel');
|
|
GtkWidgetset.SetLabelCaption(LabelWidget, LCLMenuItem.Caption);
|
|
{$ifdef GTK2}
|
|
gtk_widget_set_direction(PGtkWidget(LabelWidget), WidgetDirection[UseRTL]);
|
|
{$endif}
|
|
end;
|
|
|
|
procedure UpdateShortCutLabel;
|
|
var
|
|
LabelWidget: PGtkLabel;
|
|
NeedShortCut: Boolean;
|
|
Key, Key2: Word;
|
|
Shift, Shift2: TShiftState;
|
|
s: String;
|
|
begin
|
|
//DebugLn(['UpdateShortCutLabel ',dbgsName(LCLMenuItem),' ',ShortCutToText(NewShortCut)]);
|
|
ShortCutToKey(NewShortCut, Key, Shift);
|
|
ShortCutToKey(ShortCutKey2, Key2, Shift2);
|
|
|
|
// Check if shortcut is needed. No shortcut captions for items in menubar
|
|
NeedShortCut := (Key <> 0) and
|
|
not ( (LCLMenuItem.Parent <> nil) and LCLMenuItem.Parent.HandleAllocated and
|
|
GtkWidgetIsA(PGtkWidget(LCLMenuItem.Parent.Handle), GTK_TYPE_MENU_BAR) );
|
|
|
|
LabelWidget := PGtkLabel(gtk_object_get_data(PGtkObject(MenuItemWidget),'LCLShortCutLabel'));
|
|
if NeedShortCut then
|
|
begin
|
|
s := GetAcceleratorString(Key, Shift);
|
|
if Key2 <> 0 then
|
|
s := s + ', ' + GetAcceleratorString(Key2, Shift2);
|
|
// ShortCutToText(NewShortCut);
|
|
if LabelWidget = nil then
|
|
begin
|
|
// create a label to act as padding
|
|
LabelWidget := PGtkLabel(gtk_label_new(''));
|
|
gtk_misc_set_padding(PGtkMisc(LabelWidget), 10, 0);
|
|
gtk_container_add(GTK_CONTAINER(HBoxWidget), PGtkWidget(LabelWidget));
|
|
gtk_widget_show(PGtkWidget(LabelWidget));
|
|
// create a label for the ShortCut
|
|
LabelWidget := PGtkLabel(gtk_label_new(PChar(Pointer(s))));
|
|
gtk_object_set_data(PGtkObject(MenuItemWidget), 'LCLShortCutLabel', LabelWidget);
|
|
gtk_container_add(GTK_CONTAINER(HBoxWidget), PGtkWidget(LabelWidget));
|
|
gtk_widget_show(PGtkWidget(LabelWidget));
|
|
end
|
|
else
|
|
begin
|
|
gtk_label_set_text(LabelWidget, PChar(Pointer(s)));
|
|
end;
|
|
{$ifdef GTK2}
|
|
gtk_widget_set_direction(PGtkWidget(LabelWidget), GTK_TEXT_DIR_LTR); //Shortcut always LTR
|
|
{$endif}
|
|
if UseRTL then
|
|
gtk_misc_set_alignment(GTK_MISC(LabelWidget), 0.0, 0.5)
|
|
else
|
|
gtk_misc_set_alignment(GTK_MISC (LabelWidget), 1.0, 0.5);
|
|
end else
|
|
if LabelWidget <> nil then
|
|
gtk_widget_destroy(PGtkWidget(LabelWidget));
|
|
end;
|
|
|
|
procedure CreateIcon;
|
|
var
|
|
{$IFNDEF Gtk2}
|
|
IconWidth, IconHeight: integer;
|
|
IconSize: TPoint;
|
|
{$ENDIF}
|
|
MinHeightWidget: PGtkWidget;
|
|
begin
|
|
// the icon will be painted instead of the toggle
|
|
// of a normal gtkcheckmenuitem
|
|
|
|
if LCLMenuItem.HasIcon then
|
|
begin
|
|
{$IFNDEF Gtk2}
|
|
IconSize := LCLMenuItem.GetIconSize(0);
|
|
IconWidth := IconSize.X;
|
|
IconHeight := IconSize.Y;
|
|
// set the toggle width
|
|
GTK_MENU_ITEM(MenuItemWidget)^.toggle_size := guint16(IconWidth);
|
|
{$ENDIF}
|
|
|
|
GTK_MENU_ITEM(MenuItemWidget)^.flag0:=
|
|
PGtkMenuItem(MenuItemWidget)^.flag0 or
|
|
{$IFDEF Gtk2}
|
|
bm_TGtkCheckMenuItem_always_show_toggle;
|
|
{$ELSE}
|
|
bm_show_toggle_indicator;
|
|
{$ENDIF}
|
|
|
|
{$IFNDEF Gtk2}
|
|
// add a dummy widget for the icon height
|
|
MinHeightWidget := gtk_label_new('');
|
|
gtk_widget_show(MinHeightWidget);
|
|
gtk_widget_set_usize(MinHeightWidget, 1, IconHeight);
|
|
gtk_box_pack_start(GTK_BOX(HBoxWidget), MinHeightWidget, False, False, 0);
|
|
{$ENDIF}
|
|
end
|
|
else
|
|
MinHeightWidget := nil;
|
|
gtk_object_set_data(PGtkObject(MenuItemWidget),
|
|
'LCLMinHeight', MinHeightWidget);
|
|
end;
|
|
|
|
procedure CreateLabel;
|
|
var
|
|
LabelWidget: PGtkLabel;
|
|
begin
|
|
// create a label for the Caption
|
|
LabelWidget := PGtkLabel(gtk_label_new(''));
|
|
gtk_misc_set_alignment(GTK_MISC (LabelWidget), 0.0, 0.5);
|
|
gtk_object_set_data(PGtkObject(MenuItemWidget), 'LCLLabel', LabelWidget);
|
|
gtk_container_add(GTK_CONTAINER(HBoxWidget), PGtkWidget(LabelWidget));
|
|
SetMenuItemLabelText(LCLMenuItem, MenuItemWidget);
|
|
//gtk_accel_label_set_accel_widget(GTK_ACCEL_LABEL(LabelWidget), MenuItemWidget);
|
|
gtk_widget_show(PGtkWidget(LabelWidget));
|
|
end;
|
|
|
|
begin
|
|
HBoxWidget := gtk_object_get_data(PGtkObject(MenuItemWidget), 'LCLHBox');
|
|
if HBoxWidget = nil then
|
|
begin
|
|
// create inner widgets
|
|
if LCLMenuItem.Caption = cLineCaption then
|
|
begin
|
|
// a separator is an empty gtkmenuitem
|
|
exit;
|
|
end;
|
|
HBoxWidget := gtk_hbox_new(false, 0);
|
|
{$ifdef GTK2}
|
|
gtk_widget_set_direction(PGtkWidget(HBoxWidget), WidgetDirection[UseRTL]);
|
|
{$endif}
|
|
gtk_object_set_data(PGtkObject(MenuItemWidget), 'LCLHBox', HBoxWidget);
|
|
CreateIcon;
|
|
CreateLabel;
|
|
UpdateShortCutLabel;
|
|
gtk_container_add(GTK_CONTAINER(MenuItemWidget), HBoxWidget);
|
|
gtk_widget_show(HBoxWidget);
|
|
end else
|
|
begin
|
|
// there are already inner widgets
|
|
if LCLMenuItem.Caption = cLineCaption then
|
|
begin
|
|
// a separator is an empty gtkmenuitem -> delete the inner widgets
|
|
DestroyWidget(HBoxWidget);
|
|
gtk_object_set_data(PGtkObject(MenuItemWidget), 'LCLHBox', nil);
|
|
end else
|
|
begin
|
|
// just update the content
|
|
{$ifdef GTK2}
|
|
gtk_widget_set_direction(PGtkWidget(HBoxWidget), WidgetDirection[UseRTL]);
|
|
{$endif}
|
|
SetMenuItemLabelText(LCLMenuItem, MenuItemWidget);
|
|
UpdateShortCutLabel;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function CreateStatusBarPanel(StatusBar: TObject; Index: integer): PGtkWidget;
|
|
begin
|
|
Result := gtk_statusbar_new;
|
|
gtk_widget_show(Result);
|
|
// other properties are set in UpdateStatusBarPanels
|
|
end;
|
|
|
|
procedure UpdateStatusBarPanels(StatusBar: TObject; StatusBarWidget: PGtkWidget);
|
|
var
|
|
AStatusBar: TStatusBar;
|
|
HBox: PGtkWidget;
|
|
CurPanelCount: integer;
|
|
NewPanelCount: Integer;
|
|
CurStatusPanelWidget: PGtkWidget;
|
|
ListItem: PGList;
|
|
i: Integer;
|
|
ExpandItem: boolean;
|
|
{$IFNDEF GTK1}
|
|
ShowSizeGrip: Boolean;
|
|
{$ENDIF}
|
|
begin
|
|
AStatusBar := StatusBar as TStatusBar;
|
|
HBox := PGtkWidget(StatusBarWidget);
|
|
if (not GtkWidgetIsA(StatusBarWidget, GTK_HBOX_GET_TYPE)) then
|
|
RaiseGDBException('');
|
|
|
|
// create needed panels
|
|
CurPanelCount := integer(g_list_length(PGtkBox(HBox)^.children));
|
|
if AStatusBar.SimplePanel or (AStatusBar.Panels.Count < 1) then
|
|
NewPanelCount := 1
|
|
else
|
|
NewPanelCount := AStatusBar.Panels.Count;
|
|
|
|
while CurPanelCount < NewPanelCount do
|
|
begin
|
|
CurStatusPanelWidget := CreateStatusBarPanel(StatusBar, CurPanelCount);
|
|
ExpandItem := (CurPanelCount = NewPanelCount - 1);
|
|
gtk_box_pack_start(PGtkBox(HBox), CurStatusPanelWidget,
|
|
ExpandItem, ExpandItem, 0);
|
|
inc(CurPanelCount);
|
|
end;
|
|
|
|
// remove unneeded panels
|
|
while CurPanelCount > NewPanelCount do
|
|
begin
|
|
CurStatusPanelWidget := PGtkBoxChild(
|
|
g_list_nth_data(PGtkBox(HBox)^.children, CurPanelCount - 1))^.Widget;
|
|
{$IFDEF GTK2}
|
|
gtk_object_remove_data(PGtkObject(CurStatusPanelWidget),'lcl_statusbar_id');
|
|
{$ENDIF}
|
|
DestroyConnectedWidgetCB(CurStatusPanelWidget, True);
|
|
dec(CurPanelCount);
|
|
end;
|
|
|
|
// check new panel count
|
|
CurPanelCount := integer(g_list_length(PGtkBox(HBox)^.children));
|
|
//DebugLn('TGtkWidgetSet.UpdateStatusBarPanels B ',Dbgs(StatusBar),' NewPanelCount=',dbgs(NewPanelCount),' CurPanelCount=',dbgs(CurPanelCount));
|
|
if CurPanelCount <> NewPanelCount then
|
|
RaiseGDBException('');
|
|
|
|
// set panel properties
|
|
{$IFNDEF GTK1}
|
|
ShowSizeGrip := AStatusBar.SizeGrip and AStatusBar.SizeGripEnabled;
|
|
{$ENDIF}
|
|
ListItem := PGTKBox(HBox)^.children;
|
|
i := 0;
|
|
while ListItem <> nil do
|
|
begin
|
|
CurStatusPanelWidget := PGtkBoxChild(PGTKWidget(ListItem^.data))^.widget;
|
|
ExpandItem := (ListItem^.next = nil);
|
|
gtk_box_set_child_packing(PGtkBox(HBox), CurStatusPanelWidget,
|
|
ExpandItem, ExpandItem, 0, GTK_PACK_START);
|
|
UpdateStatusBarPanel(StatusBar, i, CurStatusPanelWidget);
|
|
inc(i);
|
|
ListItem := ListItem^.next;
|
|
{$IFNDEF GTK1}
|
|
gtk_statusbar_set_has_resize_grip(PGtkStatusBar(CurStatusPanelWidget),
|
|
(ListItem = nil) and ShowSizeGrip);
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
|
|
{$IFDEF GTK2}
|
|
function gtk2PaintStatusBarWidget(Widget: PGtkWidget; Event : PGDKEventExpose;
|
|
Data: gPointer): GBoolean; cdecl;
|
|
var
|
|
Msg: TLMDrawItems;
|
|
PS : TPaintStruct;
|
|
ItemStruct: PDrawItemStruct;
|
|
ItemID: Integer;
|
|
begin
|
|
Result := CallBackDefaultReturn;
|
|
if (Event^.Count > 0) then exit;
|
|
|
|
if (csDesigning in TComponent(Data).ComponentState) then
|
|
exit;
|
|
|
|
if TStatusBar(Data).SimplePanel then
|
|
exit;
|
|
|
|
ItemId := PtrInt(gtk_object_get_data(PGtkObject(Widget), 'lcl_statusbar_id')^);
|
|
|
|
if not ((ItemId >= 0) and (ItemId < TStatusBar(Data).Panels.Count)) then
|
|
exit;
|
|
|
|
if TStatusBar(Data).Panels[ItemId].Style <> psOwnerDraw then
|
|
exit;
|
|
|
|
FillChar(Msg, SizeOf(Msg), #0);
|
|
FillChar(PS, SizeOf(PS), #0);
|
|
FillChar(ItemStruct, SizeOf(ItemStruct), #0);
|
|
New(ItemStruct);
|
|
// we must fill up complete area otherwise gtk2 will do
|
|
// strange paints when item is not fully exposed.
|
|
ItemStruct^.rcItem := Rect(Widget^.allocation.x,
|
|
Widget^.allocation.y,
|
|
Widget^.allocation.width + Widget^.allocation.x,
|
|
Widget^.allocation.height + Widget^.allocation.y);
|
|
|
|
OffsetRect(ItemStruct^.rcItem, -ItemStruct^.rcItem.Left, -ItemStruct^.rcItem.Top);
|
|
|
|
// take frame borders into account
|
|
with ItemStruct^.rcItem do
|
|
begin
|
|
Left := Left + Widget^.style^.xthickness;
|
|
Top := Top + Widget^.style^.ythickness;
|
|
Right := Right - Widget^.style^.xthickness;
|
|
Bottom := Bottom - Widget^.style^.ythickness;
|
|
end;
|
|
|
|
ItemStruct^.itemID := ItemID;
|
|
PS.rcPaint := ItemStruct^.rcItem;
|
|
ItemStruct^._hDC := BeginPaint(HWND(Widget), PS);
|
|
Msg.Ctl := TStatusBar(Data).Handle;
|
|
Msg.DrawItemStruct := ItemStruct;
|
|
Msg.Msg := LM_DRAWITEM;
|
|
try
|
|
DeliverMessage(TStatusBar(Data), Msg);
|
|
Result := not CallBackDefaultReturn;
|
|
finally
|
|
PS.hdc := ItemStruct^._hDC;
|
|
EndPaint(HWND(TGtkDeviceContext(PS.hdc).Widget), PS);
|
|
Dispose(ItemStruct);
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
procedure UpdateStatusBarPanel(StatusBar: TObject; Index: integer;
|
|
StatusPanelWidget: PGtkWidget);
|
|
var
|
|
AStatusBar: TStatusBar;
|
|
CurPanel: TStatusPanel;
|
|
FrameWidget: PGtkWidget;
|
|
LabelWidget: PGtkLabel;
|
|
PanelText: String;
|
|
ContextID: LongWord;
|
|
NewShadowType: TGtkShadowType;
|
|
NewJustification: TGtkJustification;
|
|
{$ifndef gtk1}
|
|
xalign, yalign: gfloat;
|
|
{$endif}
|
|
begin
|
|
//DebugLn('UpdateStatusBarPanel ',DbgS(StatusBar),' Index=',dbgs(Index));
|
|
AStatusBar := StatusBar as TStatusBar;
|
|
|
|
CurPanel := nil;
|
|
if (not AStatusBar.SimplePanel) and (AStatusBar.Panels.Count > Index) then
|
|
CurPanel := AStatusBar.Panels[Index];
|
|
//DebugLn('Panel ',Index,' ',GetWidgetClassName(StatusPanelWidget),
|
|
// ' frame=',GetWidgetClassName(PGTKStatusBar(StatusPanelWidget)^.frame),
|
|
// ' thelabel=',GetWidgetClassName(PGTKStatusBar(StatusPanelWidget)^.thelabel),
|
|
// '');
|
|
FrameWidget := PGTKStatusBar(StatusPanelWidget)^.frame;
|
|
LabelWidget := PGtkLabel(
|
|
{$ifndef gtk1}
|
|
PGTKStatusBar(StatusPanelWidget)^._label
|
|
{$else}
|
|
PGTKStatusBar(StatusPanelWidget)^.thelabel
|
|
{$endif});
|
|
|
|
// Text
|
|
if AStatusBar.SimplePanel then
|
|
PanelText := AStatusBar.SimpleText
|
|
else
|
|
if CurPanel <> nil then
|
|
PanelText := CurPanel.Text
|
|
else
|
|
PanelText := '';
|
|
|
|
ContextID := gtk_statusbar_get_context_id(PGTKStatusBar(StatusPanelWidget),
|
|
'state');
|
|
//DebugLn(' PanelText="',PanelText,'"');
|
|
if PanelText <> '' then
|
|
gtk_statusbar_push(PGTKStatusBar(StatusPanelWidget), ContextID, PGChar(PanelText))
|
|
else
|
|
gtk_statusbar_push(PGTKStatusBar(StatusPanelWidget), ContextID, '');
|
|
|
|
|
|
if CurPanel <> nil then
|
|
begin
|
|
//DebugLn(' Alignment="',ord(CurPanel.Alignment),'"');
|
|
// Alignment
|
|
NewJustification := aGtkJustification[CurPanel.Alignment];
|
|
if GTK_IS_LABEL(LabelWidget) then
|
|
begin
|
|
{$ifndef gtk1}
|
|
if GTK_IS_MISC(LabelWidget) then
|
|
begin
|
|
{gtk_label_set_justify() has no effect on labels containing
|
|
only a single line !}
|
|
gtk_misc_get_alignment(GTK_MISC(LabelWidget), @xalign, @yalign);
|
|
xalign := AlignToGtkAlign(CurPanel.Alignment);
|
|
gtk_misc_set_alignment(GTK_MISC(LabelWidget), xalign, yalign);
|
|
end else
|
|
gtk_label_set_justify(LabelWidget, NewJustification);
|
|
{$else}
|
|
gtk_label_set_justify(LabelWidget, NewJustification);
|
|
{$endif}
|
|
end;
|
|
|
|
// Bevel
|
|
|
|
// Paul: this call will not modify frame on gtk2. GtkStatusBar resets frame
|
|
// shadow on every size request. I have tried to modify rcStyle and tried to
|
|
// hook property change event. Both ways are 1) not valid 2) does not give me
|
|
// any result.
|
|
// As a possible solution we can subclass PGtkStatusBar but if gtk developers
|
|
// decided that stausbar should work so whether we need to override that?
|
|
NewShadowType := aGtkShadowFromBevel[CurPanel.Bevel];
|
|
if GTK_IS_FRAME(FrameWidget) then
|
|
gtk_frame_set_shadow_type(PGtkFrame(FrameWidget), NewShadowType);
|
|
|
|
// Width
|
|
//DebugLn(' CurPanel.Width="',CurPanel.Width,'"');
|
|
gtk_widget_set_usize(StatusPanelWidget, CurPanel.Width,
|
|
StatusPanelWidget^.allocation.height);
|
|
{$IFDEF GTK2}
|
|
gtk_object_set_data(PGtkObject(StatusPanelWidget),'lcl_statusbar_id',
|
|
@AStatusBar.Panels[Index].ID);
|
|
g_signal_connect_after(StatusPanelWidget, 'expose-event',
|
|
TGtkSignalFunc(@gtk2PaintStatusBarWidget), AStatusBar);
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
|
|
function gtkListGetSelectionMode(list: PGtkList): TGtkSelectionMode; cdecl;
|
|
begin
|
|
Result:=TGtkSelectionMode(
|
|
(list^.flag0 and bm_TGtkList_selection_mode) shr bp_TGtkList_selection_mode);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
SaveSizeNotification
|
|
Params: Widget: PGtkWidget A widget that is the handle of a lcl control.
|
|
|
|
When the gtk sends a size signal, it is not send directly to the LCL. All gtk
|
|
size/move messages are collected and only the last one for each widget is sent
|
|
to the LCL.
|
|
This is neccessary, because the gtk sends size messages several times and
|
|
it replays resizes. Since the LCL reacts to every size notification and
|
|
resizes child controls, this results in a perpetuum mobile.
|
|
------------------------------------------------------------------------------}
|
|
procedure SaveSizeNotification(Widget: PGtkWidget);
|
|
{$IFDEF VerboseSizeMsg}
|
|
var
|
|
LCLControl: TWinControl;
|
|
{$ENDIF}
|
|
begin
|
|
{$IFDEF VerboseSizeMsg}
|
|
DbgOut('SaveSizeNotification Widget=',DbgS(Widget));
|
|
LCLControl:=TWinControl(GetLCLObject(Widget));
|
|
if (LCLControl<>nil) then begin
|
|
if LCLControl is TWinControl then
|
|
DebugLn(' ',LCLControl.Name,':',LCLControl.ClassName)
|
|
else
|
|
DebugLn(' ERROR: ',LCLControl.ClassName);
|
|
end else begin
|
|
DebugLn(' ERROR: LCLControl=nil');
|
|
end;
|
|
{$ENDIF}
|
|
if not FWidgetsResized.Contains(Widget) then
|
|
FWidgetsResized.Add(Widget);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
SaveClientSizeNotification
|
|
Params: FixWidget: PGtkWidget A widget that is the fixed widget
|
|
of a lcl control.
|
|
|
|
When the gtk sends a size signal, it is not sent directly to the LCL. All gtk
|
|
size/move messages are collected and only the last one for each widget is sent
|
|
to the LCL.
|
|
This is neccessary, because the gtk sends size messages several times and
|
|
it replays resizes. Since the LCL reacts to every size notification and
|
|
resizes child controls, this results in a perpetuum mobile.
|
|
------------------------------------------------------------------------------}
|
|
procedure SaveClientSizeNotification(FixWidget: PGtkWidget);
|
|
{$IFDEF VerboseSizeMsg}
|
|
var
|
|
LCLControl: TWinControl;
|
|
MainWidget: PGtkWidget;
|
|
{$ENDIF}
|
|
begin
|
|
{$IFDEF VerboseSizeMsg}
|
|
MainWidget:=GetMainWidget(FixWidget);
|
|
//write('SaveClientSizeNotification',
|
|
// ' FixWidget=',DbgS(FixWidget),
|
|
// ' MainWIdget=',DbgS(MainWidget));
|
|
LCLControl:=TWinControl(GetLCLObject(MainWidget));
|
|
if (LCLControl<>nil) then begin
|
|
if LCLControl is TWinControl then begin
|
|
//DebugLn('SaveClientSizeNotification ',LCLControl.Name,':',LCLControl.ClassName,
|
|
// ' FixWidget=',DbgS(FixWidget),
|
|
// ' MainWidget=',DbgS(MainWidget));
|
|
end else begin
|
|
DbgOut('ERROR: SaveClientSizeNotification ',
|
|
' LCLControl=',LCLControl.ClassName,
|
|
' FixWidget=',DbgS(FixWidget),
|
|
' MainWidget=',DbgS(MainWidget));
|
|
RaiseGDBException('SaveClientSizeNotification');
|
|
end;
|
|
end else begin
|
|
DbgOut('ERROR: SaveClientSizeNotification LCLControl=nil',
|
|
' FixWidget=',DbgS(FixWidget),
|
|
' MainWIdget=',DbgS(MainWidget));
|
|
RaiseGDBException('SaveClientSizeNotification');
|
|
end;
|
|
{$ENDIF}
|
|
if not FFixWidgetsResized.Contains(FixWidget) then
|
|
FFixWidgetsResized.Add(FixWidget);
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
CreateTopologicalSortedWidgets
|
|
Params: HashArray: TDynHashArray of PGtkWidget
|
|
|
|
Creates a topologically sorted TFPList of PGtkWidget.
|
|
-------------------------------------------------------------------------------}
|
|
function CreateTopologicalSortedWidgets(HashArray: TDynHashArray): TFPList;
|
|
type
|
|
PTopologicalEntry = ^TTopologicalEntry;
|
|
TTopologicalEntry = record
|
|
Widget: PGtkWidget;
|
|
ParentLevel: integer;
|
|
end;
|
|
|
|
function GetParentLevel(AControl: TControl): integer;
|
|
// nil has lvl -1
|
|
// a control without parent has lvl 0
|
|
begin
|
|
Result:=-1;
|
|
while AControl<>nil do begin
|
|
inc(Result);
|
|
AControl:=AControl.Parent;
|
|
end;
|
|
end;
|
|
|
|
var
|
|
TopologicalList: PTopologicalEntry;
|
|
HashItem: PDynHashArrayItem;
|
|
i, Lvl, MaxLevel: integer;
|
|
LCLControl: TControl;
|
|
LevelCounts: PInteger;
|
|
begin
|
|
Result:=TFPList.Create;
|
|
if HashArray.Count=0 then exit;
|
|
|
|
// put all widgets into an array and calculate their parent levels
|
|
GetMem(TopologicalList,SizeOf(TTopologicalEntry)*HashArray.Count);
|
|
HashItem:=HashArray.FirstHashItem;
|
|
i:=0;
|
|
MaxLevel:=0;
|
|
//DebugLn('CreateTopologicalSortedWidgets HashArray.Count=',HashArray.Count);
|
|
while HashItem<>nil do begin
|
|
TopologicalList[i].Widget:=HashItem^.Item;
|
|
//DebugLn('CreateTopologicalSortedWidgets i=',i,' Widget=',DbgS(TopologicalList[i].Widget));
|
|
LCLControl:=TControl(GetLCLObject(TopologicalList[i].Widget));
|
|
if (LCLControl=nil) or (not (LCLControl is TControl)) then
|
|
RaiseGDBException('CreateTopologicalSortedWidgets: '
|
|
+'Widget without LCL control');
|
|
Lvl:=GetParentLevel(LCLControl);
|
|
TopologicalList[i].ParentLevel:=Lvl;
|
|
if MaxLevel<Lvl then
|
|
MaxLevel:=Lvl;
|
|
//DebugLn('CreateTopologicalSortedWidgets i=',i,' Lvl=',Lvl,' MaxLvl=',MaxLevel,' LCLControl=',LCLControl.Name,':',LCLControl.ClassName);
|
|
inc(i);
|
|
HashItem:=HashItem^.Next;
|
|
end;
|
|
inc(MaxLevel);
|
|
|
|
// bucket sort the widgets
|
|
|
|
// count each number of levels (= bucketsizes)
|
|
GetMem(LevelCounts,SizeOf(Integer)*MaxLevel);
|
|
FillChar(LevelCounts^,SizeOf(Integer)*MaxLevel,0);
|
|
for i:=0 to HashArray.Count-1 do
|
|
inc(LevelCounts[TopologicalList[i].ParentLevel]);
|
|
|
|
// calculate bucketends
|
|
for i:=1 to MaxLevel-1 do
|
|
inc(LevelCounts[i],LevelCounts[i-1]);
|
|
|
|
// bucket sort the widgets in Result
|
|
Result.Count:=HashArray.Count;
|
|
for i:=0 to HashArray.Count-1 do
|
|
Result[i]:=nil;
|
|
for i:=0 to HashArray.Count-1 do begin
|
|
Lvl:=TopologicalList[i].ParentLevel;
|
|
dec(LevelCounts[Lvl]);
|
|
//DebugLn('CreateTopologicalSortedWidgets bucket sort i=',i,' Lvl=',Lvl,' LevelCounts[Lvl]=',LevelCounts[Lvl],
|
|
// ' Widget=',DbgS(TopologicalList[i].Widget));
|
|
Result[LevelCounts[Lvl]]:=TopologicalList[i].Widget;
|
|
end;
|
|
|
|
FreeMem(LevelCounts);
|
|
FreeMem(TopologicalList);
|
|
end;
|
|
|
|
procedure GetGTKDefaultWidgetSize(AWinControl: TWinControl;
|
|
var PreferredWidth, PreferredHeight: integer; WithThemeSpace: Boolean);
|
|
var
|
|
Widget: PGtkWidget;
|
|
Requisition: TGtkRequisition;
|
|
begin
|
|
Widget := PGtkWidget(AWinControl.Handle);
|
|
// set size to default
|
|
//DebugLn(['GetGTKDefaultWidgetSize ',GetWidgetDebugReport(Widget)]);
|
|
{$IFDEF GTK1}
|
|
gtk_widget_set_usize(Widget, -1, -1); // deprecated in gtk2
|
|
{$ELSE}
|
|
gtk_widget_set_size_request(Widget, -1, -1);
|
|
{$ENDIF}
|
|
// ask default size
|
|
gtk_widget_size_request(Widget,@Requisition);
|
|
PreferredWidth:=Requisition.width;
|
|
PreferredHeight:=Requisition.height;
|
|
if WithThemeSpace then begin
|
|
{$IFDEF Gtk1}
|
|
//DebugLn(['GetGTKDefaultWidgetSize WithThemeSpace ',DbgSName(AWinControl),' ',GtkWidgetIsA(Widget,GTK_BUTTON_TYPE),' ',GetWidgetDebugReport(Widget),' ',2*gtk_widget_get_ythickness(Widget)]);
|
|
if gtk_class_get_type(gtk_object_get_class(Widget))=GTK_BUTTON_TYPE then
|
|
inc(PreferredHeight,2*gtk_widget_get_ythickness(Widget))
|
|
else if not GtkWidgetIsA(Widget,GTK_ENTRY_TYPE) then
|
|
dec(PreferredHeight,2*gtk_widget_get_ythickness(Widget));
|
|
{$ENDIF}
|
|
end else begin
|
|
//debugLn('GetGTKDefaultWidgetSize ',DbgSName(AWinControl),' ',dbgs(gtk_widget_get_xthickness(Widget)),' ythickness=',dbgs(gtk_widget_get_ythickness(Widget)));
|
|
//debugLn(['GetGTKDefaultWidgetSize ',GetWidgetDebugReport(Widget)]);
|
|
//dec(PreferredWidth,gtk_widget_get_xthickness(Widget));
|
|
{$IFDEF Gtk1}
|
|
//if not GtkWidgetIsA(Widget,GTK_ENTRY_TYPE) then
|
|
// dec(PreferredHeight,2*gtk_widget_get_ythickness(Widget));
|
|
{$ELSE}
|
|
//if gtk_class_get_type(gtk_object_get_class(Widget))=GTK_TYPE_BUTTON then
|
|
// dec(PreferredHeight,2*gtk_widget_get_ythickness(Widget));
|
|
{$ENDIF}
|
|
end;
|
|
{DebugLn(['GetGTKDefaultWidgetSize Allocation=',Widget^.allocation.x,',',Widget^.allocation.y,',',Widget^.allocation.width,',',Widget^.allocation.height,
|
|
' requisition=',Widget^.requisition.width,',',Widget^.requisition.height,
|
|
' PreferredWidth=',PreferredWidth,' PreferredHeight=',PreferredHeight,
|
|
' WithThemeSpace=',WithThemeSpace]);}
|
|
// set new size
|
|
{$IFDEF GTK1}
|
|
gtk_widget_set_usize(Widget, AWinControl.Width, AWinControl.Height);
|
|
{$ELSE}
|
|
gtk_widget_set_size_request(Widget, AWinControl.Width, AWinControl.Height);
|
|
{$ENDIF}
|
|
//debugln('GetGTKDefaultSize PreferredWidth=',dbgs(PreferredWidth),' PreferredHeight=',dbgs(PreferredHeight));
|
|
end;
|
|
|
|
procedure SendSizeNotificationToLCL(aWidget: PGtkWidget);
|
|
var
|
|
LCLControl: TWinControl;
|
|
LCLLeft, LCLTop, LCLWidth, LCLHeight: integer;
|
|
GtkLeft, GtkTop, GtkWidth, GtkHeight: integer;
|
|
TopLeftChanged, WidthHeightChanged, IsTopLevelWidget: boolean;
|
|
MessageDelivered: boolean;
|
|
SizeMsg: TLMSize;
|
|
MoveMsg: TLMMove;
|
|
PosMsg : TLMWindowPosChanged;
|
|
MainWidget: PGtkWidget;
|
|
FixedWidget: PGtkWidget;
|
|
|
|
procedure UpdateLCLPos;
|
|
begin
|
|
LCLLeft:=LCLControl.Left;
|
|
LCLTop:=LCLControl.Top;
|
|
TopLeftChanged:=(LCLLeft<>GtkLeft) or (LCLTop<>GtkTop);
|
|
end;
|
|
|
|
procedure UpdateLCLSize;
|
|
begin
|
|
LCLWidth:=LCLControl.Width;
|
|
LCLHeight:=LCLControl.Height;
|
|
WidthHeightChanged:=(LCLWidth<>GtkWidth) or (LCLHeight<>GtkHeight);
|
|
if LCLControl.ClientRectNeedsInterfaceUpdate then begin
|
|
WidthHeightChanged:=true;
|
|
//DebugLn(['UpdateLCLSize InvalidateClientRectCache ',DbgSName(LCLControl)]);
|
|
LCLControl.InvalidateClientRectCache(false);
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
LCLControl:=TWinControl(GetLCLObject(aWidget));
|
|
if LCLControl=nil then exit;
|
|
{$IFDEF VerboseSizeMsg}
|
|
DebugLn('SendSizeNotificationToLCL checking ... ',DbgSName(LCLControl),' Widget=',WidgetFlagsToString(aWidget));
|
|
{$ENDIF}
|
|
MainWidget:=PGtkWidget(LCLControl.Handle);
|
|
FixedWidget:=PGtkWidget(GetFixedWidget(MainWidget));
|
|
|
|
FWidgetsResized.Remove(MainWidget);
|
|
FFixWidgetsResized.Remove(FixedWidget);
|
|
|
|
{$IF defined(Gtk1)}
|
|
if not GTK_WIDGET_REALIZED(aWidget) then begin
|
|
// the widget is not yet realized, so this GTK resize was not a user change.
|
|
// => ignore
|
|
{$IFDEF VerboseSizeMsg}
|
|
LCLControl:=TWinControl(GetLCLObject(aWidget));
|
|
DebugLn('SendSizeNotificationToLCL ',DbgSName(LCLControl),' aWidget=',WidgetFlagsToString(aWidget),' Ignored, because not realized ');
|
|
{$ENDIF}
|
|
exit;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
GetWidgetRelativePosition(MainWidget,GtkLeft,GtkTop);
|
|
|
|
{$ifdef gtk2}
|
|
gtk_widget_get_size_request(MainWidget, @GtkWidth, @GtkHeight);
|
|
|
|
if GtkWidth < 0 then
|
|
GtkWidth:=MainWidget^.Allocation.Width
|
|
else
|
|
MainWidget^.Allocation.Width:=GtkWidth;
|
|
if GtkHeight < 0 then
|
|
GtkHeight:=MainWidget^.Allocation.Height
|
|
else
|
|
MainWidget^.Allocation.Height:=GtkHeight;
|
|
//DebugLn(['SendSizeNotificationToLCL ',DbgSName(LCLControl),' gtk=',GtkLeft,',',GtkTop,',',GtkWidth,'x',GtkHeight,' Allocation=',MainWidget^.Allocation.Width,'x',MainWidget^.Allocation.Height]);
|
|
{$else}
|
|
GtkWidth:=MainWidget^.Allocation.Width;
|
|
GtkHeight:=MainWidget^.Allocation.Height;
|
|
{$endif}
|
|
|
|
if GtkWidth<0 then GtkWidth:=0;
|
|
if GtkHeight<0 then GtkHeight:=0;
|
|
|
|
IsTopLevelWidget:=(LCLControl is TCustomForm) and (LCLControl.Parent=nil);
|
|
if IsTopLevelWidget then begin
|
|
if not GTK_WIDGET_VISIBLE(MainWidget) then begin
|
|
// size/move messages of invisible windows are not reliable
|
|
// -> ignore
|
|
exit;
|
|
end;
|
|
if (GtkWidth=1) and (GtkHeight=1) then begin
|
|
// this is default size of the gtk. Ignore.
|
|
exit;
|
|
end;
|
|
//DebugLn(['SendSizeNotificationToLCL FORM ',GetWidgetDebugReport(MainWidget)]);
|
|
|
|
{$IFDEF VerboseFormPositioning}
|
|
DebugLn(['VFP SendSizeNotificationToLCL ',DbgSName(LCLControl),' ',
|
|
GtkLeft,',',GtkTop,',',GtkWidth,'x',GtkHeight,' ',GetWidgetDebugReport(MainWidget)]);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
UpdateLCLPos;
|
|
UpdateLCLSize;
|
|
|
|
// first send a LM_WINDOWPOSCHANGED message
|
|
if TopLeftChanged or WidthHeightChanged then begin
|
|
{$IFDEF VerboseSizeMsg}
|
|
DebugLn('SendSizeNotificationToLCL ',DbgSName(LCLControl),
|
|
' GTK=',dbgs(GtkLeft)+','+dbgs(GtkTop)+','+dbgs(GtkWidth)+'x'+dbgs(GtkHeight),
|
|
' LCL=',dbgs(LCLLeft)+','+dbgs(LCLTop)+','+dbgs(LCLWidth)+'x'+dbgs(LCLHeight)
|
|
);
|
|
{$ENDIF}
|
|
PosMsg.Msg := LM_WINDOWPOSCHANGED; //LM_SIZEALLOCATE;
|
|
PosMsg.Result := 0;
|
|
New(PosMsg.WindowPos);
|
|
try
|
|
with PosMsg.WindowPos^ do begin
|
|
hWndInsertAfter := 0;
|
|
x := GtkLeft;
|
|
y := GtkTop;
|
|
cx := GtkWidth;
|
|
cy := GtkHeight;
|
|
flags:=0;
|
|
// flags := SWP_SourceIsInterface;
|
|
end;
|
|
MessageDelivered := DeliverMessage(LCLControl, PosMsg) = 0;
|
|
finally
|
|
Dispose(PosMsg.WindowPos);
|
|
end;
|
|
if (not MessageDelivered) then exit;
|
|
if FWidgetsWithResizeRequest.Contains(MainWidget) then exit;
|
|
UpdateLCLPos;
|
|
UpdateLCLSize;
|
|
end;
|
|
|
|
// then send a LM_SIZE message
|
|
if WidthHeightChanged then begin
|
|
{$IFDEF VerboseSizeMsg}
|
|
DebugLn('Send LM_SIZE To LCL ',LCLControl.Name,':',LCLControl.ClassName);
|
|
{$ENDIF}
|
|
with SizeMsg do
|
|
begin
|
|
Result := 0;
|
|
Msg := LM_SIZE;
|
|
{$IFDEF GTK1}
|
|
if GDK_WINDOW_GET_MAXIMIZED(PGdkWindowPrivate(MainWidget^.window)) then
|
|
SizeType := SIZEFULLSCREEN
|
|
else
|
|
SizeType := SIZENORMAL;
|
|
{$ELSE}
|
|
if LCLControl is TCustomForm then begin
|
|
// if the LCL gets an event without a State it resets it to SIZENORMAL
|
|
// so we send it the state it already is
|
|
case TCustomForm(LCLControl).WindowState of
|
|
wsNormal: SizeType := SIZENORMAL;
|
|
wsMinimized: SizeType := SIZEICONIC;
|
|
wsMaximized: SizeType := SIZEFULLSCREEN;
|
|
end;
|
|
end
|
|
else
|
|
SizeType := 0;
|
|
{$ENDIF}
|
|
SizeType := SizeType or Size_SourceIsInterface;
|
|
Width := SmallInt(GtkWidth);
|
|
Height := SmallInt(GtkHeight);
|
|
end;
|
|
MessageDelivered := (DeliverMessage(LCLControl, SizeMsg) = 0);
|
|
if not MessageDelivered then exit;
|
|
if FWidgetsWithResizeRequest.Contains(MainWidget) then exit;
|
|
UpdateLCLPos;
|
|
end;
|
|
|
|
// then send a LM_MOVE message
|
|
if TopLeftChanged then begin
|
|
{$IFDEF VerboseSizeMsg}
|
|
DebugLn('Send LM_MOVE To LCL ',LCLControl.Name,':',LCLControl.ClassName);
|
|
{$ENDIF}
|
|
with MoveMsg do
|
|
begin
|
|
Result := 0;
|
|
Msg := LM_MOVE;
|
|
MoveType := Move_SourceIsInterface;
|
|
XPos := SmallInt(GtkLeft);
|
|
YPos := SmallInt(GtkTop);
|
|
end;
|
|
MessageDelivered := (DeliverMessage(LCLControl, MoveMsg) = 0);
|
|
if not MessageDelivered then exit;
|
|
end;
|
|
|
|
{$ifndef gtk1}
|
|
if GtkWidgetIsA(aWidget, GTKAPIWidget_Type) and
|
|
not (wwiNoEraseBkgnd in GetWidgetInfo(aWidget)^.Flags) then
|
|
gtk_widget_queue_draw(aWidget);
|
|
{$endif}
|
|
end;
|
|
|
|
procedure SendCachedGtkResizeNotifications;
|
|
{ This proc sends all cached size messages from the gtk to lcl but in an
|
|
optimized order.
|
|
When sending the LCL a size/move/windowposchanged messages the LCL will
|
|
automatically realign all child controls. This realigning is based on the
|
|
clientrect.
|
|
Therefore, before a size message is sent to the lcl, all clientrect must be
|
|
updated.
|
|
If a size message results in resizing a widget that was also resized, then
|
|
the message for the dependent widget is not sent to the lcl, because the lcl
|
|
resize was after the gtk resize.
|
|
}
|
|
var
|
|
FixWidget, MainWidget: PGtkWidget;
|
|
LCLControl: TWinControl;
|
|
List: TFPList;
|
|
i: integer;
|
|
|
|
procedure RaiseInvalidLCLControl;
|
|
begin
|
|
RaiseGDBException(Format('SendCachedGtkResizeNotifications FixWidget=%p MainWidget=%p LCLControl=%p',
|
|
[FixWidget, MainWidget, Pointer(LCLControl)]));
|
|
end;
|
|
|
|
begin
|
|
if (FWidgetsResized.Count=0) and (FFixWidgetsResized.Count=0) then exit;
|
|
|
|
List:=TFPList.Create;
|
|
|
|
{ if any fixed widget was resized then a client area of a LCL control was
|
|
resized
|
|
-> invalidate client rectangles
|
|
}
|
|
{$IFDEF VerboseSizeMsg}
|
|
DebugLn('HHH1 SendCachedGtkClientResizeNotifications Invalidating ClientRects ... '
|
|
,' FixSizeMsgCount=',dbgs(FFixWidgetsResized.Count));
|
|
{$ENDIF}
|
|
FFixWidgetsResized.AssignTo(List);
|
|
for i:=0 to List.Count-1 do begin
|
|
FixWidget:=List[i];
|
|
MainWidget:=GetMainWidget(FixWidget);
|
|
LCLControl:=TWinControl(GetLCLObject(MainWidget));
|
|
if (LCLControl=nil) or (not (LCLControl is TWinControl)) then
|
|
RaiseInvalidLCLControl;
|
|
LCLControl.InvalidateClientRectCache(false);
|
|
end;
|
|
|
|
{ if any main widget (= not fixed widget) was resized
|
|
then a LCL control was resized
|
|
-> send WMSize, WMMove, and WMWindowPosChanged messages
|
|
}
|
|
{$IFDEF VerboseSizeMsg}
|
|
if FWidgetsResized.First<>nil then
|
|
DebugLn('HHH2 SendCachedGtkClientResizeNotifications SizeMsgCount=',dbgs(FWidgetsResized.Count));
|
|
{$ENDIF}
|
|
repeat
|
|
MainWidget:=FWidgetsResized.First;
|
|
if MainWidget<>nil then begin
|
|
FWidgetsResized.Remove(MainWidget);
|
|
if not FWidgetsWithResizeRequest.Contains(MainWidget) then begin
|
|
SendSizeNotificationToLCL(MainWidget);
|
|
end;
|
|
end else break;
|
|
until Application.Terminated;
|
|
|
|
{ if any client area was resized, which MainWidget Size was already in sync
|
|
with the LCL, no message was sent. So, tell each changed client area to
|
|
check its size.
|
|
}
|
|
{$IFDEF VerboseSizeMsg}
|
|
if FFixWidgetsResized.First<>nil then
|
|
DebugLn('HHH3 SendCachedGtkClientResizeNotifications Updating ClientRects ...');
|
|
{$ENDIF}
|
|
repeat
|
|
FixWidget:=FFixWidgetsResized.First;
|
|
if FixWidget<>nil then begin
|
|
FFixWidgetsResized.Remove(FixWidget);
|
|
MainWidget:=GetMainWidget(FixWidget);
|
|
LCLControl:=TWinControl(GetLCLObject(MainWidget));
|
|
LCLControl.DoAdjustClientRectChange(False);
|
|
end else begin
|
|
break;
|
|
end;
|
|
until Application.Terminated;
|
|
|
|
List.Free;
|
|
{$IFDEF VerboseSizeMsg}
|
|
DebugLn('HHH4 SendCachedGtkClientResizeNotifications completed.');
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure ResizeHandle(LCLControl: TWinControl);
|
|
var
|
|
Widget: PGtkWidget;
|
|
Later: Boolean;
|
|
{$IFDEF Gtk2}
|
|
IsTopLevelWidget: Boolean;
|
|
{$ENDIF}
|
|
begin
|
|
Widget := PGtkWidget(LCLControl.Handle);
|
|
if not WidgetSizeIsEditable(Widget) then
|
|
Exit;
|
|
Later := true;
|
|
{$IFDEF Gtk2}
|
|
// add resize request immediately
|
|
IsTopLevelWidget:= (LCLControl is TCustomForm) and
|
|
(LCLControl.Parent = nil) and
|
|
(LCLControl.ParentWindow = 0);
|
|
if not IsTopLevelWidget then
|
|
begin
|
|
SetWidgetSizeAndPosition(LCLControl);
|
|
Later := false;
|
|
end;
|
|
{$ENDIF}
|
|
if Later then
|
|
SetResizeRequest(Widget);
|
|
end;
|
|
|
|
procedure SetWidgetSizeAndPosition(LCLControl: TWinControl);
|
|
var
|
|
Requisition: TGtkRequisition;
|
|
FixedWidget: PGtkWidget;
|
|
{$IFDEF Gtk2}
|
|
allocation: TGtkAllocation;
|
|
{$ENDIF}
|
|
LCLLeft: LongInt;
|
|
LCLTop: LongInt;
|
|
LCLWidth: LongInt;
|
|
LCLHeight: LongInt;
|
|
Widget: PGtkWidget;
|
|
ParentWidget: PGtkWidget;
|
|
ParentFixed: PGtkWidget;
|
|
WinWidgetInfo: PWidgetInfo;
|
|
{$IFDEF VerboseSizeMsg}
|
|
LCLObject: TObject;
|
|
{$ENDIF}
|
|
|
|
procedure WriteBigWarning;
|
|
begin
|
|
DebugLn('WARNING: SetWidgetSizeAndPosition: resizing BIG ',
|
|
' Control=',LCLControl.Name,':',LCLControl.ClassName,
|
|
' NewSize=',dbgs(LCLWidth),',',dbgs(LCLHeight));
|
|
//RaiseException('');
|
|
end;
|
|
|
|
procedure WriteWarningParentWidgetNotFound;
|
|
begin
|
|
DebugLn('WARNING: SetWidgetSizeAndPosition - '
|
|
,'Parent''s Fixed Widget not found');
|
|
DebugLn(' Control=',LCLControl.Name,':',LCLControl.ClassName,
|
|
' Parent=',LCLControl.Parent.Name,':',LCLControl.Parent.ClassName,
|
|
' ParentWidget=',DbgS(ParentWidget),
|
|
'');
|
|
end;
|
|
|
|
begin
|
|
{$IFDEF VerboseSizeMsg}
|
|
DebugLn(['SetWidgetSizeAndPosition ',DbgSName(LCLControl)]);
|
|
{$ENDIF}
|
|
Widget:=PGtkWidget(LCLControl.Handle);
|
|
|
|
LCLLeft := LCLControl.Left;
|
|
LCLTop := LCLControl.Top;
|
|
|
|
// move widget on the fixed widget of parent control
|
|
if ((LCLControl.Parent <> nil) and (LCLControl.Parent.HandleAllocated)) or
|
|
((LCLControl.Parent = nil) and (LCLControl.ParentWindow <> 0)) then
|
|
begin
|
|
if LCLControl.Parent <> nil then
|
|
ParentWidget := PGtkWidget(LCLControl.Parent.Handle)
|
|
else
|
|
ParentWidget := PGtkWidget(LCLControl.ParentWindow);
|
|
ParentFixed := GetFixedWidget(ParentWidget);
|
|
if GtkWidgetIsA(ParentFixed,GTK_FIXED_GET_TYPE) or
|
|
GtkWidgetIsA(ParentFixed,GTK_LAYOUT_GET_TYPE) then
|
|
begin
|
|
//DebugLn(['SetWidgetSizeAndPosition ',DbgSName(LCLControl),' Widget=[',GetWidgetDebugReport(Widget),'] ParentFixed=[',GetWidgetDebugReport(ParentFixed),']']);
|
|
FixedMoveControl(ParentFixed, Widget, LCLLeft, LCLTop);
|
|
end
|
|
else
|
|
begin
|
|
WinWidgetInfo := GetWidgetInfo(Widget, False);
|
|
if (WinWidgetInfo = nil) or (not (wwiNotOnParentsClientArea in WinWidgetInfo^.Flags)) then
|
|
WriteWarningParentWidgetNotFound;
|
|
end;
|
|
end;
|
|
|
|
// resize widget
|
|
LCLWidth := LCLControl.Width;
|
|
if LCLWidth <= 0 then
|
|
LCLWidth := 1;
|
|
LCLHeight := LCLControl.Height;
|
|
if LCLHeight <= 0 then
|
|
LCLHeight := 1;
|
|
if (LCLWidth > 10000) or (LCLHeight > 10000) then
|
|
begin
|
|
WriteBigWarning;
|
|
if LCLWidth > 10000 then
|
|
LCLWidth := 10000;
|
|
if LCLHeight > 10000 then
|
|
LCLHeight := 10000;
|
|
end;
|
|
|
|
{$IFDEF VerboseSizeMsg}
|
|
LCLObject:=GetNearestLCLObject(Widget);
|
|
DbgOut('TGtkWidgetSet.SetWidgetSizeAndPosition Widget='+DbgS(Widget)+WidgetFlagsToString(Widget)+
|
|
' New='+dbgs(LCLWidth)+','+dbgs(LCLHeight));
|
|
if (LCLObject<>nil) and (LCLObject is TControl) then begin
|
|
with TControl(LCLObject) do
|
|
DebugLn(' LCL=',Name,':',ClassName,' ',dbgs(Left),',',dbgs(Top),',',dbgs(Width),',',dbgs(Height));
|
|
end else begin
|
|
DebugLn(' LCL=',DbgS(LCLObject));
|
|
end;
|
|
{$ENDIF}
|
|
|
|
if GtkWidgetIsA(Widget,GTK_TYPE_SCROLLBAR) then
|
|
begin
|
|
// the width of a scrollbar is fixed and depends only on the theme
|
|
gtk_widget_size_request(widget, @Requisition);
|
|
if GtkWidgetIsA(Widget, GTK_TYPE_HSCROLLBAR) then
|
|
begin
|
|
LCLHeight:=Requisition.height;
|
|
end else begin
|
|
LCLWidth:=Requisition.width;
|
|
end;
|
|
//DebugLn('TGtkWidgetSet.SetWidgetSizeAndPosition A ',LCLwidth,',',LCLheight);
|
|
end;
|
|
|
|
gtk_widget_set_usize(Widget, LCLWidth, LCLHeight);
|
|
//DebugLn(['TGtkWidgetSet.SetWidgetSizeAndPosition ',GetWidgetDebugReport(Widget),' LCLWidth=',LCLWidth,' LCLHeight=',LCLHeight]);
|
|
|
|
{$IFDEF Gtk1}
|
|
if GtkWidgetIsA(Widget, GTK_TYPE_COMBO) then
|
|
begin
|
|
// the combobox has an entry, which height is not resized
|
|
// automatically. Do it manually.
|
|
gtk_widget_set_usize(PGtkCombo(Widget)^.entry,
|
|
PGtkCombo(Widget)^.entry^.allocation.width, LCLHeight);
|
|
end;
|
|
{$ENDIF}
|
|
|
|
if GtkWidgetIsA(Widget,gtk_toolbar_get_type) then begin
|
|
FixedWidget:=GetFixedWidget(Widget);
|
|
if (FixedWidget<>nil) and (FixedWidget<>Widget) then begin
|
|
//DebugLn('WARNING: ToDo TGtkWidgetSet.SetWidgetSizeAndPosition for TToolBar ',LCLWidth,',',LCLHeight);
|
|
gtk_widget_set_usize(FixedWidget,LCLWidth,LCLHeight);
|
|
end;
|
|
end;
|
|
|
|
{$IFDEF Gtk2}
|
|
if (Widget^.parent<>nil)
|
|
and GtkWidgetIsA(Widget^.parent,GTK_TYPE_FIXED)
|
|
and GTK_WIDGET_NO_WINDOW(Widget^.parent)
|
|
then begin
|
|
inc(LCLLeft, Widget^.parent^.allocation.x);
|
|
inc(LCLTop, Widget^.parent^.allocation.y);
|
|
end;
|
|
|
|
// commit size and position
|
|
allocation:=Widget^.allocation;
|
|
allocation.x:=LCLLeft;
|
|
allocation.y:=LCLTop;
|
|
allocation.width:=LCLWidth;
|
|
allocation.height:=LCLHeight;
|
|
//DebugLn(['SetWidgetSizeAndPosition ',DbgSName(LCLControl),' LCL=',dbgs(LCLControl.BoundsRect),' allocation=',dbgs(allocation),' ',GetWidgetDebugReport(Widget)]);
|
|
gtk_widget_size_allocate(Widget,@allocation);// Beware: this triggers callbacks
|
|
{$ENDIF}
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: SetWindowSizeAndPosition
|
|
Params: Widget: PGtkWidget; AWinControl: TWinControl
|
|
Returns: Nothing
|
|
|
|
Set the size and position of a top level window.
|
|
------------------------------------------------------------------------------}
|
|
procedure SetWindowSizeAndPosition(Window: PGtkWindow;
|
|
AWinControl: TWinControl);
|
|
var
|
|
Width, Height: integer;
|
|
{$IFDEF Gtk2}
|
|
allocation: TGtkAllocation;
|
|
{$ENDIF}
|
|
//Info: PGtkWindowGeometryInfo;
|
|
begin
|
|
Width:=AWinControl.Width;
|
|
// 0 and negative values have a special meaning, so don't use them
|
|
if Width<=0 then Width:=1;
|
|
Height:=AWinControl.Height;
|
|
if Height<=0 then Height:=1;
|
|
|
|
{$IFDEF VerboseSizeMsg}
|
|
DebugLn(['TGtkWidgetSet.SetWindowSizeAndPosition START ',DbgSName(AWinControl),' ',AWinControl.Visible,' Old=',PGtkWidget(Window)^.allocation.Width,',',PGtkWidget(Window)^.allocation.Width,' New=',Width,',',Height]);
|
|
{$ENDIF}
|
|
// set geometry default size
|
|
//Info:=gtk_window_get_geometry_info(Window, TRUE);
|
|
//if (Info^.default_width<>Width) or (Info^.default_height<>Height) then
|
|
gtk_window_set_default_size(Window, Width, Height);
|
|
|
|
{$IFDEF Gtk2}
|
|
// resize
|
|
gtk_window_resize(Window, Width, Height);
|
|
// reposition
|
|
gtk_window_move(Window, AWinControl.Left, AWinControl.Top);
|
|
// force early resize
|
|
allocation := PGtkWidget(Window)^.allocation;
|
|
allocation.width := Width;
|
|
allocation.height := Height;
|
|
//DebugLn(['SetWindowSizeAndPosition ',DbgSName(AWinControl),' ',dbgs(allocation)]);
|
|
gtk_widget_size_allocate(PGtkWidget(Window), @allocation);// Beware: this triggers callbacks
|
|
|
|
if (PGtkWidget(Window)^.Window <> nil) then
|
|
begin
|
|
// resize gdkwindow directly (sometimes the gtk forgets this)
|
|
gdk_window_move_resize(PGtkWidget(Window)^.Window,AWinControl.Left,
|
|
AWinControl.Top,Width,Height)
|
|
end;
|
|
{$ELSE}
|
|
// resize
|
|
if assigned(PGtkWidget(Window)^.Window) then
|
|
// widget is realized, resize gdkwindow directly
|
|
gdk_window_move_resize(PGtkWidget(Window)^.Window,AWinControl.Left,
|
|
AWinControl.Top,Width,Height)
|
|
else begin
|
|
// widget is not yet realized, force resize needed for shrinking under gtk1
|
|
gtk_widget_set_usize(PGtkWidget(Window), -1,-1);
|
|
end;
|
|
// reposition
|
|
gtk_widget_set_usize(PGtkWidget(Window),Width,Height);
|
|
gtk_widget_set_uposition(PGtkWidget(Window),AWinControl.Left,AWinControl.Top);
|
|
{$ENDIF}
|
|
|
|
{$IFDEF VerboseSizeMsg}
|
|
DebugLn(['SetWindowSizeAndPosition B ',DbgSName(AWinControl),
|
|
' Visible=',AWinControl.Visible,
|
|
' Cur=',PGtkWidget(Window)^.allocation.X,',',PGtkWidget(Window)^.allocation.Y,
|
|
' New=',AWinControl.Left,',',AWinControl.Top,',',Width,'x',Height]);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
GetWidgetRelativePosition
|
|
|
|
Returns the Left, Top, relative to the client origin of its parent
|
|
-------------------------------------------------------------------------------}
|
|
procedure GetWidgetRelativePosition(aWidget: PGtkWidget; var Left, Top: integer);
|
|
var
|
|
GdkWindow: PGdkWindow;
|
|
LCLControl: TWinControl;
|
|
GtkLeft, GtkTop: GInt;
|
|
begin
|
|
Left:=aWidget^.allocation.X;
|
|
Top:=aWidget^.allocation.Y;
|
|
{$IFDEF Gtk2}
|
|
if (aWidget^.parent<>nil)
|
|
and (not GtkWidgetIsA(aWidget^.parent,GTK_TYPE_FIXED))
|
|
and (not GtkWidgetIsA(aWidget^.parent,GTK_TYPE_LAYOUT))
|
|
then begin
|
|
// widget is not on a normal client area. e.g. TPage
|
|
Left:=0;
|
|
Top:=0;
|
|
end
|
|
else
|
|
if (aWidget^.parent<>nil)
|
|
and GtkWidgetIsA(aWidget^.parent,GTK_TYPE_FIXED)
|
|
and GTK_WIDGET_NO_WINDOW(aWidget^.parent)
|
|
then begin
|
|
// widget on a fixed, but fixed w/o window
|
|
Dec(Left, PGtkWidget(aWidget^.parent)^.allocation.x);
|
|
Dec(Top, PGtkWidget(aWidget^.parent)^.allocation.y);
|
|
end;
|
|
{$ENDIF}
|
|
if GtkWidgetIsA(aWidget,GTK_TYPE_WINDOW) then begin
|
|
GdkWindow:=GetControlWindow(aWidget);
|
|
if (GdkWindow<>nil) and (GTK_WIDGET_MAPPED(aWidget)) then begin
|
|
// window is mapped = window manager has put the window somewhere
|
|
gdk_window_get_root_origin(GdkWindow, @GtkLeft, @GtkTop);
|
|
Left := GtkLeft;
|
|
Top := GtkTop;
|
|
end else begin
|
|
// the gtk has not yet put the window to the final position
|
|
// => the gtk/gdk position is not reliable
|
|
// => use the LCL coords
|
|
LCLControl:=GetLCLObject(aWidget) as TWinControl;
|
|
Left:=LCLControl.Left;
|
|
Top:=LCLControl.Top;
|
|
end;
|
|
//DebugLn(['TGtkWidgetSet.GetWindowRelativePosition ',GetWidgetDebugReport(aWidget),' Left=',Left,' Top=',Top,' GdkWindow=',GdkWindow<>nil]);
|
|
end;
|
|
//DebugLn(['TGtkWidgetSet.GetWindowRelativePosition ',GetWidgetDebugReport(aWidget),' Left=',Left,' Top=',Top]);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
UnsetResizeRequest
|
|
Params: Widget: PGtkWidget
|
|
|
|
Unset the mark for the Widget to send a ResizeRequest to the gtk.
|
|
LCL size requests for a widget are cached and only the last one is sent. Some
|
|
widgets like forms send a resize request immediately. To avoid sending resize
|
|
requests multiple times they can unset the mark with this procedure.
|
|
------------------------------------------------------------------------------}
|
|
procedure UnsetResizeRequest(Widget: PGtkWidget);
|
|
begin
|
|
{$IFDEF VerboseSizeMsg}
|
|
if FWidgetsWithResizeRequest.Contains(Widget) then begin
|
|
DebugLn(['UnsetResizeRequest ',GetWidgetDebugReport(Widget)]);
|
|
end;
|
|
{$ENDIF}
|
|
FWidgetsWithResizeRequest.Remove(Widget);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
TGtkWidgetSet SetResizeRequest
|
|
Params: Widget: PGtkWidget
|
|
|
|
Marks the widget to send a ResizeRequest to the gtk.
|
|
When the LCL resizes a control the new bounds will not be set directly, but
|
|
cached. This is needed, because it is common behaviour to set the bounds step
|
|
by step. For example: Left:=10; Top:=10; Width:=100; Height:=50; results in
|
|
SetBounds(10,0,0,0);
|
|
SetBounds(10,10,0,0);
|
|
SetBounds(10,10,100,0);
|
|
SetBounds(10,10,100,50);
|
|
Because the gtk puts all size requests into a queue, it will process the
|
|
requests not immediately, but _after_ all requests. This results in changing
|
|
the widget size four times and everytime the LCL gets a message. If the
|
|
control has children, this will resize the children four times.
|
|
Therefore LCL size requests for a widget are cached and only the final one is
|
|
sent in: TGtkWidgetSet.SendCachedLCLMessages.
|
|
------------------------------------------------------------------------------}
|
|
procedure SetResizeRequest(Widget: PGtkWidget);
|
|
{$IFDEF VerboseSizeMsg}
|
|
var
|
|
LCLControl: TWinControl;
|
|
{$ENDIF}
|
|
begin
|
|
{$IFDEF Gtk2}
|
|
if not WidgetSizeIsEditable(Widget) then exit;
|
|
{$ENDIF}
|
|
{$IFDEF VerboseSizeMsg}
|
|
LCLControl:=TWinControl(GetLCLObject(Widget));
|
|
DbgOut('SetResizeRequest Widget=',DbgS(Widget));
|
|
if LCLControl is TWinControl then
|
|
DebugLn(' ',DbgSName(LCLControl),' LCLBounds=',dbgs(LCLControl.BoundsRect))
|
|
else
|
|
DebugLn(' ERROR: ',DbgSName(LCLControl));
|
|
{$ENDIF}
|
|
if not FWidgetsWithResizeRequest.Contains(Widget) then
|
|
FWidgetsWithResizeRequest.Add(Widget);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function WidgetSizeIsEditable(Widget: PGtkWidget): boolean;
|
|
|
|
True if the widget can be resized.
|
|
False if the size is under complete control of the gtk.
|
|
------------------------------------------------------------------------------}
|
|
function WidgetSizeIsEditable(Widget: PGtkWidget): boolean;
|
|
begin
|
|
if Widget=nil then exit(false);
|
|
if (GtkWidgetIsA(Widget,GTK_TYPE_WINDOW))
|
|
or (GtkWidgetIsA(Widget^.Parent,gtk_fixed_get_type))
|
|
or (GtkWidgetIsA(Widget^.Parent,gtk_layout_get_type))
|
|
then
|
|
Result:=true
|
|
else
|
|
Result:=false;
|
|
end;
|
|
|
|
procedure ReportNotObsolete(const Texts : String);
|
|
Begin
|
|
DebugLn('*********************************************');
|
|
DebugLn('*********************************************');
|
|
DebugLn('*************Non-Obsolete report*************');
|
|
DebugLn('*********************************************');
|
|
DebugLn('*************'+Texts+'*is being used yet.****');
|
|
DebugLn('*******Please remove this function from******');
|
|
DebugLn('*******the obsolete section in gtkproc.inc***');
|
|
DebugLn('*********************************************');
|
|
DebugLn('*********************************************');
|
|
DebugLn('*********************************************');
|
|
DebugLn('*********************************************');
|
|
end;
|
|
|
|
function TGDKColorToTColor(const value : TGDKColor) : TColor;
|
|
begin
|
|
Result := ((Value.Blue shr 8) shl 16) + ((Value.Green shr 8) shl 8)
|
|
+ (Value.Red shr 8);
|
|
end;
|
|
|
|
function TColortoTGDKColor(const value : TColor) : TGDKColor;
|
|
var
|
|
newColor : TGDKColor;
|
|
begin
|
|
if Value<0 then begin
|
|
FillChar(Result,SizeOf(Result),0);
|
|
exit;
|
|
end;
|
|
|
|
newColor.pixel := 0;
|
|
newColor.red := (value and $ff) * 257;
|
|
newColor.green := ((value shr 8) and $ff) * 257;
|
|
newColor.blue := ((value shr 16) and $ff) * 257;
|
|
|
|
Result := newColor;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Function: UpdateSysColorMap
|
|
Params: none
|
|
Returns: none
|
|
|
|
Reads the system colors.
|
|
------------------------------------------------------------------------------}
|
|
procedure UpdateSysColorMap(Widget: PGtkWidget; Lgs: TLazGtkStyle);
|
|
{$IFDEF VerboseUpdateSysColorMap}
|
|
function GdkColorAsString(c: TgdkColor): string;
|
|
begin
|
|
Result:='LCL='+DbgS(TGDKColorToTColor(c))
|
|
+' Pixel='+DbgS(c.Pixel)
|
|
+' Red='+DbgS(c.Red)
|
|
+' Green='+DbgS(c.Green)
|
|
+' Blue='+DbgS(c.Blue)
|
|
;
|
|
end;
|
|
{$ENDIF}
|
|
var
|
|
MainStyle: PGtkStyle;
|
|
begin
|
|
if Widget=nil then exit;
|
|
if not (Lgs in [lgsButton, lgsWindow, lgsMenuBar, lgsMenuitem,
|
|
lgsVerticalScrollbar, lgsHorizontalScrollbar, lgsTooltip]) then exit;
|
|
|
|
{$IFDEF NoStyle}
|
|
exit;
|
|
{$ENDIF}
|
|
//debugln('UpdateSysColorMap ',GetWidgetDebugReport(Widget));
|
|
gtk_widget_set_rc_style(Widget);
|
|
MainStyle := gtk_widget_get_style(Widget);
|
|
if MainStyle = nil then exit;
|
|
with MainStyle^ do
|
|
begin
|
|
{$IFDEF VerboseUpdateSysColorMap}
|
|
if rc_style<>nil then
|
|
begin
|
|
with rc_style^ do
|
|
begin
|
|
DebugLn('rc_style:');
|
|
DebugLn(' FG GTK_STATE_NORMAL ',GdkColorAsString(fg[GTK_STATE_NORMAL]));
|
|
DebugLn(' FG GTK_STATE_ACTIVE ',GdkColorAsString(fg[GTK_STATE_ACTIVE]));
|
|
DebugLn(' FG GTK_STATE_PRELIGHT ',GdkColorAsString(fg[GTK_STATE_PRELIGHT]));
|
|
DebugLn(' FG GTK_STATE_SELECTED ',GdkColorAsString(fg[GTK_STATE_SELECTED]));
|
|
DebugLn(' FG GTK_STATE_INSENSITIVE ',GdkColorAsString(fg[GTK_STATE_INSENSITIVE]));
|
|
DebugLn('');
|
|
DebugLn(' BG GTK_STATE_NORMAL ',GdkColorAsString(bg[GTK_STATE_NORMAL]));
|
|
DebugLn(' BG GTK_STATE_ACTIVE ',GdkColorAsString(bg[GTK_STATE_ACTIVE]));
|
|
DebugLn(' BG GTK_STATE_PRELIGHT ',GdkColorAsString(bg[GTK_STATE_PRELIGHT]));
|
|
DebugLn(' BG GTK_STATE_SELECTED ',GdkColorAsString(bg[GTK_STATE_SELECTED]));
|
|
DebugLn(' BG GTK_STATE_INSENSITIVE ',GdkColorAsString(bg[GTK_STATE_INSENSITIVE]));
|
|
DebugLn('');
|
|
DebugLn(' TEXT GTK_STATE_NORMAL ',GdkColorAsString(text[GTK_STATE_NORMAL]));
|
|
DebugLn(' TEXT GTK_STATE_ACTIVE ',GdkColorAsString(text[GTK_STATE_ACTIVE]));
|
|
DebugLn(' TEXT GTK_STATE_PRELIGHT ',GdkColorAsString(text[GTK_STATE_PRELIGHT]));
|
|
DebugLn(' TEXT GTK_STATE_SELECTED ',GdkColorAsString(text[GTK_STATE_SELECTED]));
|
|
DebugLn(' TEXT GTK_STATE_INSENSITIVE ',GdkColorAsString(text[GTK_STATE_INSENSITIVE]));
|
|
DebugLn('');
|
|
end;
|
|
end;
|
|
|
|
DebugLn('MainStyle:');
|
|
DebugLn(' FG GTK_STATE_NORMAL ',GdkColorAsString(fg[GTK_STATE_NORMAL]));
|
|
DebugLn(' FG GTK_STATE_ACTIVE ',GdkColorAsString(fg[GTK_STATE_ACTIVE]));
|
|
DebugLn(' FG GTK_STATE_PRELIGHT ',GdkColorAsString(fg[GTK_STATE_PRELIGHT]));
|
|
DebugLn(' FG GTK_STATE_SELECTED ',GdkColorAsString(fg[GTK_STATE_SELECTED]));
|
|
DebugLn(' FG GTK_STATE_INSENSITIVE ',GdkColorAsString(fg[GTK_STATE_INSENSITIVE]));
|
|
DebugLn('');
|
|
DebugLn(' BG GTK_STATE_NORMAL ',GdkColorAsString(bg[GTK_STATE_NORMAL]));
|
|
DebugLn(' BG GTK_STATE_ACTIVE ',GdkColorAsString(bg[GTK_STATE_ACTIVE]));
|
|
DebugLn(' BG GTK_STATE_PRELIGHT ',GdkColorAsString(bg[GTK_STATE_PRELIGHT]));
|
|
DebugLn(' BG GTK_STATE_SELECTED ',GdkColorAsString(bg[GTK_STATE_SELECTED]));
|
|
DebugLn(' BG GTK_STATE_INSENSITIVE ',GdkColorAsString(bg[GTK_STATE_INSENSITIVE]));
|
|
DebugLn('');
|
|
DebugLn(' TEXT GTK_STATE_NORMAL ',GdkColorAsString(text[GTK_STATE_NORMAL]));
|
|
DebugLn(' TEXT GTK_STATE_ACTIVE ',GdkColorAsString(text[GTK_STATE_ACTIVE]));
|
|
DebugLn(' TEXT GTK_STATE_PRELIGHT ',GdkColorAsString(text[GTK_STATE_PRELIGHT]));
|
|
DebugLn(' TEXT GTK_STATE_SELECTED ',GdkColorAsString(text[GTK_STATE_SELECTED]));
|
|
DebugLn(' TEXT GTK_STATE_INSENSITIVE ',GdkColorAsString(text[GTK_STATE_INSENSITIVE]));
|
|
DebugLn('');
|
|
DebugLn(' LIGHT GTK_STATE_NORMAL ',GdkColorAsString(light[GTK_STATE_NORMAL]));
|
|
DebugLn(' LIGHT GTK_STATE_ACTIVE ',GdkColorAsString(light[GTK_STATE_ACTIVE]));
|
|
DebugLn(' LIGHT GTK_STATE_PRELIGHT ',GdkColorAsString(light[GTK_STATE_PRELIGHT]));
|
|
DebugLn(' LIGHT GTK_STATE_SELECTED ',GdkColorAsString(light[GTK_STATE_SELECTED]));
|
|
DebugLn(' LIGHT GTK_STATE_INSENSITIVE ',GdkColorAsString(light[GTK_STATE_INSENSITIVE]));
|
|
DebugLn('');
|
|
DebugLn(' DARK GTK_STATE_NORMAL ',GdkColorAsString(dark[GTK_STATE_NORMAL]));
|
|
DebugLn(' DARK GTK_STATE_ACTIVE ',GdkColorAsString(dark[GTK_STATE_ACTIVE]));
|
|
DebugLn(' DARK GTK_STATE_PRELIGHT ',GdkColorAsString(dark[GTK_STATE_PRELIGHT]));
|
|
DebugLn(' DARK GTK_STATE_SELECTED ',GdkColorAsString(dark[GTK_STATE_SELECTED]));
|
|
DebugLn(' DARK GTK_STATE_INSENSITIVE ',GdkColorAsString(dark[GTK_STATE_INSENSITIVE]));
|
|
DebugLn('');
|
|
DebugLn(' MID GTK_STATE_NORMAL ',GdkColorAsString(mid[GTK_STATE_NORMAL]));
|
|
DebugLn(' MID GTK_STATE_ACTIVE ',GdkColorAsString(mid[GTK_STATE_ACTIVE]));
|
|
DebugLn(' MID GTK_STATE_PRELIGHT ',GdkColorAsString(mid[GTK_STATE_PRELIGHT]));
|
|
DebugLn(' MID GTK_STATE_SELECTED ',GdkColorAsString(mid[GTK_STATE_SELECTED]));
|
|
DebugLn(' MID GTK_STATE_INSENSITIVE ',GdkColorAsString(mid[GTK_STATE_INSENSITIVE]));
|
|
DebugLn('');
|
|
DebugLn(' BASE GTK_STATE_NORMAL ',GdkColorAsString(base[GTK_STATE_NORMAL]));
|
|
DebugLn(' BASE GTK_STATE_ACTIVE ',GdkColorAsString(base[GTK_STATE_ACTIVE]));
|
|
DebugLn(' BASE GTK_STATE_PRELIGHT ',GdkColorAsString(base[GTK_STATE_PRELIGHT]));
|
|
DebugLn(' BASE GTK_STATE_SELECTED ',GdkColorAsString(base[GTK_STATE_SELECTED]));
|
|
DebugLn(' BASE GTK_STATE_INSENSITIVE ',GdkColorAsString(base[GTK_STATE_INSENSITIVE]));
|
|
DebugLn('');
|
|
DebugLn(' BLACK ',GdkColorAsString(black));
|
|
DebugLn(' WHITE ',GdkColorAsString(white));
|
|
{$ENDIF}
|
|
|
|
{$IFNDEF DisableGtkSysColors}
|
|
// this map is taken from this research:
|
|
// http://www.endolith.com/wordpress/2008/08/03/wine-colors/
|
|
case Lgs of
|
|
lgsButton:
|
|
begin
|
|
SysColorMap[COLOR_ACTIVEBORDER] := TGDKColorToTColor(bg[GTK_STATE_INSENSITIVE]);
|
|
SysColorMap[COLOR_INACTIVEBORDER] := TGDKColorToTColor(bg[GTK_STATE_INSENSITIVE]);
|
|
SysColorMap[COLOR_WINDOWFRAME] := TGDKColorToTColor(mid[GTK_STATE_SELECTED]);
|
|
|
|
SysColorMap[COLOR_BTNFACE] := TGDKColorToTColor(bg[GTK_STATE_INSENSITIVE]);
|
|
SysColorMap[COLOR_BTNSHADOW] := TGDKColorToTColor(dark[GTK_STATE_INSENSITIVE]);
|
|
SysColorMap[COLOR_BTNTEXT] := TGDKColorToTColor(fg[GTK_STATE_NORMAL]);
|
|
SysColorMap[COLOR_BTNHIGHLIGHT] := TGDKColorToTColor(light[GTK_STATE_INSENSITIVE]);
|
|
SysColorMap[COLOR_3DDKSHADOW] := TGDKColorToTColor(black);
|
|
SysColorMap[COLOR_3DLIGHT] := TGDKColorToTColor(bg[GTK_STATE_INSENSITIVE]);
|
|
end;
|
|
lgsWindow:
|
|
begin
|
|
// colors which can be only retrieved from the window manager (metacity)
|
|
SysColorMap[COLOR_ACTIVECAPTION] := TGDKColorToTColor(dark[GTK_STATE_SELECTED]);
|
|
SysColorMap[COLOR_INACTIVECAPTION] := TGDKColorToTColor(dark[GTK_STATE_NORMAL]);
|
|
SysColorMap[COLOR_GRADIENTACTIVECAPTION] := TGDKColorToTColor(light[GTK_STATE_SELECTED]);
|
|
SysColorMap[COLOR_GRADIENTINACTIVECAPTION] := TGDKColorToTColor(base[GTK_STATE_NORMAL]);
|
|
SysColorMap[COLOR_CAPTIONTEXT] := TGDKColorToTColor(white);
|
|
SysColorMap[COLOR_INACTIVECAPTIONTEXT] := TGDKColorToTColor(white);
|
|
// others
|
|
SysColorMap[COLOR_APPWORKSPACE] := TGDKColorToTColor(base[GTK_STATE_NORMAL]);
|
|
SysColorMap[COLOR_GRAYTEXT] := TGDKColorToTColor(fg[GTK_STATE_INSENSITIVE]);
|
|
SysColorMap[COLOR_HIGHLIGHT] := TGDKColorToTColor(base[GTK_STATE_SELECTED]);
|
|
SysColorMap[COLOR_HIGHLIGHTTEXT] := TGDKColorToTColor(fg[GTK_STATE_SELECTED]);
|
|
SysColorMap[COLOR_WINDOW] := TGDKColorToTColor(base[GTK_STATE_NORMAL]);
|
|
SysColorMap[COLOR_WINDOWTEXT] := TGDKColorToTColor(text[GTK_STATE_NORMAL]);
|
|
SysColorMap[COLOR_HOTLIGHT] := TGDKColorToTColor(light[GTK_STATE_NORMAL]);
|
|
SysColorMap[COLOR_BACKGROUND] := TGDKColorToTColor(bg[GTK_STATE_PRELIGHT]);
|
|
SysColorMap[COLOR_FORM] := TGDKColorToTColor(bg[GTK_STATE_NORMAL]);
|
|
end;
|
|
lgsMenuBar:
|
|
begin
|
|
SysColorMap[COLOR_MENUBAR] := TGDKColorToTColor(bg[GTK_STATE_NORMAL]);
|
|
end;
|
|
lgsMenuitem:
|
|
begin
|
|
SysColorMap[COLOR_MENU] := TGDKColorToTColor(light[GTK_STATE_ACTIVE]);
|
|
SysColorMap[COLOR_MENUTEXT] := TGDKColorToTColor(fg[GTK_STATE_NORMAL]);
|
|
SysColorMap[COLOR_MENUHILIGHT] := TGDKColorToTColor(bg[GTK_STATE_PRELIGHT]);
|
|
end;
|
|
lgsVerticalScrollbar,
|
|
lgsHorizontalScrollbar:
|
|
begin
|
|
SysColorMap[COLOR_SCROLLBAR] := TGDKColorToTColor(bg[GTK_STATE_ACTIVE]);
|
|
end;
|
|
lgsTooltip:
|
|
begin
|
|
SysColorMap[COLOR_INFOTEXT] := TGDKColorToTColor(fg[GTK_STATE_NORMAL]);
|
|
SysColorMap[COLOR_INFOBK] := TGDKColorToTColor(bg[GTK_STATE_NORMAL]);
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
|
|
|
|
{------------------------------------------------------------------------------
|
|
Function: WaitForClipbrdAnswerDummyTimer
|
|
|
|
this is a helper function for WaitForClipboardAnswer
|
|
------------------------------------------------------------------------------}
|
|
function WaitForClipbrdAnswerDummyTimer(Client: Pointer): {$IFDEF Gtk2}gboolean{$ELSE}gint{$ENDIF}; cdecl;
|
|
begin
|
|
if CLient=nil then ;
|
|
Result:=GdkTrue; // go on, make sure getting a message at least every second
|
|
end;
|
|
|
|
function GetScreenWidthMM(GdkValue: boolean): integer;
|
|
begin
|
|
Result:=gdk_screen_width_mm;
|
|
if (Result<=0) and not GdkValue then
|
|
Result:=300; // some TV-out screens don't know there size
|
|
end;
|
|
|
|
function GetScreenHeightMM(GdkValue: boolean): integer;
|
|
begin
|
|
Result:=gdk_screen_height_mm;
|
|
if (Result<=0) and not GdkValue then
|
|
Result:=300; // some TV-out screens don't know there size
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Function: WaitForClipboardAnswer
|
|
Params: none
|
|
Returns: true, if clipboard data arrived
|
|
|
|
waits til clipboard/selection answer arrived (max 1 second)
|
|
! While waiting the messagequeue will be processed !
|
|
------------------------------------------------------------------------------}
|
|
function WaitForClipboardAnswer(c: PClipboardEventData): boolean;
|
|
var
|
|
StartTime, CurTime: TSystemTime;
|
|
Timer: cardinal;
|
|
|
|
function ValidDateSelection : boolean;
|
|
begin
|
|
result := c^.Data.Selection<>0;
|
|
end;
|
|
|
|
begin
|
|
Result:=false;
|
|
{$IFDEF DEBUG_CLIPBOARD}
|
|
DebugLn('[WaitForClipboardAnswer] A');
|
|
{$ENDIF}
|
|
if (ValidDateSelection) or (c^.Waiting) or (c^.Stopping) then begin
|
|
{$IFDEF DEBUG_CLIPBOARD}
|
|
DebugLn('[WaitForClipboardAnswer] ValidDateSelection=',dbgs(ValidDateSelection),' Waiting=',dbgs(c^.Waiting),' Stopping=',dbgs(c^.Stopping));
|
|
{$ENDIF}
|
|
Result:=(ValidDateSelection);
|
|
exit;
|
|
end;
|
|
c^.Waiting:=true;
|
|
DateTimeToSystemTime(Time,StartTime);
|
|
//DebugLn('[WaitForClipboardAnswer] C');
|
|
Application.ProcessMessages;
|
|
//DebugLn('[WaitForClipboardAnswer] D');
|
|
if (ValidDateSelection) or (c^.Stopping) then begin
|
|
{$IFDEF DEBUG_CLIPBOARD}
|
|
DebugLn('[WaitForClipboardAnswer] E Yeah, Response received after processing messages');
|
|
{$ENDIF}
|
|
Result:=(ValidDateSelection);
|
|
exit;
|
|
end;
|
|
//DebugLn('[WaitForClipboardAnswer] F');
|
|
// start a timer to make sure not waiting forever
|
|
Timer := gtk_timeout_add(500, @WaitForClipbrdAnswerDummyTimer, nil);
|
|
try
|
|
repeat
|
|
// just wait ...
|
|
{$IFDEF DEBUG_CLIPBOARD}
|
|
DebugLn('[WaitForClipboardAnswer] G');
|
|
{$ENDIF}
|
|
Application.ProcessMessages;
|
|
if (ValidDateSelection) or (c^.Stopping) then begin
|
|
{$IFDEF DEBUG_CLIPBOARD}
|
|
DebugLn('[WaitForClipboardAnswer] H Yeah, Response received after waiting with timer');
|
|
{$ENDIF}
|
|
Result:=(ValidDateSelection);
|
|
exit;
|
|
end;
|
|
DateTimeToSystemTime(Time,CurTime);
|
|
until (CurTime.Second*1000+CurTime.MilliSecond
|
|
-StartTime.Second*1000-StartTime.MilliSecond
|
|
>1000);
|
|
finally
|
|
{$IFDEF DEBUG_CLIPBOARD}
|
|
DebugLn('[WaitForClipboardAnswer] H');
|
|
{$ENDIF}
|
|
// stop the timer
|
|
gtk_timeout_remove(Timer);
|
|
//DebugLn('[WaitForClipboardAnswer] END');
|
|
end;
|
|
{ $IFDEF DEBUG_CLIPBOARD}
|
|
DebugLn('[WaitForClipboardAnswer] WARNING: no answer received in time');
|
|
{ $ENDIF}
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Function: RequestSelectionData
|
|
Params: ClipboardWidget - widget with connected signals 'selection_get'
|
|
and 'selection_clear_event'
|
|
ClipboardType
|
|
FormatID - the selection target format wanted
|
|
Returns: the TGtkSelectionData record
|
|
|
|
requests the format FormatID of clipboard of type ClipboardType and
|
|
waits til clipboard/selection answer arrived (max 1 second)
|
|
! While waiting the messagequeue will be processed !
|
|
------------------------------------------------------------------------------}
|
|
function RequestSelectionData(ClipboardWidget: PGtkWidget;
|
|
ClipboardType: TClipboardType; FormatID: PtrUInt): TGtkSelectionData;
|
|
|
|
function TimeIDExists(TimeID: guint32): boolean;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
i:=ClipboardSelectionData.Count-1;
|
|
while (i>=0) do begin
|
|
if (PClipboardEventData(ClipboardSelectionData[i])^.TimeID=TimeID) then
|
|
exit(true);
|
|
dec(i);
|
|
end;
|
|
Result:=false;
|
|
end;
|
|
|
|
var
|
|
TimeID: cardinal;
|
|
c: PClipboardEventData;
|
|
sanity: Integer = 0;
|
|
begin
|
|
{$IFDEF DEBUG_CLIPBOARD}
|
|
DebugLn('[RequestSelectionData] FormatID=',dbgs(FormatID));
|
|
{$ENDIF}
|
|
FillChar(Result,SizeOf(TGtkSelectionData),0);
|
|
if (ClipboardWidget=nil) or (FormatID=0)
|
|
or (ClipboardTypeAtoms[ClipboardType]=0) then exit;
|
|
|
|
TimeID:= gdk_event_get_time(gtk_get_current_event);
|
|
// IMPORTANT: To retrieve data from xterm or kde applications
|
|
// the time id must be 0 or event^.time
|
|
repeat
|
|
while TimeIDExists(TimeID) do begin
|
|
inc(TimeID);
|
|
if TimeID>1010 then exit;
|
|
end;
|
|
New(c);
|
|
FillChar(c^,SizeOf(TClipboardEventData),0);
|
|
c^.TimeID:=TimeID;
|
|
ClipboardSelectionData.Add(c);
|
|
try
|
|
{$IFDEF DEBUG_CLIPBOARD}
|
|
DebugLn('[RequestSelectionData] TimeID=',dbgs(TimeID),' Type=',GdkAtomToStr(ClipboardTypeAtoms[ClipboardType]),' FormatID=',GdkAtomToStr(FormatID), ' Sanity=', IntToStr(Sanity));
|
|
{$ENDIF}
|
|
if gtk_selection_convert(ClipboardWidget, ClipboardTypeAtoms[ClipboardType],
|
|
FormatID, TimeID)<>GdkFalse
|
|
then begin
|
|
if not WaitForClipboardAnswer(c) then exit;
|
|
Result:=c^.Data;
|
|
break;
|
|
end;
|
|
finally
|
|
ClipboardSelectionData.Remove(c);
|
|
Dispose(c);
|
|
end;
|
|
Inc(sanity);
|
|
sleep(100);
|
|
until false or (sanity > 10);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Function: FreeClipboardTargetEntries
|
|
Params: ClipboardType
|
|
Returns: -
|
|
|
|
frees the memory of a ClipboardTargetEntries list
|
|
------------------------------------------------------------------------------}
|
|
procedure FreeClipboardTargetEntries(ClipboardType: TClipboardType);
|
|
var i: integer;
|
|
begin
|
|
if ClipboardTargetEntries[ClipboardType]<>nil then begin
|
|
for i:=0 to ClipboardTargetEntryCnt[ClipboardType]-1 do
|
|
StrDispose(ClipboardTargetEntries[ClipboardType][i].Target);
|
|
FreeMem(ClipboardTargetEntries[ClipboardType]);
|
|
end;
|
|
end;
|
|
|
|
|
|
{------------------------------------------------------------------------------
|
|
function GdkAtomToStr(const Atom: TGdkAtom): string;
|
|
|
|
Returns the associated string
|
|
------------------------------------------------------------------------------}
|
|
function GdkAtomToStr(const Atom: TGdkAtom): string;
|
|
var
|
|
p: Pgchar;
|
|
begin
|
|
p:=gdk_atom_name(Atom);
|
|
Result:=p;
|
|
if p<>nil then g_free(p);
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
function CreateFormContents(AForm: TCustomForm;
|
|
var FormWidget: Pointer): Pointer;
|
|
|
|
Creates the contents for the form (normally a hbox plus a client area.
|
|
The hbox is needed for the menu.) The FormWidget is the main widget, for which
|
|
the client area is associated. If FormWidget=nil then the hbox will be used
|
|
as main widget.
|
|
-------------------------------------------------------------------------------}
|
|
function CreateFormContents(AForm: TCustomForm;
|
|
var FormWidget: Pointer; AWidgetInfo: PWidgetInfo = nil): Pointer;
|
|
var
|
|
ScrolledWidget, ClientAreaWidget: PGtkWidget;
|
|
WindowStyle: PGtkStyle;
|
|
Adjustment: PGtkAdjustment;
|
|
begin
|
|
// Create the VBox. We need that to place controls outside
|
|
// the client area (like menu)
|
|
Result := gtk_vbox_new(False, 0);
|
|
|
|
if FormWidget = nil then
|
|
FormWidget := Result;
|
|
|
|
// Create the form client area (a scrolled window with a gtklayout
|
|
// with the style of a window)
|
|
ScrolledWidget := gtk_scrolled_window_new(nil, nil);
|
|
gtk_box_pack_end(Result, ScrolledWidget, True, True, 0);
|
|
gtk_widget_show(ScrolledWidget);
|
|
|
|
ClientAreaWidget := gtk_layout_new(nil, nil);
|
|
WindowStyle := GetStyle(lgsWindow);
|
|
gtk_widget_set_style(ClientAreaWidget, WindowStyle);
|
|
//debugln('CreateFormContents Style=',GetStyleDebugReport(WindowStyle));
|
|
gtk_container_add(PGtkContainer(ScrolledWidget), ClientAreaWidget);
|
|
|
|
gtk_object_set_data(FormWidget, odnScrollArea, ScrolledWidget);
|
|
|
|
gtk_widget_show(ClientAreaWidget);
|
|
SetFixedWidget(FormWidget, ClientAreaWidget);
|
|
SetMainWidget(FormWidget, ClientAreaWidget);
|
|
|
|
if ScrolledWidget <> nil then
|
|
begin
|
|
GTK_WIDGET_UNSET_FLAGS(PGtkScrolledWindow(ScrolledWidget)^.hscrollbar,
|
|
GTK_CAN_FOCUS);
|
|
GTK_WIDGET_UNSET_FLAGS(PGtkScrolledWindow(ScrolledWidget)^.vscrollbar,
|
|
GTK_CAN_FOCUS);
|
|
gtk_scrolled_window_set_policy(PGtkScrolledWindow(ScrolledWidget),
|
|
GTK_POLICY_NEVER,GTK_POLICY_NEVER);
|
|
|
|
Adjustment := gtk_scrolled_window_get_vadjustment(PGTKScrolledWindow(ScrolledWidget));
|
|
if Adjustment <> nil then
|
|
gtk_object_set_data(PGTKObject(Adjustment), odnScrollBar,
|
|
PGTKScrolledWindow(ScrolledWidget)^.vscrollbar);
|
|
|
|
Adjustment := gtk_scrolled_window_get_hadjustment(PGTKScrolledWindow(ScrolledWidget));
|
|
if Adjustment <> nil then
|
|
gtk_object_set_data(PGTKObject(Adjustment), odnScrollBar,
|
|
PGTKScrolledWindow(ScrolledWidget)^.hscrollbar);
|
|
{$ifdef gtk2}
|
|
if (AWidgetInfo <> nil) and
|
|
(gtk_major_version >= 2) and (gtk_minor_version > 8) then
|
|
begin
|
|
g_signal_connect(PGTKScrolledWindow(ScrolledWidget)^.hscrollbar, 'change-value',
|
|
TGCallback(@Gtk2RangeScrollCB), AWidgetInfo);
|
|
g_signal_connect(PGTKScrolledWindow(ScrolledWidget)^.vscrollbar, 'change-value',
|
|
TGCallback(@Gtk2RangeScrollCB), AWidgetInfo);
|
|
end;
|
|
{$endif}
|
|
end;
|
|
end;
|
|
|
|
function IndexOfStyle(aStyle: TLazGtkStyle): integer;
|
|
begin
|
|
Result:=IndexOfStyleWithName(LazGtkStyleNames[aStyle]);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Function: IndexOfWithNameStyle
|
|
Params: WName
|
|
Returns: Index of Style
|
|
|
|
Returns the Index within the Styles property of WNAME
|
|
------------------------------------------------------------------------------}
|
|
function IndexOfStyleWithName(const WName : String): integer;
|
|
begin
|
|
if Styles<>nil then begin
|
|
for Result:=0 to Styles.Count-1 do
|
|
if CompareText(WName,Styles[Result])=0 then exit;
|
|
end;
|
|
Result:=-1;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Function: ReleaseStyle
|
|
Params: WName
|
|
Returns: nothing
|
|
|
|
Tries to release a Style corresponding to the Widget Name passed, aka 'button',
|
|
'default', checkbox', etc. This should only be called on theme change or on
|
|
application terminate.
|
|
------------------------------------------------------------------------------}
|
|
function NewStyleObject : PStyleObject;
|
|
begin
|
|
New(Result);
|
|
FillChar(Result^, SizeOf(TStyleObject), 0);
|
|
end;
|
|
|
|
procedure FreeStyleObject(var StyleObject : PStyleObject);
|
|
// internal function to dispose a styleobject
|
|
// it does *not* remove it from the style lists
|
|
begin
|
|
if StyleObject <> nil then
|
|
begin
|
|
if StyleObject^.Obj <> nil then
|
|
gtk_object_destroy(StyleObject^.Obj);
|
|
if StyleObject^.Widget <> nil then
|
|
begin
|
|
// first unref
|
|
gtk_widget_unref(StyleObject^.Widget);
|
|
// then destroy
|
|
gtk_widget_destroy(StyleObject^.Widget);
|
|
end;
|
|
if StyleObject^.Style <> nil then
|
|
if StyleObject^.Style^.{$IFDEF Gtk2}attach_count{$ELSE}Ref_Count{$ENDIF} > 0 then
|
|
gtk_style_unref(StyleObject^.Style);
|
|
Dispose(StyleObject);
|
|
StyleObject := nil;
|
|
end;
|
|
end;
|
|
|
|
procedure ReleaseAllStyles;
|
|
var
|
|
StyleObject: PStyleObject;
|
|
lgs: TLazGtkStyle;
|
|
i: Integer;
|
|
begin
|
|
if Styles=nil then exit;
|
|
{$IFDEF Gtk2}
|
|
if DefaultPangoLayout<>nil then begin
|
|
g_object_unref(DefaultPangoLayout);
|
|
DefaultPangoLayout:=nil;
|
|
end;
|
|
{$ENDIF}
|
|
for i:=Styles.Count-1 downto 0 do begin
|
|
StyleObject:=PStyleObject(Styles.Objects[i]);
|
|
FreeStyleObject(StyleObject);
|
|
end;
|
|
Styles.Clear;
|
|
for lgs:=Low(TLazGtkStyle) to High(TLazGtkStyle) do
|
|
StandardStyles[lgs]:=nil;
|
|
end;
|
|
|
|
procedure ReleaseStyle(aStyle: TLazGtkStyle);
|
|
var
|
|
StyleObject: PStyleObject;
|
|
l: Integer;
|
|
begin
|
|
if Styles=nil then exit;
|
|
if aStyle in [lgsUserDefined] then
|
|
RaiseGDBException('');// user styles are defined by name
|
|
StyleObject:=StandardStyles[aStyle];
|
|
if StyleObject<>nil then begin
|
|
l:=IndexOfStyle(aStyle);
|
|
Styles.Delete(l);
|
|
StandardStyles[aStyle]:=nil;
|
|
FreeStyleObject(StyleObject);
|
|
end;
|
|
end;
|
|
|
|
procedure ReleaseStyleWithName(const WName : String);
|
|
var
|
|
l : Longint;
|
|
s : PStyleObject;
|
|
begin
|
|
if Styles=nil then exit;
|
|
l := IndexOfStyleWithName(WName);
|
|
If l >= 0 then begin
|
|
If Styles.Objects[l] <> nil then
|
|
Try
|
|
s := PStyleObject(Styles.Objects[l]);
|
|
FreeStyleObject(S);
|
|
Except
|
|
DebugLn('[ReleaseStyle] : Unable To Unreference Style');
|
|
end;
|
|
Styles.Delete(l);
|
|
end;
|
|
end;
|
|
|
|
function GetStyle(aStyle: TLazGtkStyle): PGTKStyle;
|
|
begin
|
|
if Styles = nil then Exit(nil);
|
|
if aStyle in [lgsUserDefined] then
|
|
RaiseGDBException(''); // user styles are defined by name
|
|
if StandardStyles[aStyle] <> nil then // already created
|
|
Result := StandardStyles[aStyle]^.Style
|
|
else // create it
|
|
Result := GetStyleWithName(LazGtkStyleNames[aStyle]);
|
|
end;
|
|
|
|
procedure tooltip_window_style_set(Widget: PGtkWidget; PreviousStyle: PGtkStyle;
|
|
StyleObject: PStyleObject); cdecl;
|
|
begin
|
|
StyleObject^.Style := gtk_widget_get_style(Widget);
|
|
UpdateSysColorMap(Widget, lgsToolTip);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Function: GetStyleWithName
|
|
Params: none
|
|
Returns: Returns a Corresponding Style
|
|
|
|
Tries to get the Style corresponding to the Widget Name passed, aka 'button',
|
|
'default', checkbox', etc. for use within such routines as DrawFrameControl
|
|
to attempt to supply theme dependent drawing. Styles are stored in a TStrings
|
|
list which is only updated on theme change, to ensure fast efficient retrieval
|
|
of Styles.
|
|
------------------------------------------------------------------------------}
|
|
function GetStyleWithName(const WName: String) : PGTKStyle;
|
|
var
|
|
StyleObject : PStyleObject;
|
|
|
|
function CreateStyleNotebook: PGTKWidget;
|
|
var
|
|
NoteBookWidget: PGtkNotebook;
|
|
//NoteBookPageWidget: PGtkWidget;
|
|
NoteBookPageClientAreaWidget: PGtkWidget;
|
|
NoteBookTabLabel: PGtkWidget;
|
|
NoteBookTabMenuLabel: PGtkWidget;
|
|
begin
|
|
Result:=gtk_notebook_new;
|
|
NoteBookWidget := PGtkNoteBook(Result);
|
|
//NoteBookPageWidget := gtk_hbox_new(false, 0);
|
|
NoteBookPageClientAreaWidget := CreateFixedClientWidget{$IFNDEF GtkFixedWithWindow}(false){$ENDIF};
|
|
gtk_widget_show(NoteBookPageClientAreaWidget);
|
|
//gtk_container_add(GTK_CONTAINER(NoteBookPageWidget),
|
|
// NoteBookPageClientAreaWidget);
|
|
//gtk_widget_show(NoteBookPageWidget);
|
|
NoteBookTabLabel:=gtk_label_new('Lazarus');
|
|
gtk_widget_show(NoteBookTabLabel);
|
|
NoteBookTabMenuLabel:=gtk_label_new('Lazarus');
|
|
gtk_widget_show(NoteBookTabMenuLabel);
|
|
gtk_notebook_append_page_menu(NoteBookWidget,NoteBookPageClientAreaWidget,
|
|
NoteBookTabLabel,NoteBookTabMenuLabel);
|
|
gtk_widget_set_usize(Result,400,400);
|
|
end;
|
|
|
|
procedure ResizeWidget(CurWidget: PGTKWidget; NewWidth, NewHeight: integer);
|
|
{$IFDEF Gtk1}
|
|
begin
|
|
gtk_widget_set_usize(StyleObject^.Widget,NewWidth,NewHeight);
|
|
end;
|
|
{$ELSE}
|
|
var
|
|
allocation: TGtkAllocation;
|
|
begin
|
|
allocation.x:=0;
|
|
allocation.y:=0;
|
|
allocation.width:=NewWidth;
|
|
allocation.height:=NewHeight;
|
|
//gtk_widget_set_usize(StyleObject^.Widget,NewWidth,NewHeight);
|
|
gtk_widget_size_allocate(CurWidget,@allocation);
|
|
StyleObject^.FrameBordersValid:=false;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
var
|
|
Tp : Pointer;
|
|
l : Longint;
|
|
NoName: PGChar;
|
|
lgs: TLazGtkStyle;
|
|
WidgetName: String;
|
|
//VBox: PGtkWidget;
|
|
AddToStyleWindow: Boolean;
|
|
StyleWindowWidget: PGtkWidget;
|
|
Requisition: TGtkRequisition;
|
|
WindowFixedWidget: PGtkWidget;
|
|
VBox: PGtkWidget;
|
|
begin
|
|
Result := nil;
|
|
if Styles=nil then exit;
|
|
{$IFDEF NoStyle}
|
|
exit;
|
|
{$ENDIF}
|
|
|
|
if (WName='') then exit;
|
|
l:=IndexOfStyleWithName(WName);
|
|
//DebugLn(['GetStyleWithName START ',WName,' ',l]);
|
|
|
|
if l >= 0 then
|
|
begin
|
|
StyleObject:=PStyleObject(Styles.Objects[l]);
|
|
Result := StyleObject^.Style;
|
|
end else
|
|
begin
|
|
// create a new style object
|
|
StyleObject := NewStyleObject;
|
|
lgs := lgsUserDefined;
|
|
Tp := nil;
|
|
AddToStyleWindow := True;
|
|
WidgetName := 'LazStyle' + WName;
|
|
// create a style widget
|
|
If CompareText(WName,LazGtkStyleNames[lgsButton])=0 then begin
|
|
StyleObject^.Widget := GTK_BUTTON_NEW;
|
|
lgs:=lgsButton;
|
|
end
|
|
else
|
|
If CompareText(WName,LazGtkStyleNames[lgsLabel])=0 then begin
|
|
StyleObject^.Widget := GTK_LABEL_NEW('StyleLabel');
|
|
lgs:=lgsLabel;
|
|
end
|
|
else
|
|
If CompareText(WName,LazGtkStyleNames[lgsDefault])=0 then begin
|
|
lgs:=lgsDefault;
|
|
AddToStyleWindow:=false;
|
|
NoName:=nil;
|
|
StyleObject^.Widget :=
|
|
// GTK2 does not allow to instantiate the abstract base Widget
|
|
// so we use the "invisible" widget, which should never be defined
|
|
// by the theme
|
|
GTK_WIDGET_NEW(
|
|
{$IFDEF Gtk2}GTK_TYPE_INVISIBLE{$ELSE}GTK_WIDGET_TYPE{$ENDIF},
|
|
NoName,[]);
|
|
end
|
|
else
|
|
If CompareText(WName,LazGtkStyleNames[lgsWindow])=0 then begin
|
|
lgs:=lgsWindow;
|
|
StyleObject^.Widget := GTK_WINDOW_NEW(GTK_WINDOW_TOPLEVEL);
|
|
AddToStyleWindow:=false;
|
|
gtk_widget_hide(StyleObject^.Widget);
|
|
// create the fixed widget
|
|
// (where to put all style widgets, that need a parent for realize)
|
|
VBox:=gtk_vbox_new(false,0);// vbox is needed for menu above and fixed widget below
|
|
gtk_widget_show(VBox);
|
|
gtk_container_add(PGtkContainer(StyleObject^.Widget), VBox);
|
|
gtk_object_set_data(PGtkObject(StyleObject^.Widget),'vbox',VBox);
|
|
WindowFixedWidget:=CreateFixedClientWidget;
|
|
gtk_widget_show(WindowFixedWidget);
|
|
gtk_container_add(PGtkContainer(VBox), WindowFixedWidget);
|
|
gtk_object_set_data(PGtkObject(StyleObject^.Widget),'fixedwidget',WindowFixedWidget);
|
|
gtk_widget_realize(StyleObject^.Widget);
|
|
end
|
|
else
|
|
If CompareText(WName,LazGtkStyleNames[lgsCheckbox])=0 then begin
|
|
lgs:=lgsCheckbox;
|
|
StyleObject^.Widget := GTK_CHECK_BUTTON_NEW;
|
|
end
|
|
else
|
|
If CompareText(WName,LazGtkStyleNames[lgsRadiobutton])=0 then begin
|
|
lgs:=lgsRadiobutton;
|
|
StyleObject^.Widget := GTK_RADIO_BUTTON_NEW(nil);
|
|
end
|
|
else
|
|
If CompareText(WName,LazGtkStyleNames[lgsMenu])=0 then begin
|
|
lgs:=lgsMenu;
|
|
{$IFDEF Gtk1}
|
|
AddToStyleWindow:=false;
|
|
{$ENDIF}
|
|
StyleObject^.Widget := gtk_menu_new;
|
|
end
|
|
else
|
|
If CompareText(WName,LazGtkStyleNames[lgsMenuBar])=0 then begin
|
|
lgs:=lgsMenuBar;
|
|
{$IFDEF Gtk1}
|
|
AddToStyleWindow:=false;
|
|
{$ENDIF}
|
|
StyleObject^.Widget := gtk_menu_bar_new;
|
|
end
|
|
else
|
|
If CompareText(WName,LazGtkStyleNames[lgsMenuitem])=0 then begin
|
|
lgs:=lgsMenuitem;
|
|
{$IFDEF Gtk1}
|
|
AddToStyleWindow:=false;
|
|
StyleObject^.Widget := gtk_menu_item_new;
|
|
{$ELSE}
|
|
// image menu item is needed to correctly return theme options
|
|
StyleObject^.Widget := gtk_image_menu_item_new;
|
|
{$ENDIF}
|
|
end
|
|
else
|
|
If CompareText(WName,LazGtkStyleNames[lgsStatusBar])=0 then begin
|
|
lgs:=lgsStatusBar;
|
|
AddToStyleWindow:=true;
|
|
StyleObject^.Widget := gtk_statusbar_new;
|
|
end
|
|
else
|
|
If CompareText(WName,LazGtkStyleNames[lgsCalendar])=0 then begin
|
|
lgs:=lgsCalendar;
|
|
AddToStyleWindow:=true;
|
|
StyleObject^.Widget := gtk_calendar_new;
|
|
end
|
|
else
|
|
If CompareText(WName,LazGtkStyleNames[lgsList])=0 then begin
|
|
lgs:=lgsList;
|
|
StyleObject^.Widget := gtk_list_new;
|
|
end
|
|
else
|
|
If CompareText(WName,LazGtkStyleNames[lgsVerticalScrollbar])=0 then begin
|
|
lgs:=lgsVerticalScrollbar;
|
|
StyleObject^.Widget := gtk_vscrollbar_new(nil);
|
|
end
|
|
else
|
|
If CompareText(WName,LazGtkStyleNames[lgsHorizontalScrollbar])=0 then begin
|
|
lgs:=lgsHorizontalScrollbar;
|
|
StyleObject^.Widget := gtk_hscrollbar_new(nil);
|
|
end
|
|
else
|
|
If CompareText(WName,LazGtkStyleNames[lgsVerticalPaned])=0 then begin
|
|
lgs:=lgsVerticalPaned;
|
|
StyleObject^.Widget := gtk_vpaned_new;
|
|
end
|
|
else
|
|
If CompareText(WName,LazGtkStyleNames[lgsHorizontalPaned])=0 then begin
|
|
lgs:=lgsHorizontalPaned;
|
|
StyleObject^.Widget := gtk_hpaned_new;
|
|
end
|
|
else
|
|
If CompareText(WName,LazGtkStyleNames[lgsNotebook])=0 then begin
|
|
lgs:=lgsNotebook;
|
|
StyleObject^.Widget := CreateStyleNotebook;
|
|
end
|
|
else
|
|
if CompareText(WName,LazGtkStyleNames[lgsTooltip])=0 then
|
|
begin
|
|
lgs := lgsTooltip;
|
|
Tp := gtk_tooltips_new;
|
|
gtk_tooltips_force_window(Tp);
|
|
StyleObject^.Widget := PGTKTooltips(Tp)^.Tip_Window;
|
|
gtk_widget_ref(StyleObject^.Widget);// MG: why is this needed?
|
|
{$IFNDEF GTK1}
|
|
g_signal_connect(StyleObject^.Widget, 'style-set',
|
|
TGCallback(@tooltip_window_style_set), StyleObject);
|
|
{$ENDIF}
|
|
WidgetName := 'gtk-tooltip-lcl';
|
|
StyleObject^.Obj := Tp;
|
|
Tp := nil;
|
|
{$IFDEF GTK1}
|
|
AddToStyleWindow := False;
|
|
{$ENDIF}
|
|
end
|
|
else
|
|
If CompareText(WName,LazGtkStyleNames[lgsHScale])=0 then begin
|
|
lgs:=lgsHScale;
|
|
TP := PGtkWidget( gtk_adjustment_new (0, 0, 100, 1, 10, 0));
|
|
StyleObject^.Widget := gtk_hscale_new (PGTKADJUSTMENT (TP));
|
|
end
|
|
else
|
|
If CompareText(WName,LazGtkStyleNames[lgsVScale])=0 then begin
|
|
lgs:=lgsVScale;
|
|
TP := PGtkWidget( gtk_adjustment_new (0, 0, 100, 1, 10, 0));
|
|
StyleObject^.Widget := gtk_vscale_new (PGTKADJUSTMENT (TP));
|
|
end
|
|
else
|
|
If CompareText(WName,LazGtkStyleNames[lgsGroupBox])=0 then begin
|
|
lgs:=lgsGroupBox;
|
|
StyleObject^.Widget := gtk_frame_new('GroupBox');
|
|
WindowFixedWidget:=CreateFixedClientWidget{$IFNDEF GtkFixedWithWindow}(false){$ENDIF};
|
|
gtk_widget_show(WindowFixedWidget);
|
|
gtk_container_add(PGtkContainer(StyleObject^.Widget), WindowFixedWidget);
|
|
gtk_object_set_data(PGtkObject(StyleObject^.Widget),'fixedwidget',WindowFixedWidget);
|
|
end
|
|
{$ifdef gtk2}
|
|
else
|
|
If CompareText(WName,LazGtkStyleNames[lgsTreeView])=0 then begin
|
|
lgs:=lgsTreeView;
|
|
StyleObject^.Widget := gtk_tree_view_new;
|
|
gtk_tree_view_append_column(PGtkTreeView(StyleObject^.Widget), gtk_tree_view_column_new);
|
|
end
|
|
{$endif}
|
|
else
|
|
If CompareText(WName,LazGtkStyleNames[lgsToolBar])=0 then begin
|
|
lgs:=lgsToolBar;
|
|
StyleObject^.Widget := gtk_toolbar_new;
|
|
end
|
|
else
|
|
If CompareText(WName,LazGtkStyleNames[lgsToolButton])=0 then begin
|
|
lgs:=lgsToolButton;
|
|
StyleObject^.Widget := gtk_toolbar_append_item(PGtkToolBar(GetStyleWidget(lgsToolBar)), 'B', nil, nil, nil, nil, nil);
|
|
end
|
|
else
|
|
if CompareText(WName,LazGtkStyleNames[lgsScrolledWindow])=0 then begin
|
|
lgs:=lgsScrolledWindow;
|
|
StyleObject^.Widget := gtk_scrolled_window_new(nil, nil);
|
|
end
|
|
else
|
|
If CompareText(WName,LazGtkStyleNames[lgsGTK_Default])=0 then begin
|
|
lgs:=lgsGTK_Default;
|
|
AddToStyleWindow:=false;
|
|
StyleObject^.Widget := nil;
|
|
StyleObject^.Style := gtk_style_new;
|
|
end
|
|
else begin
|
|
// unknown style name -> bug
|
|
FreeStyleObject(StyleObject);
|
|
AddToStyleWindow:=false;
|
|
RaiseGDBException('');
|
|
end;
|
|
|
|
if (lgs<>lgsUserDefined) and (StandardStyles[lgs]<>nil) then begin
|
|
// consistency error
|
|
RaiseGDBException('');
|
|
end;
|
|
|
|
// ensure style of the widget
|
|
If (StyleObject^.Widget <> nil) then begin
|
|
gtk_widget_ref(StyleObject^.Widget);
|
|
|
|
// put style widget on style window, so that it can be realized
|
|
if AddToStyleWindow then
|
|
begin
|
|
gtk_widget_show_all(StyleObject^.Widget);
|
|
if GtkWidgetIsA(StyleObject^.Widget,GTK_TYPE_MENU) then
|
|
begin
|
|
// attach menu to window
|
|
gtk_menu_attach_to_widget(PGtkMenu(StyleObject^.Widget),
|
|
GetStyleWidget(lgsWindow), nil);
|
|
end
|
|
else
|
|
if GtkWidgetIsA(StyleObject^.Widget,GTK_TYPE_MENU_BAR) then
|
|
begin
|
|
StyleWindowWidget:=GetStyleWidget(lgsWindow);
|
|
// add menu above the forms client area (fixed widget)
|
|
VBox:=PGTKWidget(
|
|
gtk_object_get_data(PGtkObject(StyleWindowWidget),'vbox'));
|
|
gtk_box_pack_start(PGTKBox(VBox), StyleObject^.Widget, False, False, 0);
|
|
end
|
|
else
|
|
if GtkWidgetIsA(StyleObject^.Widget,GTK_TYPE_MENU_ITEM) then
|
|
begin
|
|
gtk_menu_bar_append({$IFDEF Gtk1}
|
|
PGtkMenuBar(GetStyleWidget(lgsMenuBar)),
|
|
{$ELSE}
|
|
GetStyleWidget(lgsMenuBar),
|
|
{$ENDIF}
|
|
StyleObject^.Widget);
|
|
end
|
|
else
|
|
{$ifdef gtk2}
|
|
if GtkWidgetIsA(StyleObject^.Widget, GTK_TYPE_TOOL_BUTTON) then
|
|
begin
|
|
//gtk_toolbar_insert();
|
|
gtk_toolbar_append_widget(GTK_TOOLBAR(GetStyleWidget(lgsToolBar)),
|
|
StyleObject^.Widget, nil, nil);
|
|
end
|
|
else
|
|
{$endif}
|
|
if (lgs = lgsToolButton) or
|
|
(lgs = lgsTooltip) then
|
|
begin
|
|
// already on a parent => nothing to do
|
|
end
|
|
else
|
|
begin
|
|
StyleWindowWidget:=GetStyleWidget(lgsWindow);
|
|
// add widget on client area of form
|
|
WindowFixedWidget:=PGTKWidget(
|
|
gtk_object_get_data(PGtkObject(StyleWindowWidget),'fixedwidget'));
|
|
//DebugLn('GetStyleWithName adding on hidden stylewindow ',WName,' ',GetWidgetDebugReport(StyleObject^.Widget));
|
|
if WindowFixedWidget <> nil then
|
|
gtk_fixed_put(PGtkFixed(WindowFixedWidget),StyleObject^.Widget,10,10);
|
|
end;
|
|
end;
|
|
|
|
gtk_widget_set_name(StyleObject^.Widget,PChar(WidgetName));
|
|
gtk_widget_ensure_style(StyleObject^.Widget);
|
|
|
|
// request default sizing
|
|
FillChar(Requisition,SizeOf(Requisition),0);
|
|
gtk_widget_size_request(StyleObject^.Widget, @Requisition);
|
|
|
|
StyleObject^.Style:=gtk_widget_get_style(StyleObject^.Widget);
|
|
// ToDo: find out, why sometimes the style is not initialized.
|
|
// for example: why the following occurs:
|
|
if CompareText(WName,'button')=0 then begin
|
|
if StyleObject^.Style^.light_gc[GTK_STATE_NORMAL]=nil then begin
|
|
//DebugLn('GetStyleWithName ',WName);
|
|
end;
|
|
end;
|
|
if AddToStyleWindow then begin
|
|
if not GtkWidgetIsA(StyleObject^.Widget,GTK_WINDOW_GET_TYPE) then begin
|
|
//DebugLn(['GetStyleWithName realizing ...']);
|
|
gtk_widget_realize(StyleObject^.Widget);
|
|
//DebugLn('AddToStyleWindow realized: ',WName,' ',GetWidgetDebugReport(StyleObject^.Widget));
|
|
end;
|
|
ResizeWidget(StyleObject^.Widget,200,200);
|
|
end;
|
|
end;
|
|
|
|
// increase refcount of style
|
|
if StyleObject^.Style <> nil then
|
|
if CompareText(WName,LazGtkStyleNames[lgsGTK_Default])<>0 then
|
|
StyleObject^.Style := GTK_Style_Ref(StyleObject^.Style);
|
|
|
|
// if successful add to style objects list
|
|
if StyleObject^.Style <> nil then
|
|
begin
|
|
Styles.AddObject(WName, TObject(StyleObject));
|
|
if lgs <> lgsUserDefined then
|
|
StandardStyles[lgs] := StyleObject;
|
|
Result := StyleObject^.Style;
|
|
UpdateSysColorMap(StyleObject^.Widget, lgs);
|
|
|
|
// ToDo: create all gc of the style
|
|
//gtk_widget_set_rc_style(StyleObject^.Widget);
|
|
|
|
if lgs = lgsTooltip then
|
|
gtk_widget_hide_all(StyleObject^.Widget);
|
|
end
|
|
else begin
|
|
// no success, clean up
|
|
FreeStyleObject(StyleObject);
|
|
DebugLn('WARNING: GetStyleWithName ',WName,' failed');
|
|
end;
|
|
|
|
// clean up
|
|
if Tp <> nil then
|
|
gtk_object_destroy(Tp);
|
|
end;
|
|
end;
|
|
|
|
function GetStyleWidget(aStyle: TLazGtkStyle) : PGTKWidget;
|
|
begin
|
|
if aStyle in [lgsUserDefined] then
|
|
RaiseGDBException('');// user styles are defined by name
|
|
if StandardStyles[aStyle]<>nil then
|
|
// already created
|
|
Result:=StandardStyles[aStyle]^.Widget
|
|
else
|
|
// create it
|
|
Result:=GetStyleWidgetWithName(LazGtkStyleNames[aStyle]);
|
|
end;
|
|
|
|
function GetStyleWidgetWithName(const WName : String) : PGTKWidget;
|
|
var
|
|
l : Longint;
|
|
begin
|
|
Result := nil;
|
|
// init style
|
|
GetStyleWithName(WName);
|
|
// return widget
|
|
l:=IndexOfStyleWithName(WName);
|
|
if l>=0 then
|
|
Result := PStyleObject(Styles.Objects[l])^.Widget;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Function: LoadDefaultFont(Desc)
|
|
Params: none
|
|
Returns: Returns the default Font
|
|
|
|
For Text/Font Routines: if the Font is invalid, this can be used instead, or
|
|
if the DT_internal flag is used(aka use system font) this is used. This is
|
|
also the font returned by GetStockObject(SYSTEM_FONT).
|
|
|
|
It attempts to get the font from the default Style, or if none is available,
|
|
a new style(aka try and get GTK builtin values), if that fails tries to get
|
|
a generic fixed font, if THAT fails, it gets whatever font is available.
|
|
If the result is not nil it MUST be GDK_FONT_UNREF'd when done.
|
|
------------------------------------------------------------------------------}
|
|
function LoadDefaultFont: TGtkIntfFont;
|
|
{$IFDEF Gtk1}
|
|
var
|
|
Style : PGTKStyle;
|
|
{$ENDIF}
|
|
begin
|
|
{$IFDEF Gtk2}
|
|
Result:=gtk_widget_create_pango_layout(GetStyleWidget(lgsdefault), nil);
|
|
{$ELSE Gtk1}
|
|
Result := nil;
|
|
Style := GetStyle(lgsDefault);
|
|
if Style = nil then
|
|
Style := GetStyle(lgsGTK_Default);
|
|
if Style <> nil then begin
|
|
Result := Style^.Font;
|
|
if Result = nil then
|
|
{$IFNDEF NoStyle}
|
|
if (Style^.RC_Style <> nil) then begin
|
|
if (Style^.RC_Style^.font_name <> nil) then
|
|
Result := gdk_font_load(Style^.RC_Style^.font_name);
|
|
end;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
If Result = nil then
|
|
Result := gdk_fontset_load('-*-fixed-*-*-*-*-*-120-*-*-*-*-*-*');
|
|
if Result = nil then
|
|
Result := gdk_fontset_load('-*-*-*-*-*-*-*-*-*-*-*-*-*-*');
|
|
{$ENDIF}
|
|
|
|
If Result <> nil then
|
|
ReferenceGtkIntfFont(Result);
|
|
end;
|
|
|
|
{$Ifdef GTK2}
|
|
function LoadDefaultFontDesc: PPangoFontDescription;
|
|
var
|
|
Style : PGTKStyle;
|
|
begin
|
|
Result := nil;
|
|
|
|
{$IFDEF VerboseGtkToDos}{$WARNING ToDo LoadDefaultFontDesc: get a working default pango font description}{$ENDIF}
|
|
Result := pango_font_description_from_string('sans 12');
|
|
|
|
exit;
|
|
|
|
Style := GetStyle(lgsLabel);
|
|
if Style = nil then
|
|
Style := GetStyle(lgsDefault);
|
|
if Style = nil then
|
|
Style := GetStyle(lgsGTK_Default);
|
|
|
|
If (Style <> nil) then begin
|
|
Result := pango_font_description_copy(Style^.font_desc);
|
|
end;
|
|
|
|
If Result = nil then
|
|
Result := pango_font_description_from_string('sans 12');
|
|
|
|
if Result = nil then
|
|
Result := pango_font_description_from_string('12');
|
|
end;
|
|
{$ENDIF}
|
|
|
|
function GetDefaultFontName: string;
|
|
var
|
|
Style: PGtkStyle;
|
|
{$IFDEF GTK2}
|
|
PangoFontDesc: PPangoFontDescription;
|
|
{$ELSE}
|
|
p,t: pchar;
|
|
AFont: PGdkFont;
|
|
{$ENDIF}
|
|
begin
|
|
Result:='';
|
|
Style := GetStyle(lgsDefault);
|
|
if Style = nil then
|
|
Style := GetStyle(lgsGTK_Default);
|
|
|
|
If Style <> nil then begin
|
|
{$IFDEF GTK1}
|
|
{$IFNDEF NoStyle}
|
|
if (Style^.RC_Style <> nil) then
|
|
with style^.RC_Style^ do begin
|
|
if (font_name <> nil) then
|
|
Result := font_name;
|
|
if (Result='') and (fontset_name<>nil) then
|
|
begin
|
|
// fontset_name it's usually a comma separated list of font names
|
|
// try to get the first valid font.
|
|
p := fontset_name;
|
|
while p<>nil do begin
|
|
t := strscan(p, ',');
|
|
if t=nil then
|
|
result := p
|
|
else begin
|
|
result := copy(p, 1, t-p);
|
|
while (t<>nil) and (t^ in [',',' ',#9,#10,#13]) do
|
|
inc(t);
|
|
end;
|
|
AFont := gdk_font_load(pchar(result));
|
|
if AFont<>nil then begin
|
|
gdk_font_unref(AFont);
|
|
{$IFDEF VerboseFonts}
|
|
debugln('DefaultFont found in fontset: ',result);
|
|
{$ENDIF}
|
|
break;
|
|
end;
|
|
p := t;
|
|
end;
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
{$IFDEF GTK2}
|
|
If (Style <> nil) then begin
|
|
PangoFontDesc := Style^.font_desc;
|
|
if PangoFontDesc<>nil then begin
|
|
Result:=pango_font_description_get_family(PangoFontDesc);
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
end;
|
|
{$IFDEF VerboseFonts}
|
|
DebugLn('GetDefaultFontName: DefaultFont=',result);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure RealizeGDKColor(ColorMap: PGdkColormap; Color: PGDKColor);
|
|
var
|
|
AllocResult: gboolean;
|
|
begin
|
|
if ColorMap=nil then ColorMap:=gdk_colormap_get_system;
|
|
if (Color^.pixel = 0)
|
|
and ((Color^.red<>0) or (Color^.blue<>0) or (Color^.green<>0)) then
|
|
gdk_colormap_alloc_colors(ColorMap, Color, 1, false, true, @AllocResult)
|
|
else
|
|
gdk_colormap_query_color(ColorMap, Color^.pixel, Color);
|
|
end;
|
|
|
|
procedure RealizeGtkStyleColor(Style: PGTKStyle; Color: PGDKColor);
|
|
begin
|
|
if (Style<>nil) then
|
|
RealizeGDKColor(Style^.ColorMap,Color)
|
|
else
|
|
RealizeGDKColor(nil,Color);
|
|
end;
|
|
|
|
function GetSysGCValues(Color: TColorRef;
|
|
ThemeWidget: PGtkWidget): TGDKGCValues;
|
|
// ThemeWidget can be nil
|
|
|
|
function GetWidgetWithBackgroundWindow(Widget: PGtkWidget): PGtkWidget;
|
|
// returns the gtk widget which has the background gdk window
|
|
var
|
|
WindowOwnerWidget: PGtkWidget;
|
|
begin
|
|
Result:=Widget;
|
|
if Result=nil then exit;
|
|
if Result^.window=nil then exit;
|
|
gdk_window_get_user_data(Result^.window,PGPointer(@WindowOwnerWidget));
|
|
Result:=WindowOwnerWidget;
|
|
if Result=nil then exit;
|
|
end;
|
|
|
|
var
|
|
Style: PGTKStyle;
|
|
GC: PGDKGC;
|
|
Pixmap: PGDKPixmap;
|
|
SysColor: TColorRef;
|
|
BaseColor: TColorRef;
|
|
Red, Green, Blue: byte;
|
|
begin
|
|
// Set defaults in case something goes wrong
|
|
FillChar(Result, SizeOf(Result), 0);
|
|
Style := nil;
|
|
GC := nil;
|
|
Pixmap := nil;
|
|
|
|
SysColor := ColorToRGB(TColor(Color));
|
|
Result.Fill := GDK_Solid;
|
|
RedGreenBlue(TColor(SysColor), Red, Green, Blue);
|
|
Result.foreground.Red:=gushort(Red) shl 8 + Red;
|
|
Result.foreground.Green:=gushort(Green) shl 8 + Green;
|
|
Result.foreground.Blue:=gushort(Blue) shl 8 + Blue;
|
|
|
|
{$IfDef Disable_GC_SysColors}
|
|
exit;
|
|
{$EndIf}
|
|
BaseColor := Color and $FF;
|
|
case BaseColor of
|
|
{These are WM/X defined, but might be possible to get
|
|
|
|
COLOR_CAPTIONTEXT
|
|
COLOR_INACTIVECAPTIONTEXT}
|
|
|
|
{These Are incompatible or WM defined
|
|
|
|
COLOR_ACTIVECAPTION
|
|
COLOR_INACTIVECAPTION
|
|
COLOR_GRADIENTACTIVECAPTION
|
|
COLOR_GRADIENTINACTIVECAPTION
|
|
COLOR_WINDOWFRAME
|
|
COLOR_ACTIVEBORDER
|
|
COLOR_INACTIVEBORDER}
|
|
|
|
COLOR_BACKGROUND:
|
|
begin
|
|
Style := GetStyle(lgsDefault);
|
|
if Style = nil then
|
|
Style := GetStyle(lgsWindow);
|
|
if Style = nil then
|
|
exit;
|
|
Pixmap := Style^.bg_pixmap[GTK_STATE_NORMAL];
|
|
if Pixmap <> nil then
|
|
begin
|
|
Result.Fill := GDK_Tiled;
|
|
Result.Tile := Pixmap;
|
|
end
|
|
else
|
|
begin
|
|
GC := Style^.bg_gc[GTK_STATE_NORMAL];
|
|
if GC = nil then
|
|
begin
|
|
Result.Fill := GDK_Solid;
|
|
Result.foreground := Style^.bg[GTK_STATE_PRELIGHT];
|
|
end
|
|
else
|
|
GDK_GC_Get_Values(GC, @Result);
|
|
end;
|
|
end;
|
|
|
|
COLOR_INFOBK :
|
|
begin
|
|
Style := GetStyle(lgsTooltip);
|
|
if Style = nil then
|
|
Style := GetStyle(lgsWindow);
|
|
if Style = nil then
|
|
exit;
|
|
|
|
Pixmap := Style^.bg_pixmap[GTK_STATE_NORMAL];
|
|
if Pixmap <> nil then
|
|
begin
|
|
Result.Fill := GDK_Tiled;
|
|
Result.Tile := Pixmap;
|
|
end
|
|
else
|
|
begin
|
|
GC := Style^.bg_gc[GTK_STATE_NORMAL];
|
|
if GC = nil then
|
|
begin
|
|
Result.Fill := GDK_Solid;
|
|
{$IFDEF Gtk1}
|
|
Result.foreground := Style^.bg[GTK_STATE_PRELIGHT];
|
|
{$ELSE}
|
|
Result.foreground := Style^.bg[GTK_STATE_NORMAL];
|
|
{$ENDIF}
|
|
end
|
|
else
|
|
GDK_GC_Get_Values(GC, @Result);
|
|
end;
|
|
end;
|
|
|
|
COLOR_INFOTEXT :
|
|
begin
|
|
Style := GetStyle(lgsTooltip);
|
|
|
|
if Style = nil then
|
|
Style := GetStyle(lgsWindow);
|
|
|
|
if Style = nil then
|
|
exit;
|
|
|
|
GC := Style^.fg_gc[GTK_STATE_NORMAL];
|
|
if GC = nil then
|
|
begin
|
|
Result.Fill := GDK_Solid;
|
|
Result.foreground := Style^.fg[GTK_STATE_NORMAL];
|
|
end
|
|
else
|
|
GDK_GC_Get_Values(GC, @Result);
|
|
end;
|
|
|
|
COLOR_FORM,
|
|
COLOR_MENU,
|
|
COLOR_SCROLLBAR,
|
|
COLOR_BTNFACE :
|
|
begin
|
|
case BaseColor of
|
|
COLOR_FORM: Style := GetStyle(lgsWindow);
|
|
COLOR_BTNFACE: Style := GetStyle(lgsButton);
|
|
COLOR_MENU: Style := GetStyle(lgsMenu);
|
|
COLOR_SCROLLBAR: Style := GetStyle(lgsHorizontalScrollbar);
|
|
end;
|
|
if Style = nil then
|
|
exit;
|
|
Pixmap := Style^.bg_pixmap[GTK_STATE_NORMAL];
|
|
if Pixmap <> nil then
|
|
begin
|
|
Result.Fill := GDK_Tiled;
|
|
Result.Tile := Pixmap;
|
|
end else
|
|
begin
|
|
GC := Style^.bg_gc[GTK_STATE_NORMAL];
|
|
if GC = nil then
|
|
begin
|
|
Result.Fill := GDK_Solid;
|
|
Result.foreground := Style^.bg[GTK_STATE_NORMAL];
|
|
end
|
|
else
|
|
GDK_GC_Get_Values(GC, @Result);
|
|
end;
|
|
end;
|
|
|
|
COLOR_3DDKSHADOW,
|
|
COLOR_BTNSHADOW :
|
|
begin
|
|
Style := GetStyle(lgsButton);
|
|
if Style = nil then
|
|
exit;
|
|
GC := Style^.dark_gc[GTK_STATE_NORMAL];
|
|
if GC = nil then
|
|
begin
|
|
Result.Fill := GDK_Solid;
|
|
Result.foreground := Style^.dark[GTK_STATE_NORMAL];
|
|
end
|
|
else
|
|
GDK_GC_Get_Values(GC, @Result);
|
|
end;
|
|
|
|
COLOR_GRAYTEXT :
|
|
begin
|
|
Style := GetStyle(lgsDefault);
|
|
if Style = nil then
|
|
exit;
|
|
GC := Style^.text_gc[GTK_STATE_INSENSITIVE];
|
|
if GC = nil then
|
|
begin
|
|
Result.Fill := GDK_Solid;
|
|
Result.foreground := Style^.text[GTK_STATE_NORMAL];
|
|
end else
|
|
GDK_GC_Get_Values(GC, @Result);
|
|
end;
|
|
|
|
COLOR_MENUTEXT,
|
|
COLOR_BTNTEXT :
|
|
begin
|
|
case BaseColor of
|
|
COLOR_BTNTEXT : Style := GetStyle(lgsButton);
|
|
COLOR_MENUTEXT : Style := GetStyle(lgsMenuitem);
|
|
end;
|
|
if Style = nil then
|
|
exit;
|
|
GC := Style^.fg_gc[GTK_STATE_NORMAL];
|
|
if GC = nil then
|
|
begin
|
|
Result.Fill := GDK_Solid;
|
|
Result.foreground := Style^.fg[GTK_STATE_NORMAL];
|
|
end
|
|
else
|
|
GDK_GC_Get_Values(GC, @Result);
|
|
end;
|
|
|
|
COLOR_WINDOWTEXT:
|
|
begin
|
|
Style := GetStyle(lgsDefault);
|
|
if Style = nil then
|
|
exit;
|
|
GC := Style^.text_gc[GTK_STATE_NORMAL];
|
|
if GC = nil then
|
|
begin
|
|
Result.Fill := GDK_Solid;
|
|
Result.foreground := Style^.text[GTK_STATE_NORMAL];
|
|
end
|
|
else
|
|
GDK_GC_Get_Values(GC, @Result);
|
|
end;
|
|
|
|
COLOR_3DLIGHT,
|
|
COLOR_BTNHIGHLIGHT :
|
|
begin
|
|
Style := GetStyle(lgsButton);
|
|
if Style = nil then
|
|
exit;
|
|
GC := Style^.light_gc[GTK_STATE_NORMAL];
|
|
if GC = nil then
|
|
begin
|
|
Result.Fill := GDK_Solid;
|
|
Result.foreground := Style^.light[GTK_STATE_NORMAL];
|
|
end
|
|
else
|
|
GDK_GC_Get_Values(GC, @Result);
|
|
end;
|
|
|
|
COLOR_WINDOW :
|
|
begin
|
|
Style := GetStyle(lgsList);
|
|
if Style = nil then
|
|
exit;
|
|
GC := Style^.base_gc[GTK_STATE_NORMAL];
|
|
if (GC = nil) then
|
|
begin
|
|
Result.Fill := GDK_Solid;
|
|
if Style^.base[GTK_STATE_NORMAL].Pixel<>0 then
|
|
begin
|
|
Result.foreground := Style^.base[GTK_STATE_NORMAL];
|
|
Result.background := Style^.base[GTK_STATE_NORMAL];
|
|
end;
|
|
end
|
|
else
|
|
GDK_GC_Get_Values(GC, @Result);
|
|
end;
|
|
|
|
COLOR_HIGHLIGHT :
|
|
begin
|
|
Style := GetStyle(lgsDefault);
|
|
if Style = nil then
|
|
exit;
|
|
GC := Style^.bg_gc[GTK_STATE_SELECTED];
|
|
if GC = nil then
|
|
begin
|
|
Result.Fill := GDK_Solid;
|
|
Result.foreground := Style^.bg[GTK_STATE_SELECTED];
|
|
end
|
|
else
|
|
GDK_GC_Get_Values(GC, @Result);
|
|
end;
|
|
|
|
COLOR_HIGHLIGHTTEXT :
|
|
begin
|
|
Style := GetStyle(lgsDefault);
|
|
if Style = nil then
|
|
exit;
|
|
{$IFDEF Gtk1}
|
|
GC := Style^.bg_gc[GTK_STATE_PRELIGHT];
|
|
{$ELSE}
|
|
GC := Style^.text_gc[GTK_STATE_SELECTED];
|
|
{$ENDIF}
|
|
if GC = nil then
|
|
begin
|
|
Result.Fill := GDK_Solid;
|
|
Result.foreground := Style^.bg[GTK_STATE_PRELIGHT];
|
|
end
|
|
else
|
|
GDK_GC_Get_Values(GC, @Result);
|
|
end;
|
|
|
|
{?????????????
|
|
COLOR_HOTLIGHT :
|
|
begin
|
|
end;
|
|
?????????????}
|
|
|
|
{?????????????????
|
|
COLOR_APPWORKSPACE :
|
|
begin
|
|
end;
|
|
?????????????????}
|
|
end;
|
|
|
|
RealizeGtkStyleColor(Style, @Result.foreground);
|
|
end;
|
|
|
|
function StyleForegroundColor(Color: TColorRef;
|
|
DefaultColor: PGDKColor): PGDKColor;
|
|
var
|
|
style : PGTKStyle;
|
|
begin
|
|
style := nil;
|
|
Result := DefaultColor;
|
|
|
|
Case TColor(Color) of
|
|
clINFOTEXT :
|
|
begin
|
|
Style := GetStyle(lgsTooltip);
|
|
|
|
If Style = nil then
|
|
exit;
|
|
|
|
Result := @Style^.fg[GTK_STATE_NORMAL];
|
|
end;
|
|
|
|
cl3DDKSHADOW,
|
|
clBTNSHADOW :
|
|
begin
|
|
Style := GetStyle(lgsButton);
|
|
If Style = nil then
|
|
exit;
|
|
Result := @Style^.dark[GTK_STATE_NORMAL];
|
|
end;
|
|
|
|
clGRAYTEXT :
|
|
begin
|
|
Style := GetStyle(lgsDefault);
|
|
If Style = nil then
|
|
exit;
|
|
Result := @Style^.text[GTK_STATE_INSENSITIVE];
|
|
end;
|
|
|
|
clMENUTEXT,
|
|
clBTNTEXT :
|
|
begin
|
|
Case TColor(Color) of
|
|
clBTNTEXT : Style := GetStyle(lgsButton);
|
|
clMENUTEXT : Style := GetStyle(lgsMenuitem);
|
|
end;
|
|
If Style = nil then
|
|
exit;
|
|
Result := @Style^.fg[GTK_STATE_NORMAL];
|
|
end;
|
|
|
|
clWINDOWTEXT:
|
|
begin
|
|
Style := GetStyle(lgsDefault);
|
|
If Style = nil then
|
|
exit;
|
|
Result := @Style^.text[GTK_STATE_NORMAL];
|
|
end;
|
|
|
|
cl3DLIGHT,
|
|
clBTNHIGHLIGHT :
|
|
begin
|
|
Style := GetStyle(lgsButton);
|
|
If Style = nil then
|
|
exit;
|
|
Result := @Style^.light[GTK_STATE_NORMAL];
|
|
end;
|
|
|
|
clHIGHLIGHTTEXT :
|
|
begin
|
|
DebugLn(['StyleForegroundColor clHIGHLIGHTTEXT']);
|
|
Style := GetStyle(lgsDefault);
|
|
If Style = nil then
|
|
exit;
|
|
Result := @Style^.text[GTK_STATE_PRELIGHT];
|
|
DebugLn(['StyleForegroundColor clHIGHLIGHTTEXT 2 ',Result<>nil]);
|
|
end;
|
|
end;
|
|
|
|
If Result = nil then
|
|
Result := DefaultColor;
|
|
|
|
if (Result <> nil) and (Result <> DefaultColor) then
|
|
RealizeGtkStyleColor(Style,Result);
|
|
end;
|
|
|
|
function GetStyleGroupboxFrameBorders: TRect;
|
|
const s = 200;
|
|
var
|
|
StyleObject: PStyleObject;
|
|
allocation: TGtkAllocation;
|
|
FrameWidget: PGtkFrame;
|
|
f: TRect;
|
|
begin
|
|
GetStyleWidget(lgsGroupBox);
|
|
StyleObject:=StandardStyles[lgsGroupBox];
|
|
if not StyleObject^.FrameBordersValid then begin
|
|
allocation.x:=0;
|
|
allocation.y:=0;
|
|
allocation.width:=s;
|
|
allocation.height:=s;
|
|
gtk_widget_size_allocate(StyleObject^.Widget,@allocation);
|
|
FrameWidget:=pGtkFrame(StyleObject^.Widget);
|
|
{$IFDEF Gtk1}
|
|
allocation:=FrameWidget^.bin.child^.allocation;
|
|
{$ELSE}
|
|
GTK_FRAME_GET_CLASS(FrameWidget)^.compute_child_allocation(
|
|
FrameWidget,@allocation);
|
|
{$ENDIF}
|
|
//DebugLn(['GetStyleGroupboxFrame BBB2 ',dbgs(allocation)]);
|
|
f.Left:=Min(s,Max(0,allocation.x));
|
|
f.Top:=Min(s,Max(0,allocation.y));
|
|
f.Right:=Max(0,Min(s-f.Left,s-allocation.x-allocation.width));
|
|
f.Bottom:=Max(0,Min(s-f.Top,s-allocation.x-allocation.width));
|
|
StyleObject^.FrameBorders:=f;
|
|
//DebugLn(['GetStyleGroupboxFrame FrameBorders=',dbgs(StyleObject^.FrameBorders)]);
|
|
StyleObject^.FrameBordersValid:=true;
|
|
end;
|
|
Result:=StyleObject^.FrameBorders;
|
|
end;
|
|
|
|
function GetStyleNotebookFrameBorders: TRect;
|
|
const s = 400;
|
|
var
|
|
StyleObject: PStyleObject;
|
|
allocation: TGtkAllocation;
|
|
f: TRect;
|
|
PageWidget: PGtkWidget;
|
|
begin
|
|
GetStyleWidget(lgsNotebook);
|
|
StyleObject:=StandardStyles[lgsNotebook];
|
|
if not StyleObject^.FrameBordersValid then begin
|
|
allocation.x:=0;
|
|
allocation.y:=0;
|
|
allocation.width:=s;
|
|
allocation.height:=s;
|
|
gtk_widget_size_allocate(StyleObject^.Widget,@allocation);
|
|
PageWidget:=gtk_notebook_get_nth_page(PGtkNoteBook(StyleObject^.Widget),0);
|
|
//DebugLn(['GetStyleNotebookFrameBorders BBB2 ',dbgs(allocation)]);
|
|
allocation:=PageWidget^.allocation;
|
|
f.Left:=Min(s,Max(0,allocation.x));
|
|
f.Top:=Min(s,Max(0,allocation.y));
|
|
f.Right:=Max(0,Min(s-f.Left,s-allocation.x-allocation.width));
|
|
f.Bottom:=Max(0,Min(s-f.Top,s-allocation.x-allocation.width));
|
|
StyleObject^.FrameBorders:=f;
|
|
//DebugLn(['GetStyleNotebookFrameBorders FrameBorders=',dbgs(StyleObject^.FrameBorders)]);
|
|
StyleObject^.FrameBordersValid:=true;
|
|
end;
|
|
Result:=StyleObject^.FrameBorders;
|
|
end;
|
|
|
|
{$IFDEF Gtk2}
|
|
function GetStyleFormFrameBorders(WithMenu: boolean): TRect;
|
|
const s = 400;
|
|
var
|
|
StyleObject: PStyleObject;
|
|
allocation: TGtkAllocation;
|
|
f: TRect;
|
|
InnerWidget: PGtkWidget;
|
|
Outer: TGdkRectangle;
|
|
Inner: TGdkRectangle;
|
|
begin
|
|
GetStyleWidget(lgsMenu);
|
|
StyleObject:=StandardStyles[lgsWindow];
|
|
if not StyleObject^.FrameBordersValid then begin
|
|
allocation.x:=0;
|
|
allocation.y:=0;
|
|
allocation.width:=s;
|
|
allocation.height:=s;
|
|
gtk_widget_size_allocate(StyleObject^.Widget,@allocation);
|
|
InnerWidget:=PGTKWidget(
|
|
gtk_object_get_data(PGtkObject(StyleObject^.Widget),'fixedwidget'));
|
|
allocation:=InnerWidget^.allocation;
|
|
//DebugLn(['GetStyleFormFrameBorders BBB2 ',dbgs(allocation),' WithMenu=',WithMenu,' ClientWidget=',GetWidgetDebugReport(InnerWidget)]);
|
|
f.Left:=Min(s,Max(0,allocation.x));
|
|
f.Top:=Min(s,Max(0,allocation.y));
|
|
f.Right:=Max(0,Min(s-f.Left,s-allocation.x-allocation.width));
|
|
f.Bottom:=Max(0,Min(s-f.Top,s-allocation.x-allocation.width));
|
|
StyleObject^.FrameBorders:=f;
|
|
//DebugLn(['GetStyleFormFrameBorders FrameBorders=',dbgs(StyleObject^.FrameBorders)]);
|
|
StyleObject^.FrameBordersValid:=true;
|
|
end;
|
|
|
|
if WithMenu then begin
|
|
InnerWidget:=PGTKWidget(
|
|
gtk_object_get_data(PGtkObject(StyleObject^.Widget),'vbox'));
|
|
end else begin
|
|
InnerWidget:=PGTKWidget(
|
|
gtk_object_get_data(PGtkObject(StyleObject^.Widget),'fixedwidget'));
|
|
end;
|
|
Outer:=StyleObject^.Widget^.allocation;
|
|
Inner:=InnerWidget^.allocation;
|
|
Result.Left:=Min(Outer.width,Max(0,Inner.x));
|
|
Result.Top:=Min(Outer.height,Max(0,Inner.y));
|
|
Result.Right:=Max(0,Min(Outer.width-f.Left,Outer.width-Inner.x-Inner.width));
|
|
Result.Bottom:=Max(0,Min(Outer.height-f.Top,Outer.height-Inner.x-Inner.width));
|
|
//DebugLn(['GetStyleFormFrameBorders BBB3 Inner=',dbgs(Inner),' Outer=',dbgs(Outer),' WithMenu=',WithMenu,' InnerWidget=',GetWidgetDebugReport(InnerWidget),' Result=',dbgs(Result)]);
|
|
end;
|
|
{$ENDIF}
|
|
|
|
procedure StyleFillRectangle(drawable : PGDKDrawable; GC : PGDKGC;
|
|
Color : TColorRef; x, y, width, height : gint);
|
|
var
|
|
style: PGTKStyle;
|
|
widget: PGTKWidget;
|
|
state: TGTKStateType;
|
|
shadow: TGtkShadowType;
|
|
detail: pgchar;
|
|
begin
|
|
style := nil;
|
|
shadow := GTK_SHADOW_NONE;
|
|
state := GTK_STATE_NORMAL;
|
|
|
|
case TColor(Color) of
|
|
{ clMenu:
|
|
begin
|
|
Style := GetStyle('menuitem');
|
|
widget := GetStyleWidget('menuitem');
|
|
detail := 'menuitem';
|
|
end;
|
|
|
|
clBtnFace :
|
|
begin
|
|
Style := GetStyle('button');
|
|
widget := GetStyleWidget('button');
|
|
detail := 'button';
|
|
end;
|
|
|
|
clWindow :
|
|
begin
|
|
Style := GetStyle('default');
|
|
widget := GetStyleWidget('default');
|
|
detail := 'list';
|
|
end; }
|
|
|
|
clBackground:
|
|
begin
|
|
Style := GetStyle(lgsWindow);
|
|
widget := GetStyleWidget(lgsWindow);
|
|
detail := 'window';
|
|
end;
|
|
|
|
clInfoBk :
|
|
begin
|
|
Style := GetStyle(lgsToolTip);
|
|
Widget := GetStyleWidget(lgsToolTip);
|
|
shadow := GTK_SHADOW_OUT;
|
|
detail := 'tooltip';
|
|
end;
|
|
|
|
clForm :
|
|
begin
|
|
Style := GetStyle(lgsWindow);
|
|
widget := GetStyleWidget(lgsWindow);
|
|
detail := 'window';
|
|
end;
|
|
end;
|
|
|
|
if Assigned(Style) then
|
|
gtk_paint_flat_box(style, drawable, state, shadow, nil, widget,
|
|
detail, x, y, width, height)
|
|
else
|
|
gdk_draw_rectangle(drawable, GC, 1, x, y, width, height);
|
|
end;
|
|
|
|
procedure UpdateWidgetStyleOfControl(AWinControl: TWinControl);
|
|
var
|
|
RCStyle : PGtkRCStyle;
|
|
Widget, FixWidget : PGTKWidget;
|
|
MainWidget: PGtkWidget;
|
|
FreeFontName: boolean;
|
|
FreeFontSetName: boolean;
|
|
|
|
procedure CreateRCStyle;
|
|
begin
|
|
if RCStyle=nil then
|
|
RCStyle:=gtk_rc_style_new;
|
|
end;
|
|
|
|
procedure SetRCFont(FontGdiObject: PGdiObject);
|
|
{$IFDEF GTK1}
|
|
var
|
|
FontDesc: TGtkFontCacheDescriptor;
|
|
{$ENDIF}
|
|
begin
|
|
{$IFDEF GTK1}
|
|
CreateRCStyle;
|
|
FontDesc:=FontCache.FindADescriptor(FontGdiObject^.GDIFontObject);
|
|
if (FontDesc<>nil) and (FontDesc.xlfd<>'') then begin
|
|
RCStyle:=gtk_rc_style_new;
|
|
g_free(RCStyle^.font_name);
|
|
RCStyle^.font_name:=g_strdup(PChar(FontDesc.xlfd));
|
|
g_free(RCStyle^.fontset_name);
|
|
RCStyle^.fontset_name:=g_strdup(PChar(FontDesc.xlfd));
|
|
FreeFontName:=true;
|
|
|
|
//DebugLn('UpdateWidgetStyleOfControl.SetRCFont ',DbgSName(AWinControl),' Widget=',GetWidgetDebugReport(Widget),' Style=',GetWidgetStyleReport(Widget));
|
|
end;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
begin
|
|
{$IFDEF NoStyle}
|
|
exit;
|
|
{$ENDIF}
|
|
|
|
if not AWinControl.HandleAllocated then exit;
|
|
|
|
MainWidget:=PGtkWidget(AWinControl.Handle);
|
|
FixWidget:=GetFixedWidget(MainWidget);
|
|
if (FixWidget <> nil) and (FixWidget <> MainWidget) then
|
|
Widget := FixWidget
|
|
else
|
|
Widget := MainWidget;
|
|
|
|
RCStyle:=nil;
|
|
FreeFontName:=false;
|
|
FreeFontSetName:=false;
|
|
try
|
|
// set default background
|
|
if (AWinControl.Color=clNone) then
|
|
begin
|
|
// clNone => remove default background
|
|
if (FixWidget<>nil) and (FixWidget^.Window<>nil) then
|
|
begin
|
|
gdk_window_set_back_pixmap(FixWidget^.Window, nil, GdkFalse);
|
|
end;
|
|
end
|
|
else
|
|
if not IsColorDefault(AWinControl) and ((AWinControl.Color and SYS_COLOR_BASE)=0) then
|
|
begin
|
|
// set background to user defined color
|
|
|
|
// don't set background for custom controls, which paint themselves
|
|
// (this prevents flickering)
|
|
if (csOpaque in AWinControl.ControlStyle)
|
|
and GtkWidgetIsA(MainWidget,GTKAPIWidget_Type) then exit;
|
|
|
|
{for i:=0 to 4 do begin
|
|
RCStyle^.bg[i]:=NewColor;
|
|
|
|
// Indicate which colors the GtkRcStyle will affect;
|
|
// unflagged colors will follow the theme
|
|
RCStyle^.color_flags[i]:=
|
|
RCStyle^.color_flags[i] or GTK_RC_BG;
|
|
end;}
|
|
|
|
//DebugLn('UpdateWidgetStyleOfControl ',DbgSName(AWinControl),' Color=',DbgS(AWinControl.Color));
|
|
end;
|
|
|
|
{if (AWinControl is TCustomForm) then begin
|
|
gdk_window_set_back_pixmap(FixWidget^.Window,nil,GdkFalse);
|
|
|
|
NewColor:=TColorToTGDKColor(clRed);
|
|
|
|
CreateRCStyle;
|
|
for i:=0 to 4 do begin
|
|
debugln('UpdateWidgetStyleOfControl i=',dbgs(i),' ',RCStyle^.bg_pixmap_name[i],' ',RCStyle^.Name);
|
|
RCStyle^.bg[i]:=NewColor;
|
|
|
|
// Indicate which colors the GtkRcStyle will affect;
|
|
// unflagged colors will follow the theme
|
|
RCStyle^.color_flags[i]:=
|
|
RCStyle^.color_flags[i] or GTK_RC_BG;
|
|
end;
|
|
end;}
|
|
|
|
// set font color
|
|
|
|
// set font (currently only TCustomLabel)
|
|
if (GtkWidgetIsA(Widget,gtk_label_get_type)
|
|
or GtkWidgetIsA(Widget,gtk_editable_get_type)
|
|
or GtkWidgetIsA(Widget,gtk_check_button_get_type))
|
|
and (not AWinControl.Font.IsDefault)
|
|
then begin
|
|
// allocate font (just read it)
|
|
if AWinControl.Font.Reference.Handle=0 then ;
|
|
end;
|
|
|
|
finally
|
|
if RCStyle<>nil then begin
|
|
//DebugLn('UpdateWidgetStyleOfControl Apply Modifications ',AWinControl.Name,' ',GetWidgetClassName(Widget));
|
|
gtk_widget_modify_style(Widget,RCStyle);
|
|
|
|
if FreeFontName then begin
|
|
{$ifdef gtk1}
|
|
g_free(RCStyle^.font_name);
|
|
RCStyle^.font_name:=nil;
|
|
{$else}
|
|
pango_font_description_free(RCStyle^.font_desc);
|
|
RCStyle^.font_desc:=nil;
|
|
{$endif}
|
|
end;
|
|
if FreeFontSetName then begin
|
|
{$ifdef gtk1}
|
|
g_free(RCStyle^.fontset_name);
|
|
RCStyle^.fontset_name:=nil;
|
|
{$endif}
|
|
end;
|
|
//DebugLn('UpdateWidgetStyleOfControl END ',DbgSName(AWinControl),' Widget=',GetWidgetDebugReport(Widget),' Style=',GetWidgetStyleReport(Widget));
|
|
gtk_rc_style_unref(RCStyle);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
Creates a new PChar. Deletes escaping ampersands, replaces the first single
|
|
ampersand with an underscore and deletes all other single ampersands.
|
|
-------------------------------------------------------------------------------}
|
|
function Ampersands2Underscore(Src: PChar) : PChar;
|
|
var
|
|
s: String;
|
|
begin
|
|
s := StrPas(Src);
|
|
s := Ampersands2Underscore(s);
|
|
Result := StrAlloc(Length(s)+1); // +1 for #0 char at end
|
|
strcopy(Result, PChar(s));
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
Deletes escaping ampersands, replaces the first single
|
|
ampersand with an underscore and deletes all other single ampersands.
|
|
-------------------------------------------------------------------------------}
|
|
function Ampersands2Underscore(const ASource: String): String;
|
|
var
|
|
n: Integer;
|
|
FirstFound: Boolean;
|
|
begin
|
|
//TODO: escape underscores
|
|
FirstFound := False;
|
|
Result := ASource;
|
|
n := 1;
|
|
while n <= Length(Result) do
|
|
begin
|
|
if Result[n] = '&' then
|
|
begin
|
|
if FirstFound
|
|
or ( (n < Length(Result)) and (Result[n+1] = '&') ) // got &&
|
|
then begin
|
|
Delete(Result, n, 1);
|
|
if not FirstFound then
|
|
Inc(n); // Skip the second & of &&
|
|
end
|
|
else begin
|
|
FirstFound := True;
|
|
Result[n] := '_';
|
|
end;
|
|
end;
|
|
Inc(n);
|
|
end;
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
function RemoveAmpersands(Src: PChar; LineLength : Longint) : PChar;
|
|
|
|
Creates a new PChar removing all escaping ampersands.
|
|
-------------------------------------------------------------------------------}
|
|
function RemoveAmpersands(Src: PChar; LineLength : Longint) : PChar;
|
|
var
|
|
i, j: Longint;
|
|
ShortenChars, NewLength, SrcLength: integer;
|
|
begin
|
|
// count ampersands and find first ampersand
|
|
ShortenChars:= 0; // chars to delete
|
|
SrcLength:= LineLength;
|
|
|
|
{ Look for amperands. If found, check if it is an escaped ampersand.
|
|
If it is, don't count it in. }
|
|
i:=0;
|
|
while i<SrcLength do begin
|
|
if Src[i] = '&' then begin
|
|
if (i < SrcLength - 1) and (Src[i+1] = '&') then begin
|
|
// escaping ampersand found
|
|
inc(ShortenChars);
|
|
inc(i,2);
|
|
Continue;
|
|
end
|
|
else
|
|
inc(ShortenChars);
|
|
end;
|
|
inc(i);
|
|
end;
|
|
// create new PChar
|
|
NewLength:= SrcLength - ShortenChars;
|
|
|
|
Result:=StrAlloc(NewLength+1); // +1 for #0 char at end
|
|
|
|
// copy string without ampersands
|
|
i:=0;
|
|
j:=0;
|
|
while (j < NewLength) do begin
|
|
if Src[i] <> '&' then begin
|
|
// copy normal char
|
|
Result[j]:= Src[i];
|
|
end else begin
|
|
// ampersand
|
|
if (i < (SrcLength - 1)) and (Src[i+1] = '&') then begin
|
|
// escaping ampersand found
|
|
inc(i);
|
|
Result[j]:='&';
|
|
end else
|
|
// delete single ampersand
|
|
dec(j);
|
|
end;
|
|
Inc(i);
|
|
Inc(j);
|
|
end;
|
|
Result[NewLength]:=#0;
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
function RemoveAmpersands(const ASource: String): String;
|
|
|
|
Removing all escaping ampersands.
|
|
-------------------------------------------------------------------------------}
|
|
function RemoveAmpersands(const ASource: String): String;
|
|
var
|
|
n: Integer;
|
|
begin
|
|
Result := ASource;
|
|
n := 1;
|
|
while n <= Length(Result) do
|
|
begin
|
|
if Result[n] = '&'
|
|
then begin
|
|
if (n < Length(Result))
|
|
and (Result[n + 1] = '&')
|
|
then begin
|
|
// we got a &&, remove the first
|
|
Delete(Result, n, 1);
|
|
Inc(n);
|
|
Continue;
|
|
end;
|
|
// simply remove it
|
|
Delete(Result, n, 1);
|
|
Continue;
|
|
end;
|
|
Inc(n);
|
|
end;
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
procedure LabelFromAmpersands(var AText, APattern: String; var AAccelChar: Char)
|
|
|
|
Removes all escaping ampersands &&, creates an underscore pattern and returns
|
|
the first ampersand char as accelerator char
|
|
-------------------------------------------------------------------------------}
|
|
procedure LabelFromAmpersands(var AText, APattern: String; var AAccelChar: Char);
|
|
var
|
|
n: Integer;
|
|
FirstFound: Boolean;
|
|
begin
|
|
FirstFound := False;
|
|
APattern := StringOfChar(' ', Length(AText));
|
|
AAccelChar := #0;
|
|
n := 1;
|
|
while n <= Length(AText) do
|
|
begin
|
|
case AText[n] of
|
|
'&': begin
|
|
if (n < Length(AText))
|
|
and (AText[n + 1] = '&')
|
|
then begin
|
|
// we got a &&, remove the first
|
|
Delete(AText, n, 1);
|
|
Delete(APattern, n, 1);
|
|
Inc(n);
|
|
end else begin
|
|
Delete(AText, n, 1);
|
|
Delete(APattern, n, 1);
|
|
if FirstFound
|
|
then Continue; // simply remove it
|
|
|
|
// if we are here it's our first
|
|
FirstFound := True;
|
|
AAccelChar := System.lowerCase(AText[n]);
|
|
// is there a next char we can underline ?
|
|
if n <= Length(APattern)
|
|
then APattern[n] := '_';
|
|
end;
|
|
end;
|
|
'_': begin
|
|
AText[n] := ' ';
|
|
APattern[n] := '_';
|
|
end;
|
|
end;
|
|
Inc(n);
|
|
end;
|
|
end;
|
|
|
|
|
|
{-------------------------------------------------------------------------------
|
|
function GetTextExtentIgnoringAmpersands(TheFont: PGDKFont;
|
|
Str : PChar; StrLength: integer;
|
|
MaxWidth: Longint; lbearing, rbearing, width, ascent, descent : Pgint);
|
|
|
|
Gets text extent of a string, ignoring escaped Ampersands.
|
|
That means, ampersands are not counted.
|
|
Negative MaxWidth means no limit.
|
|
-------------------------------------------------------------------------------}
|
|
procedure GetTextExtentIgnoringAmpersands(TheFont: TGtkIntfFont;
|
|
Str : PChar; StrLength: integer;
|
|
lbearing, rbearing, width, ascent, descent : Pgint);
|
|
var
|
|
NewStr : PChar;
|
|
i: integer;
|
|
begin
|
|
NewStr:=Str;
|
|
// first check if Str contains an ampersand:
|
|
if (Str<>nil) then begin
|
|
i:=0;
|
|
while (Str[i]<>'&') and (i<StrLength) do inc(i);
|
|
if i<StrLength then begin
|
|
NewStr := RemoveAmpersands(Str, StrLength);
|
|
StrLength:=StrLen(NewStr);
|
|
end;
|
|
end;
|
|
gdk_text_extents(TheFont, NewStr, StrLength,
|
|
lbearing, rBearing, width, ascent, descent);
|
|
if NewStr<>Str then
|
|
StrDispose(NewStr);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function FontIsDoubleByteCharsFont(TheFont: TGtkIntfFont): boolean;
|
|
|
|
This is only a heuristic
|
|
------------------------------------------------------------------------------}
|
|
function FontIsDoubleByteCharsFont(TheFont: TGtkIntfFont): boolean;
|
|
var
|
|
SingleCharLen, DoubleCharLen: integer;
|
|
begin
|
|
{$IFDEF Gtk1}
|
|
SingleCharLen:=gdk_text_width(TheFont, 'A', 1);
|
|
DoubleCharLen:=gdk_text_width(TheFont, #0'A', 2);
|
|
{$ELSE}
|
|
pango_layout_set_single_paragraph_mode(TheFont, TRUE);
|
|
pango_layout_set_width(TheFont, -1);
|
|
pango_layout_set_text(TheFont, 'A', 1);
|
|
pango_layout_get_pixel_size(TheFont, @SingleCharLen, nil);
|
|
pango_layout_set_text(TheFont, #0'A', 2);
|
|
pango_layout_get_pixel_size(TheFont, @DoubleCharLen, nil);
|
|
{$ENDIF}
|
|
Result:=(SingleCharLen=0) and (DoubleCharLen>0);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function FontIsMonoSpaceFont(TheFont: TGtkIntfFont): boolean;
|
|
|
|
This is only a heuristic
|
|
------------------------------------------------------------------------------}
|
|
function FontIsMonoSpaceFont(TheFont: TGtkIntfFont): boolean;
|
|
var
|
|
{$IFDEF Gtk1}
|
|
SingleCharLen: LongInt;
|
|
{$ENDIF}
|
|
MWidth: LongInt;
|
|
IWidth: LongInt;
|
|
begin
|
|
{$IFDEF Gtk1}
|
|
SingleCharLen:=gdk_text_width(TheFont, 'A', 1);
|
|
if SingleCharLen=0 then begin
|
|
// assume a double byte character font
|
|
MWidth:=gdk_text_width(TheFont, '#0m', 2);
|
|
IWidth:=gdk_text_width(TheFont, '#0i', 2);
|
|
end else begin
|
|
// assume a single byte character font
|
|
MWidth:=gdk_text_width(TheFont, 'm', 1);
|
|
IWidth:=gdk_text_width(TheFont, 'i', 1);
|
|
end;
|
|
{$ELSE}
|
|
pango_layout_set_single_paragraph_mode(TheFont, TRUE);
|
|
pango_layout_set_width(TheFont, -1);
|
|
pango_layout_set_text(TheFont, 'm', 1);
|
|
pango_layout_get_pixel_size(TheFont, @MWidth, nil);
|
|
pango_layout_set_text(TheFont, 'i', 1);
|
|
pango_layout_get_pixel_size(TheFont, @IWidth, nil);
|
|
{$ENDIF}
|
|
Result:=MWidth=IWidth;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: GDKPixel2GDIRGB
|
|
Params:
|
|
Pixel - a GDK Pixel, refers to Index in Colormap/Visual
|
|
Visual - a GDK Visual, if nil, the System Default is used
|
|
Colormap - a GDK Colormap, if nil, the System Default is used
|
|
Returns: TGDIRGB
|
|
|
|
A convenience function for use with GDK Image's. It takes a pixel value
|
|
retrieved from gdk_image_get_pixel, and uses the passed Visual and Colormap
|
|
to try and look up actual RGB values.
|
|
------------------------------------------------------------------------------}
|
|
function GDKPixel2GDIRGB(Pixel: Longint; Visual: PGDKVisual;
|
|
Colormap: PGDKColormap) : TGDIRGB;
|
|
var
|
|
Color: TGDKColor;
|
|
begin
|
|
FillChar(Result, SizeOf(TGDIRGB),0);
|
|
|
|
If (Visual = nil) or (Colormap = nil) then begin
|
|
Visual := GDK_Visual_Get_System;
|
|
Colormap := GDK_Colormap_Get_System;
|
|
end;
|
|
|
|
gdk_colormap_query_color(colormap, pixel, @color);
|
|
|
|
Result.Red := Color.Red shr 8;
|
|
Result.Green := Color.Green shr 8;
|
|
Result.Blue := Color.Blue shr 8;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function GetWindowDecorations(AForm : TCustomForm) : Longint;
|
|
|
|
------------------------------------------------------------------------------}
|
|
function GetWindowDecorations(AForm : TCustomForm) : Longint;
|
|
var
|
|
ABorderStyle: TFormBorderStyle;
|
|
begin
|
|
Result := 0;
|
|
|
|
if not (csDesigning in AForm.ComponentState) then
|
|
ABorderStyle:=AForm.BorderStyle
|
|
else
|
|
ABorderStyle:=bsSizeable;
|
|
|
|
{$IFDEF Gtk2}
|
|
|
|
case ABorderStyle of
|
|
bsNone: Result := 0;
|
|
|
|
bsSingle: Result := GDK_DECOR_TITLE or
|
|
GDK_DECOR_MENU or GDK_DECOR_MINIMIZE or
|
|
GDK_DECOR_MAXIMIZE;
|
|
|
|
bsSizeable: Result := GDK_DECOR_BORDER or GDK_DECOR_TITLE or
|
|
GDK_DECOR_MENU or GDK_DECOR_MINIMIZE or GDK_DECOR_MAXIMIZE
|
|
or GDK_DECOR_RESIZEH;
|
|
|
|
bsDialog: Result := GDK_DECOR_BORDER or GDK_DECOR_TITLE or
|
|
GDK_DECOR_MENU or GDK_DECOR_MINIMIZE;
|
|
|
|
bsToolWindow: Result := GDK_DECOR_TITLE or GDK_DECOR_MENU;
|
|
|
|
bsSizeToolWin: Result := GDK_DECOR_BORDER or GDK_DECOR_TITLE or
|
|
GDK_DECOR_MENU or GDK_DECOR_RESIZEH;
|
|
end;
|
|
|
|
if not (csDesigning in AForm.ComponentState) then
|
|
begin
|
|
if not (biMinimize in AForm.BorderIcons) then
|
|
Result := Result and not GDK_DECOR_MINIMIZE;
|
|
if not (biMaximize in AForm.BorderIcons) then
|
|
Result := Result and not GDK_DECOR_MAXIMIZE;
|
|
if not (biSystemMenu in AForm.BorderIcons) then
|
|
Result := Result and not GDK_DECOR_MENU;
|
|
end;
|
|
|
|
{$ELSE}
|
|
case ABorderStyle of
|
|
bsNone : Result := 0;
|
|
|
|
bsSingle : Result := GDK_DECOR_TITLE or
|
|
GDK_DECOR_MENU or GDK_DECOR_MINIMIZE or
|
|
GDK_DECOR_MAXIMIZE;
|
|
|
|
bsSizeable : Result := GDK_DECOR_BORDER or GDK_DECOR_TITLE or
|
|
GDK_DECOR_MENU or GDK_DECOR_MINIMIZE or GDK_DECOR_MAXIMIZE
|
|
or GDK_DECOR_RESIZEH;
|
|
|
|
bsDialog : Result := GDK_DECOR_BORDER or GDK_DECOR_TITLE or
|
|
GDK_DECOR_MENU or GDK_DECOR_MINIMIZE;
|
|
|
|
bsToolWindow : Result := GDK_DECOR_TITLE or GDK_DECOR_MENU;
|
|
|
|
bsSizeToolWin :Result := GDK_DECOR_BORDER or GDK_DECOR_TITLE or
|
|
GDK_DECOR_MENU or GDK_DECOR_RESIZEH;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
//DebugLn('GetWindowDecorations ',DbgSName(AForm),' ',dbgs(ord(ABorderStyle)),' ',binStr(Result,8));
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function GetWindowFunction(AForm : TCustomForm) : Longint;
|
|
|
|
------------------------------------------------------------------------------}
|
|
function GetWindowFunction(AForm : TCustomForm) : Longint;
|
|
var
|
|
ABorderStyle: TFormBorderStyle;
|
|
begin
|
|
Result:=0;
|
|
if not (csDesigning in AForm.ComponentState) then
|
|
ABorderStyle:=AForm.BorderStyle
|
|
else
|
|
ABorderStyle:=bsSizeable;
|
|
|
|
{$IFDEF Gtk2}
|
|
case ABorderStyle of
|
|
bsNone : Result := GDK_FUNC_RESIZE or GDK_FUNC_CLOSE {$ifndef windows}or GDK_FUNC_MOVE{$endif};
|
|
|
|
bsSingle : Result := GDK_FUNC_MOVE or GDK_FUNC_MINIMIZE or GDK_FUNC_CLOSE;
|
|
|
|
bsSizeable : Result := GDK_FUNC_RESIZE or GDK_FUNC_MOVE or
|
|
GDK_FUNC_MINIMIZE or GDK_FUNC_CLOSE or GDK_FUNC_MAXIMIZE;
|
|
|
|
bsDialog : Result := GDK_FUNC_CLOSE or GDK_FUNC_MINIMIZE
|
|
or GDK_FUNC_MOVE;
|
|
|
|
bsToolWindow : Result := GDK_FUNC_MOVE or GDK_FUNC_CLOSE;
|
|
|
|
bsSizeToolWin : Result := GDK_FUNC_RESIZE or GDK_FUNC_MOVE or GDK_FUNC_CLOSE;
|
|
end;
|
|
|
|
// X warns if marking a fixed size window resizeable:
|
|
if ((AForm.Constraints.MinWidth>0)
|
|
and (AForm.Constraints.MinWidth=AForm.Constraints.MaxWidth))
|
|
or ((AForm.Constraints.MinHeight>0)
|
|
and (AForm.Constraints.MinHeight=AForm.Constraints.MaxHeight)) then
|
|
Result:=Result-GDK_FUNC_RESIZE;
|
|
|
|
if (not (csDesigning in AForm.ComponentState)) then
|
|
begin
|
|
if not (biMinimize in AForm.BorderIcons) then
|
|
Result:=Result and not GDK_FUNC_MINIMIZE;
|
|
if not (biMaximize in AForm.BorderIcons) then
|
|
Result:=Result and not GDK_FUNC_MAXIMIZE;
|
|
end;
|
|
{$ELSE}
|
|
case ABorderStyle of
|
|
bsNone : Result := GDK_FUNC_RESIZE or GDK_FUNC_CLOSE;
|
|
|
|
bsSingle : Result := GDK_FUNC_MOVE or GDK_FUNC_MINIMIZE or GDK_FUNC_CLOSE;
|
|
|
|
bsSizeable : Result := GDK_FUNC_RESIZE or GDK_FUNC_MOVE or
|
|
GDK_FUNC_MINIMIZE or GDK_FUNC_CLOSE or GDK_FUNC_MAXIMIZE;
|
|
|
|
bsDialog : Result := GDK_FUNC_CLOSE or GDK_FUNC_MINIMIZE
|
|
or GDK_FUNC_MOVE;
|
|
|
|
bsToolWindow : Result := GDK_FUNC_MOVE or GDK_FUNC_CLOSE;
|
|
|
|
bsSizeToolWin : Result := GDK_FUNC_RESIZE or GDK_FUNC_MOVE or GDK_FUNC_CLOSE;
|
|
end;
|
|
|
|
// X warns if marking a fixed size window resizeable:
|
|
if ((AForm.Constraints.MinWidth>0)
|
|
and (AForm.Constraints.MinWidth=AForm.Constraints.MaxWidth))
|
|
or ((AForm.Constraints.MinHeight>0)
|
|
and (AForm.Constraints.MinHeight=AForm.Constraints.MaxHeight)) then
|
|
Result:=Result-GDK_FUNC_RESIZE;
|
|
{$ENDIF}
|
|
|
|
//DebugLn('GetWindowFunction ',DbgSName(AForm),' ',dbgs(ord(ABorderStyle)),' ',binStr(Result,8));
|
|
end;
|
|
|
|
procedure FillScreenFonts(ScreenFonts : TStrings);
|
|
var
|
|
{$ifdef gtk1}
|
|
theFonts : PPChar;
|
|
{$else}
|
|
Widget : PGTKWidget;
|
|
Context : PPangoContext;
|
|
families : PPPangoFontFamily;
|
|
{$endif}
|
|
Tmp: AnsiString;
|
|
I, N: Integer;
|
|
begin
|
|
ScreenFonts.Clear;
|
|
{$ifdef gtk1}
|
|
theFonts := XListFonts(gdk_display,PChar('-*-*-*-*-*-*-*-*-*-*-*-*-*-*'), 10000, @N);
|
|
debugln('FillScreenFonts N=',dbgs(N));
|
|
for I := 0 to N - 1 do
|
|
if theFonts[I] <> nil then begin
|
|
Tmp := ExtractFamilyFromXLFDName(theFonts[I]);
|
|
if Tmp <> '' then
|
|
if ScreenFonts.IndexOf(Tmp) < 0 then
|
|
ScreenFonts.Append(Tmp);
|
|
end;
|
|
XFreeFontNames(theFonts);
|
|
{$else}
|
|
Widget := GetStyleWidget(lgsDefault);
|
|
if Widget = nil then begin
|
|
exit;//raise an error here I guess
|
|
end;
|
|
Context := gtk_widget_get_pango_context(Widget);
|
|
if Context = nil then begin
|
|
exit;//raise an error here I guess
|
|
end;
|
|
families := nil;
|
|
pango_context_list_families(Context, @families, @n);
|
|
|
|
for I := 0 to N - 1 do
|
|
if families[I] <> nil then begin
|
|
Tmp := StrPas(pango_font_family_get_name(families[I]));
|
|
if Tmp <> '' then
|
|
if ScreenFonts.IndexOf(Tmp) < 0 then
|
|
ScreenFonts.Append(Tmp);
|
|
end;
|
|
if (families <> nil) then
|
|
g_free(families);
|
|
{$endif gtk2}
|
|
end;
|
|
|
|
function GetTextHeight(DCTextMetric: TDevContextTextMetric): integer;
|
|
// IMPORTANT: Before this call: UpdateDCTextMetric(TGtkDeviceContext(DC));
|
|
begin
|
|
{$IfDef Win32}
|
|
Result := DCTextMetric.TextMetric.tmHeight div 2;
|
|
{$Else}
|
|
Result := DCTextMetric.TextMetric.tmAscent;
|
|
{$EndIf}
|
|
end;
|
|
|
|
{$IFDEF GTK1}
|
|
{ Compile with UseXinerama defined to use the Xinerama extension to avoid dialog
|
|
boxes straddling two monitors. This is only required for GTK1, as it is built
|
|
into GTK2. The Xinerama library is not always available, so the libraries will
|
|
be dynamically loaded. (A single monitor is assumed if the load fails.) On
|
|
some systems only a static Xinerama library is available, so define
|
|
StaticXinerama also. MAC OSX is in this latter category, but it crashed the
|
|
X server when I tried it on a real two monitor display.
|
|
}
|
|
{$IFDEF UseXinerama}
|
|
{$IFDEF StaticXinerama}
|
|
{$LINKLIB Xinerama}
|
|
{$ENDIF}
|
|
var
|
|
FirstScreenCalled: Boolean = False;
|
|
FirstScreenResult: Boolean = False;
|
|
{ Copy record definition from Xinerama unit.
|
|
Can't use the unit itself, as it forces the executable to
|
|
refer to the libraray }
|
|
type
|
|
TXineramaScreenInfo = record
|
|
screen_number : cint;
|
|
x_org : cshort;
|
|
y_org : cshort;
|
|
width : cshort;
|
|
height : cshort;
|
|
end;
|
|
PXineramaScreenInfo = ^TXineramaScreenInfo;
|
|
|
|
function GetFirstScreen: Boolean;
|
|
var
|
|
nMonitors: cint;
|
|
XineramaScreenInfo: PXineramaScreenInfo;
|
|
opcode, firstevent, firsterror: cint;
|
|
XineramaLib: TLibHandle;
|
|
pXineramaIsActive: function (dpy: PDisplay):TBool;cdecl;
|
|
pXineramaQueryScreens: function (dpy: PDisplay;
|
|
number: Pcint): PXineramaScreenInfo;cdecl;
|
|
begin
|
|
if not FirstScreenCalled then begin
|
|
if XQueryExtension(gdk_display, 'XINERAMA', @opcode, @firstevent,
|
|
@firsterror)
|
|
then begin
|
|
XineramaLib := {$IFDEF StaticXinerama} 1 {Flag present} {$ELSE} LoadLibrary('libXinerama.so') {$ENDIF};
|
|
if XineramaLib <> 0 then begin
|
|
{$IFDEF StaticXinerama}
|
|
Pointer(pXineramaIsActive) := @XineramaIsActive;
|
|
Pointer(pXineramaQueryScreens) := @XineramaQueryScreens;
|
|
{$ELSE}
|
|
Pointer(pXineramaIsActive) :=
|
|
GetProcAddress(XineramaLib, 'XineramaIsActive');
|
|
Pointer(pXineramaQueryScreens) :=
|
|
GetProcAddress(XineramaLib, 'XineramaQueryScreens');
|
|
{$ENDIF}
|
|
if (pXineramaIsActive <> nil) and (pXineramaQueryScreens <> nil) and
|
|
pXineramaIsActive(gdk_display)
|
|
then begin
|
|
XineramaScreenInfo := pXineramaQueryScreens(gdk_display, @nMonitors);
|
|
if XineramaScreenInfo <> nil then begin
|
|
if (nMonitors > 0) and (nMonitors < 10) then begin
|
|
FirstScreen.x := XineramaScreenInfo^.width;
|
|
FirstScreen.y := XineramaScreenInfo^.height;
|
|
FirstScreenResult := True;
|
|
end;
|
|
XFree(XineramaScreenInfo);
|
|
end;
|
|
end;
|
|
// Do not FreeLibrary(XineramaLib) because it causes the X11 library to
|
|
// crash on exit
|
|
end;
|
|
end;
|
|
FirstScreenCalled := True;
|
|
end;
|
|
Result := FirstScreenResult;
|
|
end;
|
|
{$ENDIF UseXinerama}
|
|
{$ENDIF Gtk1}
|
|
|
|
{$IFDEF HasX}
|
|
function XGetWorkarea(var ax,ay,awidth,aheight:gint): gint;
|
|
|
|
var
|
|
XDisplay: PDisplay;
|
|
XScreen: PScreen;
|
|
XWindow: TWindow;
|
|
AtomType: x.TAtom;
|
|
Format: gint;
|
|
nitems: gulong;
|
|
bytes_after: gulong;
|
|
current_desktop: pguint;
|
|
res : Integer;
|
|
begin
|
|
Result := -1;
|
|
xdisplay := gdk_display;
|
|
xscreen := XDefaultScreenOfDisplay(xdisplay);
|
|
xwindow := XRootWindowOfScreen(xscreen);
|
|
res:=XGetWindowProperty (xdisplay, xwindow,
|
|
XInternAtom(xdisplay, '_NET_WORKAREA', false),
|
|
0, MaxInt, False, XA_CARDINAL, @atomtype, @format, @nitems,
|
|
@bytes_after, gpointer(@current_desktop));
|
|
if (atomtype = XA_CARDINAL) and (format = 32) and (nitems > 0) then begin
|
|
result:=res;
|
|
ax:=current_desktop[0];
|
|
ay:=current_desktop[1];
|
|
awidth:=current_desktop[2];
|
|
aheight:=current_desktop[3];
|
|
// if an invalid size was given, assume garbage from the window manager
|
|
if (awidth < 1) or (aheight < 1) then result := -1;
|
|
end;
|
|
if current_desktop <> nil then
|
|
XFree (current_desktop);
|
|
end;
|
|
{$ENDIF}
|
|
|
|
function FindFocusWidget(AWidget: PGtkWidget): PGtkWidget;
|
|
var
|
|
WinWidgetInfo: PWinWidgetInfo;
|
|
ImplWidget: PGtkWidget;
|
|
GList: PGlist;
|
|
LastFocusWidget: PGtkWidget;
|
|
begin
|
|
// Default to the widget, try to find other
|
|
Result := AWidget;
|
|
|
|
// Combo
|
|
if GtkWidgetIsA(AWidget, gtk_combo_get_type)
|
|
then begin
|
|
// handle is a gtk combo
|
|
{$IfDef VerboseFocus}
|
|
DebugLn(' D taking gtkcombo entry');
|
|
{$EndIf}
|
|
Result := PgtkWidget(PGtkCombo(AWidget)^.entry);
|
|
Exit;
|
|
end;
|
|
|
|
// check if widget has a WinWidgetInfo record
|
|
WinWidgetInfo := GetWidgetInfo(AWidget, false);
|
|
if WinWidgetInfo = nil then Exit;
|
|
|
|
ImplWidget:= WinWidgetInfo^.CoreWidget;
|
|
if ImplWidget = nil then Exit;
|
|
// set default to the implementation widget
|
|
Result := ImplWidget;
|
|
|
|
// handle has an ImplementationWidget
|
|
if GtkWidgetIsA(ImplWidget, gtk_list_get_type)
|
|
then begin
|
|
{$IfDef VerboseFocus}
|
|
DebugLn(' E using list');
|
|
{$EndIf}
|
|
// Try the last added selected
|
|
if not (selection_mode(PGtkList(ImplWidget)^) in [GTK_SELECTION_SINGLE, GTK_SELECTION_BROWSE])
|
|
and (PGtkList(ImplWidget)^.last_focus_child <> nil)
|
|
then begin
|
|
LastFocusWidget:=PGtkList(ImplWidget)^.last_focus_child;
|
|
if g_list_find(PGtkList(ImplWidget)^.selection,LastFocusWidget)<>nil
|
|
then begin
|
|
Result := PGtkList(ImplWidget)^.last_focus_child;
|
|
{$IfDef VerboseFocus}
|
|
DebugLn(' E.1 using last_focus_child');
|
|
{$EndIf}
|
|
Exit;
|
|
end;
|
|
end;
|
|
|
|
// If there is a selection, try the first
|
|
GList := PGtkList(ImplWidget)^.selection;
|
|
if (GList <> nil) and (GList^.data <> nil)
|
|
then begin
|
|
Result := GList^.data;
|
|
{$IfDef VerboseFocus}
|
|
DebugLn(' E.2 using 1st selection');
|
|
{$EndIf}
|
|
Exit;
|
|
end;
|
|
|
|
// If not in browse mode, set focus to the first child
|
|
// in browsemode, the focused item cannot be selected by mouse
|
|
// if selection_mode(PGtkList(ImplWidget)^) = GTK_SELECTION_BROWSE
|
|
// then begin
|
|
// {$IfDef VerboseFocus}
|
|
// DebugLn(' E.3 Browse mode -> using ImplWidget');
|
|
// {$EndIf}
|
|
// Exit;
|
|
// end;
|
|
|
|
GList := PGtkList(ImplWidget)^.children;
|
|
if GList = nil then Exit;
|
|
if GList^.Data = nil then Exit;
|
|
Result := GList^.Data;
|
|
{$IfDef VerboseFocus}
|
|
DebugLn(' E.4 using 1st child');
|
|
{$EndIf}
|
|
|
|
Exit;
|
|
end;
|
|
|
|
{$IfDef VerboseFocus}
|
|
DebugLn(' E taking ImplementationWidget');
|
|
{$EndIf}
|
|
end;
|
|
|
|
|
|
{$IFDEF ASSERT_IS_ON}
|
|
{$UNDEF ASSERT_IS_ON}
|
|
{$C-}
|
|
{$ENDIF}
|
|
|
|
// included by gtkproc.pp
|