mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-05-30 01:22:43 +02:00
8429 lines
266 KiB
PHP
8429 lines
266 KiB
PHP
// included by gtkproc.pp
|
|
|
|
{******************************************************************************
|
|
Misc Support Functs
|
|
******************************************************************************
|
|
used by:
|
|
GTKObject
|
|
GTKWinAPI
|
|
GTKCallback
|
|
******************************************************************************
|
|
*****************************************************************************
|
|
* *
|
|
* This file is part of the Lazarus Component Library (LCL) *
|
|
* *
|
|
* See the file COPYING.LCL, included in this distribution, *
|
|
* for details about the copyright. *
|
|
* *
|
|
* This program is distributed in the hope that it will be useful, *
|
|
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
|
|
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
|
|
* *
|
|
*****************************************************************************
|
|
}
|
|
|
|
{$IFOPT C-}
|
|
// Uncomment for local trace
|
|
//{$C+}
|
|
//{$DEFINE ASSERT_IS_ON}
|
|
{$ENDIF}
|
|
|
|
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(Style : PGTKWidget) : gint; overload;
|
|
begin
|
|
result := gtk_widget_get_xthickness(gtk_widget_get_style(Style));
|
|
end;
|
|
|
|
function gtk_widget_get_ythickness(Style : PGTKWidget) : gint; overload;
|
|
begin
|
|
result := gtk_widget_get_ythickness(gtk_widget_get_style(Style));
|
|
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) : guint;
|
|
begin
|
|
{$IfDef GTK2}
|
|
result := PGdkEvent(Event)^._type;
|
|
{$Else}
|
|
result := PGdkEvent(Event)^.TheType;
|
|
{$EndIF}
|
|
end;
|
|
|
|
procedure RememberKeyEventWasHandledByLCL(Event: PGdkEventKey;
|
|
BeforeEvent: boolean);
|
|
var
|
|
HandledEvent: TLCLHandledKeyEvent;
|
|
EventList: TList;
|
|
begin
|
|
if KeyEventWasHandledByLCL(Event,BeforeEvent) then exit;
|
|
if BeforeEvent then begin
|
|
if LCLHandledKeyEvents=nil then
|
|
LCLHandledKeyEvents:=TList.Create;
|
|
EventList:=LCLHandledKeyEvents;
|
|
end else begin
|
|
if LCLHandledKeyAfterEvents=nil then
|
|
LCLHandledKeyAfterEvents:=TList.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: TList;
|
|
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;
|
|
|
|
{$IfNdef GTK2}
|
|
function gtk_class_get_type(aclass : Pointer) : TGtkType;
|
|
begin
|
|
If (aclass <> nil) then
|
|
result := PGtkTypeClass(aclass)^.thetype
|
|
else
|
|
result := 0;
|
|
end;
|
|
|
|
function gtk_object_get_class(anobject : Pointer) : Pointer;
|
|
begin
|
|
If (anobject <> nil) then
|
|
result := PGtkTypeObject(anobject)^.klass
|
|
else
|
|
result := nil;
|
|
end;
|
|
|
|
function gtk_window_get_modal(window:PGtkWindow):gboolean;
|
|
begin
|
|
if assigned(Window) then
|
|
result := (Window^.flag0 and bm_modal)<>0
|
|
else
|
|
result := False;
|
|
end;
|
|
|
|
function gtk_bin_get_child(bin : PGTKBin) : PGTKWidget;
|
|
begin
|
|
if (bin <> nil) then
|
|
result := bin^.Child
|
|
else
|
|
result := nil;
|
|
end;
|
|
|
|
Procedure gtk_menu_item_set_right_justified(menu_item : PGtkMenuItem; right_justified : gboolean);
|
|
begin
|
|
if right_justified then
|
|
menu_item^.flag0:=menu_item^.flag0 or bm_right_justify
|
|
else
|
|
menu_item^.flag0:=menu_item^.flag0 and (not bm_right_justify);
|
|
end;
|
|
|
|
Function gtk_check_menu_item_get_active(menu_item : PGtkCheckMenuItem) : gboolean;
|
|
begin
|
|
Result:=(menu_item^.flag0 and bm_checkmenuitem_active <> 0);
|
|
end;
|
|
|
|
Procedure gtk_menu_append(menu : PGTKWidget; Item : PGtkWidget);
|
|
begin
|
|
gtk.gtk_menu_append(PGTKMenu(menu), Item);
|
|
end;
|
|
|
|
Procedure gtk_menu_insert(menu : PGtkWidget; Item : PGTKWidget; Index : gint);
|
|
begin
|
|
gtk.gtk_menu_insert(PGTKMenu(menu), Item, Index);
|
|
end;
|
|
|
|
Procedure gtk_menu_bar_insert(menubar : PGtkWidget; Item : PGTKWidget; Index : gint);
|
|
begin
|
|
gtk.gtk_menu_bar_insert(PGtkMenuBar(menubar), Item, Index);
|
|
end;
|
|
|
|
Function gtk_image_new :PGTKWidget;
|
|
begin
|
|
result := gtk.gtk_image_new(nil,nil);
|
|
end;
|
|
|
|
Function gtk_toolbar_new : PGTKWidget;
|
|
begin
|
|
result := gtk.gtk_toolbar_new(GTK_ORIENTATION_HORIZONTAL,GTK_TOOLBAR_BOTH);
|
|
end;
|
|
|
|
Procedure gtk_color_selection_get_current_color(colorsel : PGTKColorSelection; Color : PGDKColor);
|
|
var
|
|
colorArray : array[0..2] of double;
|
|
begin
|
|
gtk_color_selection_get_color(colorsel, @colorArray[0]);
|
|
Color^.pixel := 0;
|
|
Color^.red := gushort(TruncToCardinal(colorArray[0] * $FFFF));
|
|
Color^.green := gushort(TruncToCardinal(colorArray[1] * $FFFF));
|
|
Color^.blue := gushort(TruncToCardinal(colorArray[2] * $FFFF));
|
|
{$IFDEF VerboseColorDialog}
|
|
DebugLn('gtk_color_selection_get_current_color ',
|
|
' Red=',HexStr(Cardinal(Color^.Red),8),
|
|
' Green=',HexStr(Cardinal(Color^.Green),8),
|
|
' Blue=',HexStr(Cardinal(Color^.Blue),8),
|
|
'');
|
|
{$ENDIF}
|
|
end;
|
|
|
|
Procedure gtk_color_selection_set_current_color(colorsel : PGTKColorSelection;
|
|
Color : PGDKColor);
|
|
var
|
|
SelectionColor: PGDouble;
|
|
begin
|
|
{$IFDEF VerboseColorDialog}
|
|
DebugLn('gtk_color_selection_set_current_color ',
|
|
' Red=',HexStr(Cardinal(Color^.Red),8),
|
|
' Green=',HexStr(Cardinal(Color^.Green),8),
|
|
' Blue=',HexStr(Cardinal(Color^.Blue),8),
|
|
'');
|
|
{$ENDIF}
|
|
GetMem(SelectionColor,4*SizeOf(GDouble));
|
|
try
|
|
SelectionColor[0]:=gdouble(Color^.Red)/65535;
|
|
SelectionColor[1]:=gdouble(Color^.Green)/65535;
|
|
SelectionColor[2]:=gdouble(Color^.Blue)/65535;
|
|
SelectionColor[3]:=0.0;
|
|
gtk_color_selection_set_color(colorSel,SelectionColor);
|
|
finally
|
|
FreeMem(SelectionColor);
|
|
end;
|
|
end;
|
|
|
|
procedure gdk_image_unref(Image : PGdkImage);
|
|
begin
|
|
gdk_window_unref(PGdkWindow(Image));
|
|
end;
|
|
|
|
Function gdk_image_get_colormap(Image : PGDKImage) : PGdkColormap;
|
|
begin
|
|
result := gdk_window_get_colormap(PGdkWindow(Image));
|
|
end;
|
|
|
|
Procedure gdk_colormap_query_color(colormap : PGDKColormap; Pixel : gulong; Result : PGDKColor);
|
|
var
|
|
GdkColorContext: PGdkColorContext;
|
|
begin
|
|
if (Colormap = nil) or (Result = nil) then exit;
|
|
GdkColorContext:= gdk_color_context_new(gdk_colormap_get_visual(colormap),colormap);
|
|
Result^.Pixel := Pixel;
|
|
gdk_color_context_query_color(GdkColorContext, Result);
|
|
gdk_color_context_free(GdkColorContext);
|
|
end;
|
|
|
|
Function gdk_region_intersect(source1:PGdkRegion; source2:PGdkRegion) : PGdkRegion;
|
|
begin
|
|
result := gdk_regions_intersect(source1, source2);
|
|
end;
|
|
|
|
Function gdk_region_union(source1:PGdkRegion; source2:PGdkRegion) : PGdkRegion;
|
|
begin
|
|
result := gdk_regions_union(source1, source2);
|
|
end;
|
|
|
|
Function gdk_region_subtract(source1:PGdkRegion; source2:PGdkRegion) : PGdkRegion;
|
|
begin
|
|
result := gdk_regions_subtract(source1, source2);
|
|
end;
|
|
|
|
Function gdk_region_xor(source1:PGdkRegion; source2:PGdkRegion) : PGdkRegion;
|
|
begin
|
|
result := gdk_regions_xor(source1, source2);
|
|
end;
|
|
|
|
function gdk_region_copy(region: PGDKRegion): PGDKRegion;
|
|
var
|
|
EmptyRegion: PGdkRegion;
|
|
begin
|
|
EmptyRegion := gdk_region_new;
|
|
Result := gdk_regions_union(region, EmptyRegion);
|
|
gdk_region_destroy(EmptyRegion);
|
|
end;
|
|
|
|
function gdk_region_rectangle(rect: PGdkRectangle): PGDKRegion;
|
|
var
|
|
EmptyRegion: PGdkRegion;
|
|
begin
|
|
EmptyRegion := gdk_region_new;
|
|
Result := gdk_region_union_with_rect(EmptyRegion,Rect);
|
|
gdk_region_destroy(EmptyRegion);
|
|
end;
|
|
|
|
Function gdk_pixmap_create_from_xpm_d (window : PGdkWindow; var mask : PGdkBitmap; transparent_color : PGdkColor; data : PPgchar) : PGdkPixmap;
|
|
begin
|
|
result := gdk.gdk_pixmap_create_from_xpm_d(window, @mask, transparent_color, data)
|
|
end;
|
|
|
|
Function gdk_pixmap_colormap_create_from_xpm_d (window : PGdkWindow; colormap: PGdkColormap; var mask : PGdkBitmap; transparent_color : PGdkColor; data : PPgchar) : PGdkPixmap;
|
|
begin
|
|
result := gdk.gdk_pixmap_colormap_create_from_xpm_d(window, colormap, @mask, transparent_color, data)
|
|
end;
|
|
|
|
Function gdk_pixmap_colormap_create_from_xpm (window : PGdkWindow; colormap: PGdkColormap; var mask : PGdkBitmap; transparent_color : PGdkColor; filename : Pgchar) : PGdkPixmap;
|
|
begin
|
|
result := gdk.gdk_pixmap_colormap_create_from_xpm(window, colormap, @mask, transparent_color, filename)
|
|
end;
|
|
|
|
{$IfNDef NoGdkPixbufLib}
|
|
Procedure gdk_pixbuf_render_pixmap_and_mask(pixbuf : PGdkPixbuf; var pixmap_return : PGdkPixmap; var mask_return : PGdkBitmap; alpha_threshold : gint);
|
|
begin
|
|
gdkpixbuf.gdk_pixbuf_render_pixmap_and_mask(pixbuf, @pixmap_return, @mask_return, alpha_threshold);
|
|
end;
|
|
{$EndIf}
|
|
|
|
Function gdk_drawable_get_depth(Drawable : PGDKDrawable) : gint;
|
|
begin
|
|
gdk_window_get_geometry(Drawable, nil, nil, nil, nil, @result);
|
|
end;
|
|
|
|
Procedure gdk_drawable_get_size(Drawable : PGDKDrawable; Width, Height : PGInt);
|
|
begin
|
|
gdk_window_get_geometry(Drawable, nil, nil, Width, Height, nil);
|
|
end;
|
|
|
|
Function gdk_drawable_get_image(Drawable : PGDKDrawable; x, y, width, height : gint) : PGdkImage;
|
|
begin
|
|
result := gdk_image_get(Drawable, x, y, width, height);
|
|
end;
|
|
|
|
Function gdk_drawable_get_colormap(Drawable : PGDKDrawable) : PGdkColormap;
|
|
begin
|
|
result := gdk_window_get_colormap(Drawable);
|
|
end;
|
|
|
|
{$EndIf}
|
|
|
|
{$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(FontDesc : PPangoFontDescription; Str : PChar;
|
|
LineLength : Longint; lbearing, rbearing, width, ascent, descent : Pgint);
|
|
var
|
|
Layout : PPangoLayout;
|
|
AttrList : PPangoAttrList;
|
|
Attr : PPangoAttribute;
|
|
Extents : TPangoRectangle;
|
|
begin
|
|
GetStyle(lgsDefault);
|
|
Layout := gtk_widget_create_pango_layout (GetStyleWidget(lgsDefault), nil);
|
|
pango_layout_set_font_description(Layout, FontDesc);
|
|
AttrList := pango_layout_get_attributes(Layout);
|
|
|
|
If (AttrList = nil) then
|
|
AttrList := pango_attr_list_new();
|
|
|
|
Attr := pango_attr_underline_new(PANGO_UNDERLINE_NONE);
|
|
|
|
pango_attr_list_change(AttrList,Attr);
|
|
|
|
Attr := pango_attr_strikethrough_new(False);
|
|
pango_attr_list_change(AttrList,Attr);
|
|
|
|
pango_layout_set_attributes(Layout, AttrList);
|
|
|
|
pango_layout_set_single_paragraph_mode(Layout, TRUE);
|
|
pango_layout_set_width(Layout, -1);
|
|
|
|
pango_layout_set_alignment(Layout, PANGO_ALIGN_LEFT);
|
|
|
|
//fix me... and what about UTF-8 conversion?
|
|
//this could be a massive problem since we
|
|
//will need to know before hand what the current
|
|
//locale is, and if we stored UTF-8 string this would break
|
|
//cross-compatibility with GTK1.2 and win32 interfaces.....
|
|
|
|
pango_layout_set_text(Layout, Str, Linelength);
|
|
|
|
if Assigned(width) then
|
|
pango_layout_get_pixel_size(Layout, width, nil);
|
|
|
|
pango_layout_get_extents(Layout, nil, @Extents);
|
|
g_object_unref(Layout);
|
|
|
|
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;
|
|
|
|
{$EndIf}
|
|
|
|
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 REPORT_GDK_ERRORS}
|
|
If (Xerror<>0) then
|
|
RaiseException('A GDK/X Error occured, this is normally fatal. The error code was : ' + IntToStr(Xerror));
|
|
{$EndIf}
|
|
end;
|
|
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure RaiseException(const Msg: string);
|
|
|
|
Raises an exception.
|
|
gdb does not catch fpc Exception objects, therefore this procedure raises
|
|
a standard AV which is catched by gdb.
|
|
------------------------------------------------------------------------------}
|
|
procedure RaiseException(const Msg: string);
|
|
begin
|
|
DebugLn('ERROR in gtk-interface: ',Msg);
|
|
// creates an exception, that gdb catches:
|
|
DebugLn('Creating gdb catchable error:');
|
|
if (length(Msg) div (length(Msg) div 10000))=0 then ;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function CreatePChar(const s: string): PChar;
|
|
|
|
Allocates a new PChar
|
|
------------------------------------------------------------------------------}
|
|
function CreatePChar(const s: string): PChar;
|
|
begin
|
|
Result:=StrAlloc(length(s) + 1);
|
|
StrPCopy(Result, s);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function ComparePChar(P1, P2: PChar): boolean;
|
|
|
|
Checks if P1 and P2 have the same content.
|
|
------------------------------------------------------------------------------}
|
|
function ComparePChar(P1, P2: PChar): boolean;
|
|
begin
|
|
if (P1<>P2) then begin
|
|
if (P1<>nil) and (P2<>nil) then begin
|
|
while (P1^=P2^) do begin
|
|
if P1^<>#0 then begin
|
|
inc(P1);
|
|
inc(P2);
|
|
end else begin
|
|
Result:=true;
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
Result:=false;
|
|
end else begin
|
|
Result:=true;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function FindChar(c: char; p:PChar; Max: integer): integer;
|
|
------------------------------------------------------------------------------}
|
|
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 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 (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
|
|
Result:=HexStr(Cardinal(Widget),8);
|
|
if Widget=nil then exit;
|
|
Result:=Result+'='+GetWidgetClassName(Widget);
|
|
Result:=Result+' '+WidgetFlagsToString(Widget);
|
|
LCLObject:=GetNearestLCLObject(Widget);
|
|
Result:=Result+' LCLObject='+HexStr(Cardinal(LCLObject),8);
|
|
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 begin
|
|
Result:=Result+'<Is MainWidget>';
|
|
end else begin
|
|
Result:=Result+'<MainWidget='+HexStr(Cardinal(MainWidget),8)
|
|
+'='+GetWidgetClassName(MainWidget)+'>';
|
|
end;
|
|
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: Pgpointer;
|
|
Widget: PGtkWidget;
|
|
WindowType: TGdkWindowType;
|
|
Width: Integer;
|
|
Height: Integer;
|
|
Visual: PGdkVisual;
|
|
TypeAsStr: String;
|
|
begin
|
|
Result:=HexStr(Cardinal(AWindow),8);
|
|
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),GTKAPIWidget_GetType) then begin
|
|
Widget:=PGTKWidget(p);
|
|
Result:=Result+'<Widget['+GetWidgetDebugReport(Widget)+']>';
|
|
end else begin
|
|
Result:=Result+'<UserData='+HexStr(Cardinal(p),8)+']>';
|
|
end;
|
|
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 begin
|
|
if WindowType in [GDK_WINDOW_PIXMAP] then begin
|
|
Result:=Result+' Depth='+IntToStr(Visual^.bits_per_rgb);
|
|
end;
|
|
end;
|
|
{$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+'BG_Pixmap[N]:='+HexStr(Cardinal(AStyle^.bg_pixmap[GTK_STATE_NORMAL]),8)+' ';
|
|
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+'" ';
|
|
{$ELSE GTK1}
|
|
{$WARNING TODO find GTK2 font naming}
|
|
{$ENDIF GTK1}
|
|
Result:=Result+'bg_pixmap_name[N]="'+AStyle^.bg_pixmap_name[GTK_STATE_NORMAL]+'" ';
|
|
{$IFDEF GTK1}
|
|
Result:=Result+'engine='+HexStr(Cardinal(AStyle^.engine),8);
|
|
{$ELSE GTK1}
|
|
{$WARNING TODO find GTK2 theme engine}
|
|
{$ENDIF GTK1}
|
|
end;
|
|
Result:=Result+']';
|
|
end;
|
|
|
|
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';
|
|
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 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 HideCaretOfWidgetGroup(ChildWidget: PGtkWidget;
|
|
var MainWidget: PGtkWidget; var CaretWasVisible: boolean);
|
|
|
|
Find main widget and if it is a API widget, hide caret.
|
|
------------------------------------------------------------------------------}
|
|
procedure HideCaretOfWidgetGroup(ChildWidget: PGtkWidget;
|
|
var MainWidget: PGtkWidget; var CaretWasVisible: boolean);
|
|
var
|
|
LCLObject: TObject;
|
|
IsAPIWidget: Boolean;
|
|
begin
|
|
MainWidget:=ChildWidget;
|
|
LCLObject:=GetNearestLCLObject(ChildWidget);
|
|
if (LCLObject is TWinControl) then
|
|
MainWidget:=PGtkWidget(TWinControl(LCLObject).Handle);
|
|
IsAPIWidget:=GtkWidgetIsA(MainWidget,GTKAPIWidget_GetType);
|
|
CaretWasVisible:=false;
|
|
if IsAPIWidget then
|
|
GTKAPIWidget_HideCaret(PGTKAPIWidget(MainWidget),CaretWasVisible);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure SetComboBoxText(ComboWidget: PGtkCombo; const NewText: string);
|
|
|
|
Sets the text of the combobox entry.
|
|
------------------------------------------------------------------------------}
|
|
procedure SetComboBoxText(ComboWidget: PGtkCombo; NewText: PChar);
|
|
begin
|
|
//DebugLn('SetComboBoxText ',HexStr(Cardinal(ComboWidget),8),' "',NewText,'"');
|
|
// lock combobox, so that no OnChange event is fired
|
|
LockOnChange(PGtkObject(ComboWidget^.entry),+1);
|
|
// set text
|
|
if NewText = nil then NewText:=#0; // gtk expects at least a #0
|
|
//writeln('SetComboBoxText A ',HexStr(Cardinal(NewText),8));
|
|
gtk_entry_set_text(PGtkEntry(ComboWidget^.entry), NewText);
|
|
// unlock combobox
|
|
LockOnChange(PGtkObject(ComboWidget^.entry),-1);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function GetComboBoxItemIndex(ComboBox: TComboBox): integer;
|
|
|
|
Returns the current ItemIndex of a TComboBox
|
|
------------------------------------------------------------------------------}
|
|
function GetComboBoxItemIndex(ComboBox: TComboBox): integer;
|
|
begin
|
|
Result:=ComboBox.Items.IndexOf(ComboBox.Text);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure SetComboBoxItemIndex(ComboBox: TComboBox; Index: integer);
|
|
|
|
Returns the current ItemIndex of a TComboBox
|
|
------------------------------------------------------------------------------}
|
|
procedure SetComboBoxItemIndex(ComboBox: TComboBox; Index: integer);
|
|
var
|
|
ComboWidget: PGtkCombo;
|
|
begin
|
|
ComboWidget:=PGtkCombo(ComboBox.Handle);
|
|
gtk_list_select_item(PGtkList(ComboWidget^.list),Index);
|
|
if Index>=0 then
|
|
SetComboBoxText(ComboWidget,PChar(ComboBox.Items[Index]));
|
|
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;
|
|
begin
|
|
Result.Msg:=LM_PAINT;
|
|
New(PS);
|
|
PS^.hDC:=0;
|
|
If GtkPaintMsg.Data.RepaintAll then
|
|
PS^.rcPaint := Rect(0,0,0,0)
|
|
else
|
|
PS^.rcPaint := GtkPaintMsg.Data.Rect;
|
|
|
|
Result.DC:=BeginPaint(THandle(GtkPaintMsg.Data.Widget), PS^);
|
|
Result.PaintStruct:=PS;
|
|
Result.Result:=0;
|
|
if FreeGtkPaintMsg then
|
|
FreeThenNil(GtkPaintMsg.Data);
|
|
end;
|
|
|
|
procedure FinalizePaintMessage(Msg: PLMessage);
|
|
var
|
|
PS : PPaintStruct;
|
|
DC : TDeviceContext;
|
|
begin
|
|
if (Msg^.Msg=LM_PAINT) or (Msg^.Msg=LM_INTERNALPAINT) then begin
|
|
If Msg^.LParam <> 0 then begin
|
|
PS := PPaintStruct(Msg^.LParam);
|
|
If Msg^.WParam<>0 then
|
|
DC := TDeviceContext(Msg^.WParam)
|
|
else
|
|
DC := TDeviceContext(PS^.hdc);
|
|
EndPaint(THandle(DC.wnd), 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 begin
|
|
FreeThenNil(TLMGtkPaint(Msg^).Data);
|
|
end;
|
|
end;
|
|
|
|
procedure FinalizePaintTagMsg(Msg: PMsg);
|
|
var
|
|
PS : PPaintStruct;
|
|
DC : TDeviceContext;
|
|
begin
|
|
if (Msg^.Message=LM_PAINT) or (Msg^.Message=LM_INTERNALPAINT) then begin
|
|
If Msg^.LParam <> 0 then begin
|
|
PS := PPaintStruct(Msg^.LParam);
|
|
If Msg^.WParam<>0 then
|
|
DC := TDeviceContext(Msg^.WParam)
|
|
else
|
|
DC := TDeviceContext(PS^.hdc);
|
|
EndPaint(THandle(DC.wnd), 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 begin
|
|
FreeThenNil(TObject(Msg^.WParam));
|
|
end;
|
|
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: TDeviceContext; DestinationGC: PGDKGC;
|
|
X, Y, Width, Height: integer; ClipMergeMask: PGdkPixmap;
|
|
ClipMergeMaskX, ClipMergeMaskY: integer;
|
|
var NewClipMask: PGdkPixmap);
|
|
// merge ClipMergeMask into the destination clipping mask at the
|
|
// destination rectangle
|
|
var
|
|
temp_gc : PGDKGC;
|
|
temp_color : TGDKColor;
|
|
Region: PGdiObject;
|
|
RGNType : Longint;
|
|
OffsetXY: TPoint;
|
|
//ClipMergeMaskWidth, ClipMergeMaskHeight: integer;
|
|
begin
|
|
{$IFDEF VerboseStretchCopyArea}
|
|
DebugLn('MergeClipping START DestinationDC=',HexStr(Cardinal(DestinationDC),8),
|
|
' DestinationGC=',HexStr(Cardinal(DestinationGC),8),
|
|
' X=',X,' Y=',Y,' Width=',Width,' Height=',Height,
|
|
' ClipMergeMask=',HexStr(Cardinal(ClipMergeMask),8),
|
|
' ClipMergeMaskX=',ClipMergeMaskX,' ClipMergeMaskY=',ClipMergeMaskY);
|
|
{$ENDIF}
|
|
|
|
// activate clipping region of destination
|
|
SelectGDIRegion(HDC(DestinationDC));
|
|
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, height);
|
|
gdk_draw_rectangle(NewClipMask, temp_gc, 0, 0, 0, width, height);
|
|
|
|
// copy the destination clipping mask into the temporary mask
|
|
with DestinationDC do begin
|
|
If (ClipRegion <> 0) then begin
|
|
Region:=PGDIObject(ClipRegion);
|
|
RGNType := RegionType(Region^.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(Region^.GDIRegionObject,OffsetXY.X,OffsetXY.Y);
|
|
// 2. Apply region to temporary mask
|
|
gdk_gc_set_clip_region(temp_gc, Region^.GDIRegionObject);
|
|
// 3. Undo moving the region
|
|
gdk_region_offset(Region^.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, Width, Height);
|
|
|
|
// 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;
|
|
|
|
procedure ResetGCClipping(DC: HDC; GC: PGDKGC);
|
|
begin
|
|
BeginGDKErrorTrap;
|
|
gdk_gc_set_clip_mask(GC, nil);
|
|
gdk_gc_set_clip_origin (GC, 0,0);
|
|
SelectGDIRegion(DC);
|
|
EndGDKErrorTrap;
|
|
end;
|
|
|
|
function ScalePixmap(ScaleGC: PGDKGC;
|
|
SrcPixmap: PGdkPixmap; SrcX, SrcY, SrcWidth, SrcHeight: integer;
|
|
SrcColorMap: PGdkColormap;
|
|
NewWidth, NewHeight: integer;
|
|
var NewPixmap: PGdkPixmap) : Boolean;
|
|
{$Ifndef NoGdkPixbufLib}
|
|
var
|
|
ScaleSrc, ScaleDest: PGDKPixbuf;
|
|
ShrinkWidth,
|
|
ShrinkHeight : Boolean;
|
|
ScaleMethod : TGDKINTERPTYPE;
|
|
DummyMask: PGdkPixmap;
|
|
SrcWholeWidth, SrcWholeHeight: integer;
|
|
{$IFDEF VerboseStretchCopyArea}
|
|
NewWholeWidth, NewWholeHeight: integer;
|
|
{$ENDIF}
|
|
begin
|
|
{$IFDEF VerboseStretchCopyArea}
|
|
DebugLn('ScalePixmap ScaleGC=',HexStr(Cardinal(ScaleGC),8),
|
|
' SrcPixmap=[',GetWindowDebugReport(SrcPixmap),']',
|
|
' SrcX=',SrcX,' SrcY=',SrcY,' SrcWidth=',SrcWidth,' SrcHeight=',SrcHeight,
|
|
' NewPixmap=[',GetWindowDebugReport(NewPixmap),']',
|
|
' NewWidth=',NewWidth,' NewHeight=',NewHeight);
|
|
{$ENDIF}
|
|
Result := False;
|
|
if SrcPixmap=nil then begin
|
|
DebugLn('WARNING: ScalePixmap SrcPixmap=nil');
|
|
exit;
|
|
end;
|
|
if NewPixmap<>nil then begin
|
|
DebugLn('WARNING: ScalePixmap NewPixmap<>nil');
|
|
exit;
|
|
end;
|
|
|
|
ScaleSRC := nil;
|
|
ScaleDest := nil;
|
|
|
|
gdk_window_get_size(PGDKWindow(SrcPixmap),@SrcWholeWidth,@SrcWholeHeight);
|
|
if SrcX+SrcWidth>SrcWholeWidth then begin
|
|
DebugLn('WARNING: ScalePixmap SrcX+SrcWidth>SrcWholeWidth');
|
|
end;
|
|
if SrcY+SrcHeight>SrcWholeHeight then begin
|
|
DebugLn('WARNING: ScalePixmap SrcY+SrcHeight>SrcWholeHeight');
|
|
end;
|
|
|
|
// calculate ScaleMethod
|
|
ShrinkWidth := NewWidth < SrcWidth;
|
|
ShrinkHeight := NewHeight < SrcHeight;
|
|
//GDKPixbuf Scaling is not done in the same way as Windows
|
|
//but by rights ScaleMethod should really be chosen based
|
|
//on the destination device's internal flag
|
|
{GDK_INTERP_NEAREST,GDK_INTERP_TILES,
|
|
GDK_INTERP_BILINEAR,GDK_INTERP_HYPER);}
|
|
If ShrinkWidth and ShrinkHeight then
|
|
ScaleMethod := GDK_INTERP_TILES
|
|
else
|
|
If ShrinkWidth or ShrinkHeight then
|
|
ScaleMethod := GDK_INTERP_BILINEAR//GDK_INTERP_HYPER
|
|
else
|
|
ScaleMethod := GDK_INTERP_BILINEAR;
|
|
|
|
// Creating PixBuf from pixmap
|
|
{$IFDEF VerboseStretchCopyArea}
|
|
DebugLn('ScalePixmap Creating PixBuf from pixmap SrcWhole=',SrcWholeWidth,',',SrcWholeHeight);
|
|
{$ENDIF}
|
|
ScaleSRC := gdk_pixbuf_get_from_drawable(nil,SrcPixmap,
|
|
SrcColorMap,0,0,SrcX,SrcY,SrcWidth,SrcHeight);
|
|
If ScaleSRC = nil then begin
|
|
DebugLn('WARNING: ScalePixmap ScaleSRC=nil');
|
|
exit;
|
|
end;
|
|
|
|
// Scaling PixBuf
|
|
{$IFDEF VerboseStretchCopyArea}
|
|
DebugLn('ScalePixmap Scaling PixBuf ',
|
|
' Width=',gdk_pixbuf_get_width(ScaleSrc),
|
|
' Height=',gdk_pixbuf_get_height(ScaleSrc),
|
|
' HasAlpha=',gdk_pixbuf_get_has_alpha(ScaleSrc),
|
|
' RowStride=',gdk_pixbuf_get_rowstride(ScaleSrc),
|
|
'');
|
|
{$ENDIF}
|
|
ScaleDest := gdk_pixbuf_scale_simple(ScaleSRC,NewWidth,NewHeight,ScaleMethod);
|
|
GDK_Pixbuf_Unref(ScaleSRC);
|
|
If ScaleDest = nil then begin
|
|
DebugLn('WARNING: ScalePixmap ScaleDest=nil');
|
|
exit;
|
|
end;
|
|
BeginGDKErrorTrap;
|
|
|
|
// Creating pixmap from scaled pixbuf
|
|
{$IFDEF VerboseStretchCopyArea}
|
|
DebugLn('ScalePixmap Creating pixmap from scaled pixbuf',
|
|
' Width=',gdk_pixbuf_get_width(ScaleDest),
|
|
' Height=',gdk_pixbuf_get_height(ScaleDest),
|
|
' HasAlpha=',gdk_pixbuf_get_has_alpha(ScaleDest),
|
|
' RowStride=',gdk_pixbuf_get_rowstride(ScaleDest),
|
|
'');
|
|
{$ENDIF}
|
|
DummyMask:=nil;
|
|
gdk_pixbuf_render_pixmap_and_mask(ScaleDest,NewPixmap,DummyMask,0);
|
|
|
|
// clean up
|
|
{$IFDEF VerboseStretchCopyArea}
|
|
gdk_window_get_size(PGDKWindow(NewPixmap),@NewWholeWidth,@NewWholeHeight);
|
|
DebugLn('ScalePixmap RESULT NewPixmap=',HexStr(Cardinal(NewPixmap),8),
|
|
' DummyMask=',HexStr(Cardinal(DummyMask),8),
|
|
' NewWidth=',NewWholeWidth,' NewHeight=',NewWholeHeight,
|
|
'');
|
|
{$ENDIF}
|
|
if DummyMask<>nil then gdk_pixmap_unref(DummyMask);
|
|
EndGDKErrorTrap;
|
|
GDK_Pixbuf_Unref(ScaleDest);
|
|
Result := True;
|
|
{$Else not NoGdkPixbufLib}
|
|
begin
|
|
DebugLn('ScalePixmap GDKPixbuf support has been disabled, no stretching is available!');
|
|
Result := True;
|
|
{$EndIf}
|
|
end;
|
|
|
|
procedure DrawImageListIconOnWidget(ImgList: TCustomImageList;
|
|
Index: integer; DestWidget: PGTKWidget);
|
|
begin
|
|
DrawImageListIconOnWidget(ImgList,Index,DestWidget,true,true,0,0);
|
|
end;
|
|
|
|
procedure DrawImageListIconOnWidget(ImgList: TCustomImageList;
|
|
Index: integer; DestWidget: PGTKWidget;
|
|
CenterHorizontally, CenterVertically: boolean;
|
|
DestLeft, DestTop: integer);
|
|
// draw icon of imagelist centered on gdkwindow
|
|
var
|
|
Bitmap, MaskBitmap: TBitmap;
|
|
ImageRect: TRect;
|
|
ImageWidth: Integer;
|
|
ImageHeight: Integer;
|
|
WindowWidth, WindowHeight: integer;
|
|
DestDC: HDC;
|
|
begin
|
|
//DebugLn('DrawImageListIconOnWidget A ',ImgList.Name,':',ImgList.ClassName,
|
|
// ' Index=',Index,
|
|
// ' DestWindow=[',GetWidgetDebugReport(DestWidget),']');
|
|
if ImgList=nil then exit;
|
|
if (Index<0) or (Index>=ImgList.Count) then exit;
|
|
if (DestWidget=nil) then exit;
|
|
ImgList.GetInternalImage(Index,Bitmap,MaskBitmap,ImageRect);
|
|
ImageWidth:=ImageRect.Right-ImageRect.Left;
|
|
ImageHeight:=ImageRect.Bottom-ImageRect.Top;
|
|
if (ImageWidth<1) or (ImageHeight<1) then exit;
|
|
|
|
WindowWidth:=DestWidget^.allocation.width;
|
|
WindowHeight:=DestWidget^.allocation.height;
|
|
if CenterHorizontally then
|
|
DestLeft:=DestWidget^.allocation.x+((WindowWidth-ImageWidth) div 2);
|
|
if CenterVertically then
|
|
DestTop:=DestWidget^.allocation.y+((WindowHeight-ImageHeight) div 2);
|
|
DestDC:=GetDC(HDC(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,ImageRect.Left,ImageRect.Top,ImageWidth,ImageHeight,
|
|
SRCCOPY);
|
|
ReleaseDC(HDC(DestWidget),DestDC);
|
|
end;
|
|
|
|
function CreateGdkBitmap(Window: PGdkWindow;
|
|
Width, Height: integer): PGdkBitmap;
|
|
var
|
|
DummyData: Pointer;
|
|
begin
|
|
// I didn't found a simple gdk_bitmap_new function. So, I create some
|
|
// dummy data and use gdk_bitmap_create_from_data
|
|
GetMem(DummyData,(((Width*Height)+7) shr 3)+1);
|
|
Result:=gdk_bitmap_create_from_data(Window,DummyData,Width,Height);
|
|
FreeMem(DummyData);
|
|
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:=CreateGdkBitmap(nil,SrcWidth,SrcHeight);
|
|
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;
|
|
|
|
{$IfDef Win32}
|
|
Procedure gdk_window_copy_area(Dest : PGDKWindow; GC : PGDKGC; DestX,
|
|
DestY : Longint; SRC : PGDKWindow; XSRC, YSRC, Width, Height : Longint);
|
|
begin
|
|
gdk_draw_pixmap(Dest, GC, Src, XSrc, YSrc, DestX, DestY, Width, Height);
|
|
End;
|
|
{$EndIf}
|
|
|
|
{------------------------------------------------------------------------------
|
|
Function: AllocGDKColor
|
|
Params: AColor: A RGB color (TColor)
|
|
Returns: an Allocated GDKColor
|
|
|
|
Allocated a GDKColor from a winapi color
|
|
------------------------------------------------------------------------------}
|
|
function AllocGDKColor(const AColor: LongInt): 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;
|
|
BeginGDKErrorTrap;
|
|
gdk_colormap_alloc_color(gdk_colormap_get_system, @Result, False, True);
|
|
EndGDKErrorTrap;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Function: CopyDCData
|
|
Params: DestinationDC: a dc to copy data to
|
|
SourceDC: a dc to copy data from
|
|
Returns: True if succesful
|
|
|
|
Creates a copy DC from the given DC
|
|
------------------------------------------------------------------------------}
|
|
function CopyDCData(DestinationDC, SourceDC: TDeviceContext): Boolean;
|
|
var
|
|
GCValues: TGDKGCValues;
|
|
begin
|
|
Assert(False, Format('Trace:> [CopyDCData] DestDC:0x%x, SourceDC:0x%x', [Integer(DestinationDC), Integer(SourceDC)]));
|
|
Result := (DestinationDC <> nil) and (SourceDC <> nil);
|
|
if Result
|
|
then begin
|
|
with DestinationDC do
|
|
begin
|
|
Wnd := SourceDC.Wnd;
|
|
Drawable := SourceDC.Drawable;
|
|
if GC<>nil then begin
|
|
BeginGDKErrorTrap;
|
|
gdk_gc_unref(GC);
|
|
EndGDKErrorTrap;
|
|
GC:=nil;
|
|
DCFlags:=DCFlags-[dcfPenSelected];
|
|
end;
|
|
if (SourceDC.GC <> nil) and (Drawable <> nil) then begin
|
|
BeginGDKErrorTrap;
|
|
gdk_gc_get_values(SourceDC.GC, @GCValues);
|
|
GC := gdk_gc_new_with_values(Drawable, @GCValues, 3 { $3FF});
|
|
EndGDKErrorTrap;
|
|
DCFlags:=DCFlags-[dcfPenSelected];
|
|
end;
|
|
|
|
Origin := SourceDC.Origin;
|
|
SpecialOrigin := SourceDC.SpecialOrigin;
|
|
PenPos := SourceDC.PenPos;
|
|
|
|
if (dcfTextMetricsValid in SourceDC.DCFlags) then begin
|
|
Include(DCFlags,dcfTextMetricsValid);
|
|
DCTextMetric := SourceDC.DCTextMetric;
|
|
end else
|
|
Exclude(DCFlags,dcfTextMetricsValid);
|
|
CurrentBitmap := SourceDC.CurrentBitmap;
|
|
CurrentFont := SourceDC.CurrentFont;
|
|
CurrentPen := SourceDC.CurrentPen;
|
|
CurrentBrush := SourceDC.CurrentBrush;
|
|
//CurrentPalette := SourceDC.CurrentPalette;
|
|
CopyGDIColor(SourceDC.CurrentTextColor,CurrentTextColor);
|
|
CopyGDIColor(SourceDC.CurrentBackColor,CurrentBackColor);
|
|
ClipRegion := SourceDC.ClipRegion;
|
|
|
|
SelectedColors := dcscCustom;
|
|
SavedContext := nil;
|
|
end;
|
|
end;
|
|
Assert(False, Format('Trace:< [CopyDCData] DestDC:0x%x, SourceDC:0x%x --> %d', [Integer(DestinationDC), Integer(SourceDC), Integer(Result)]));
|
|
end;
|
|
|
|
Function RegionType(RGN: PGDKRegion) : Longint;
|
|
var
|
|
aRect : TGDKRectangle;
|
|
SimpleRGN: PGdkRegion;
|
|
begin
|
|
BeginGDKErrorTrap;
|
|
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;
|
|
EndGDKErrorTrap;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Procedure SelectGDIRegion(const DC: HDC);
|
|
|
|
Applies the current clipping region of the DC (DeviceContext) to the
|
|
gc (GDK Graphic context - pgdkGC)
|
|
------------------------------------------------------------------------------}
|
|
Procedure SelectGDIRegion(const DC: HDC);
|
|
var
|
|
Region: PGdiObject;
|
|
RGNType : Longint;
|
|
begin
|
|
with TDeviceContext(DC) do
|
|
begin
|
|
BeginGDKErrorTrap;
|
|
gdk_gc_set_clip_region(gc, nil);
|
|
gdk_gc_set_clip_rectangle (gc, nil);
|
|
If (ClipRegion <> 0) then begin
|
|
Region:=PGDIObject(ClipRegion);
|
|
RGNType := RegionType(Region^.GDIRegionObject);
|
|
If (RGNType <> ERROR) and (RGNType <> NULLREGION) then begin
|
|
gdk_gc_set_clip_region(gc, PGDIObject(ClipRegion)^.GDIRegionObject);
|
|
end;
|
|
end;
|
|
EndGDKErrorTrap;
|
|
end;
|
|
end;
|
|
|
|
function GDKRegionAsString(RGN: PGDKRegion): string;
|
|
var
|
|
aRect: TGDKRectangle;
|
|
begin
|
|
Result:=HexStr(Cardinal(RGN),8);
|
|
BeginGDKErrorTrap;
|
|
gdk_region_get_clipbox(RGN,@aRect);
|
|
EndGDKErrorTrap;
|
|
Result:=Result+'('+IntToStr(aRect.x)+','+IntToStr(aRect.y)+','
|
|
+IntToStr(aRect.Width)+','+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;
|
|
BeginGDKErrorTrap;
|
|
Result:=gdk_region_rectangle(@GDKRect);
|
|
EndGDKErrorTrap;
|
|
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 : Longint;
|
|
begin
|
|
if DC=0 then ;
|
|
if not (cfColorAllocated in GDIColor^.ColorFlags) then begin
|
|
RGBColor := ColorToRGB(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 TDeviceContext(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 EnsureAsGCValues;
|
|
var
|
|
AllocFG : Boolean;
|
|
SysGCValues: TGdkGCValues;
|
|
begin
|
|
FreeGDIColor(GDIColor);
|
|
SysGCValues:=GetSysGCValues(GDIColor^.ColorRef,
|
|
PGtkWidget(TDeviceContext(DC).Wnd));
|
|
{$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF}
|
|
With SysGCValues do begin
|
|
gdk_gc_set_fill(GC, fill);
|
|
AllocFG := Foreground.Pixel = 0;
|
|
If AllocFG then
|
|
if not gdk_colormap_alloc_color(GDK_Colormap_get_system,@Foreground,
|
|
True,True)
|
|
then begin
|
|
DebugLn('NOTE: EnsureGCColor.EnsureAsGCValues gdk_colormap_alloc_color failed ',
|
|
' Foreground=',
|
|
HexStr(Cardinal(Foreground.red),4),',',
|
|
HexStr(Cardinal(Foreground.green),4),',',
|
|
HexStr(Cardinal(Foreground.blue),4),
|
|
' GDIColor^.ColorRef=',HexStr(Cardinal(GDIColor^.ColorRef),8)
|
|
);
|
|
end;
|
|
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 ',HexStr(Cardinal(GDIColor^.ColorRef),8),' 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:=TDeviceContext(DC).GC;
|
|
GDIColor:=nil;
|
|
with TDeviceContext(DC) do
|
|
begin
|
|
case ColorType of
|
|
dccCurrentBackColor: GDIColor:=@CurrentBackColor;
|
|
dccCurrentTextColor: GDIColor:=@CurrentTextColor;
|
|
dccGDIBrushColor : GDIColor:=@(CurrentBrush^.GDIBrushColor);
|
|
dccGDIPenColor : GDIColor:=@(CurrentPen^.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,
|
|
clHighlightText,
|
|
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)
|
|
|
|
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);
|
|
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(Pal : PGDIObject; Entries : PPALETTEENTRY; RGBCount : Longint);
|
|
var
|
|
PalEntries : PPALETTEENTRY;
|
|
I : Integer;
|
|
RGBValue : Longint;
|
|
begin
|
|
PalEntries := Entries;
|
|
For I := 0 to RGBCount - 1 do begin
|
|
If PaletteIndexExists(Pal, I) then
|
|
PaletteDeleteIndex(Pal, I);
|
|
With PalEntries[I] do
|
|
RGBValue := RGB(peRed, peGreen, peBlue) {or (peFlags shl 32)??};
|
|
If not PaletteRGBExists(Pal, RGBValue) then
|
|
PaletteAddIndex(Pal, I, RGBValue);
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Procedure: KeySymToVKeyArray
|
|
Params: AKeySym: The keysym the array is requested for
|
|
ACreate: True if the array should be created if it does not exist
|
|
Returns: PVKeyArray: The VKey array for the LSByte of KeySym
|
|
|
|
Retrieves or constructs a VKeyArray for VK lookup on KeySyms.
|
|
------------------------------------------------------------------------------}
|
|
function KeySymToVKeyArray(const AKeySym: Cardinal; const ACreate: Boolean): PVKeyArray1;
|
|
var
|
|
K: Byte;
|
|
P2: PVKeyArray2;
|
|
P3: PVKeyArray3;
|
|
begin
|
|
Result := nil;
|
|
|
|
K := Byte(AKeySym shr 24);
|
|
P3 := MKeySymToVK[K];
|
|
if P3 = nil
|
|
then begin
|
|
if not ACreate then Exit;
|
|
New(P3);
|
|
FillChar(P3^, SizeOf(P3^), 0);
|
|
MKeySymToVK[K] := P3;
|
|
end;
|
|
|
|
K := Byte(AKeySym shr 16);
|
|
P2 := P3^[K];
|
|
if P2 = nil
|
|
then begin
|
|
if not ACreate then Exit;
|
|
New(P2);
|
|
FillChar(P2^, SizeOf(P2^), 0);
|
|
P3^[K] := P2;
|
|
end;
|
|
|
|
K := Byte(AKeySym shr 8);
|
|
Result := P2^[K];
|
|
if Result = nil
|
|
then begin
|
|
if not ACreate then Exit;
|
|
New(Result);
|
|
FillChar(Result^, SizeOf(Result^), 0);
|
|
P2^[K] := Result;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Procedure: KeySymToVKey
|
|
Params: AKeySym: The keysym the array is requested for
|
|
Returns: The VKey for the KeySym
|
|
|
|
Retrieves a VKey for a KeySyms.
|
|
------------------------------------------------------------------------------}
|
|
function KeySymToVKey(const AKeySym: Cardinal): TVKeyRecord;
|
|
var
|
|
P: PVKeyArray1;
|
|
begin
|
|
P := KeySymToVKeyArray(AKeySym, False);
|
|
if P = nil
|
|
then begin
|
|
Result.VKey := $FF;
|
|
Result.Flags := $FF;
|
|
end
|
|
else begin
|
|
Result := P^[AKeySym and $FF];
|
|
end;
|
|
end;
|
|
|
|
function HandleGTKKeyUpDown(Widget: PGtkWidget; Event: PGdkEventKey;
|
|
Data: gPointer; BeforeEvent: boolean) : GBoolean;
|
|
{off $DEFINE VerboseKeyboard}
|
|
var
|
|
Msg: TLMKey;
|
|
EventStopped: Boolean;
|
|
EventString: PChar; // GTK1 and GTK2 workaround
|
|
// (and easy access to bytes)
|
|
Character: TUTF8Char;
|
|
|
|
procedure StopKeyEvent(const AnEventName: PChar);
|
|
begin
|
|
{$IFDEF VerboseKeyboard}
|
|
DebugLn('StopKeyEvent AnEventName="',AnEventName,'" BeforeEvent=',dbgs(BeforeEvent));
|
|
{$ENDIF}
|
|
if not EventStopped
|
|
then begin
|
|
g_signal_stop_emission_by_name(PGtkObject(Widget), AnEventName);
|
|
EventStopped := True;
|
|
end;
|
|
|
|
//MWE: still need to skip on win32 ?
|
|
{MWE:.$IfNDef Win32}
|
|
if EventString <> nil
|
|
then begin
|
|
gdk_event_key_set_string(Event,#0);
|
|
Event^.length:=0;
|
|
end;
|
|
{MWE:.$EndIf}
|
|
|
|
Event^.KeyVal := 0;
|
|
end;
|
|
|
|
function CanSendChar: Boolean;
|
|
begin
|
|
Result := False;
|
|
if Event^.Length > 1 then Exit;
|
|
|
|
// to be delphi compatible we should not send a space here
|
|
if Event^.KeyVal = GDK_KEY_KP_SPACE then Exit;
|
|
|
|
// Check if CTRL is pressed
|
|
if ((Event^.State and GDK_CONTROL_MASK) <> 0)
|
|
then begin
|
|
// Check if we pressed ^@
|
|
if (Event^.Length = 0)
|
|
and (Event^.KeyVal = GDK_KEY_AT)
|
|
then begin
|
|
Result := True;
|
|
Exit;
|
|
end;
|
|
// check if we send the ^Char subset
|
|
if (Event^.Length = 1) and (EventString <> nil)
|
|
then begin
|
|
Result := (EventString^ > #0) and (EventString^ < ' ');
|
|
end;
|
|
Exit;
|
|
end;
|
|
Result := Event^.KeyVal < $F000;
|
|
end;
|
|
|
|
var
|
|
VKey: TVKeyRecord;
|
|
CommonKeyData: Integer;
|
|
Flags: Integer;
|
|
SysKey: Boolean;
|
|
FocusedWidget: PGtkWidget;
|
|
LCLObject: TObject;
|
|
FocusedWinControl: TWinControl;
|
|
HandledByLCL: Boolean;
|
|
TargetWidget: PGtkWidget;
|
|
TargetData: gPointer;
|
|
KeyPressesChar: char;
|
|
begin
|
|
Result := True;
|
|
EventStopped := False;
|
|
HandledByLCL:=KeyEventWasHandledByLCL(Event,BeforeEvent);
|
|
|
|
{$IFDEF VerboseKeyboard}
|
|
DebugLn('[HandleGTKKeyUpDown] ',TControl(Data).Name,':',TControl(Data).ClassName,
|
|
' ',dbgs(Event^.{$IFDEF GTK1}theType{$ELSE}_Type{$ENDIF}),' Widget=',GetWidgetClassName(Widget),
|
|
' Before=',dbgs(BeforeEvent),' HandledByLCL=',dbgs(HandledByLCL));
|
|
{$ENDIF}
|
|
|
|
// handle every key event only once
|
|
if HandledByLCL then exit;
|
|
|
|
TargetWidget:=Widget;
|
|
TargetData:=Data;
|
|
|
|
// 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(Widget,gtk_window_get_type) then begin
|
|
FocusedWidget:=PGtkWindow(Widget)^.focus_widget;
|
|
if FocusedWidget<>nil then begin
|
|
LCLObject:=GetNearestLCLObject(FocusedWidget);
|
|
if LCLObject is TWinControl then begin
|
|
FocusedWinControl:=TWinControl(LCLObject);
|
|
if FocusedWidget<>Widget then begin
|
|
{$IFDEF VerboseKeyboard}
|
|
DebugLn('[HandleGTKKeyUpDown] REDIRECTING ',
|
|
' FocusedWidget=',GetWidgetClassName(FocusedWidget),
|
|
' Control=',FocusedWinControl.Name,':',FocusedWinControl.ClassName);
|
|
{$ENDIF}
|
|
// redirect key to lcl control
|
|
TargetWidget:=FocusedWidget;
|
|
TargetData:=FocusedWinControl;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
// remember this event
|
|
RememberKeyEventWasHandledByLCL(Event,BeforeEvent);
|
|
|
|
if TargetWidget=nil then exit;
|
|
|
|
gdk_event_key_get_string(Event, EventString);
|
|
FillChar(Msg,SizeOf(Msg),0);
|
|
|
|
VKey := KeySymToVKey(Event^.keyval);
|
|
|
|
Flags := 0;
|
|
if (VKey.Flags and VKEY_FLAG_EXT) <> 0
|
|
then Flags := KF_EXTENDED;
|
|
|
|
SysKey := False;
|
|
if (VKey.Flags and VKEY_FLAG_ALT) = 0
|
|
then begin
|
|
// VKey is without ALT so Alt is syskey
|
|
SysKey := (Event^.State and GDK_MOD1_MASK) <> 0;
|
|
end
|
|
else begin
|
|
// VKey is with ALT so SHIFT Alt is syskey
|
|
SysKey := (Event^.State and (GDK_MOD1_MASK or GDK_SHIFT_MASK))
|
|
= (GDK_MOD1_MASK or GDK_SHIFT_MASK);
|
|
end;
|
|
|
|
if SysKey
|
|
then Flags := Flags or KF_ALTDOWN;
|
|
CommonKeyData := MVKeyInfo[VKey.VKey].KeyCode shl 16; // ScanCode
|
|
|
|
case gdk_event_get_type(Event) of
|
|
GDK_KEY_RELEASE:
|
|
begin
|
|
{$IFDEF VerboseKeyboard}
|
|
DebugLn('[HandleGTKKeyUpDown] GDK_KEY_RELEASE VKey=',dbgs(VKey.VKey));
|
|
{$ENDIF}
|
|
|
|
Msg.CharCode := VKey.VKey;
|
|
if BeforeEvent then begin
|
|
if SysKey
|
|
then Msg.msg := CN_SYSKEYUP
|
|
else Msg.msg := CN_KEYUP;
|
|
end else begin
|
|
if SysKey
|
|
then Msg.msg := LM_SYSKEYUP
|
|
else Msg.msg := LM_KEYUP;
|
|
end;
|
|
|
|
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(Msg.Msg);
|
|
Result := DeliverMessage(TargetData, Msg) = 0;
|
|
|
|
if Msg.CharCode <> VKey.VKey
|
|
then begin
|
|
// key was handled by LCL
|
|
StopKeyEvent('key_release_event');
|
|
end;
|
|
end;
|
|
|
|
GDK_KEY_PRESS:
|
|
begin
|
|
{$IFDEF VerboseKeyboard}
|
|
DebugLn('[HandleGTKKeyUpDown] GDK_KEY_PRESS VKey=',dbgs(VKey.VKey));
|
|
{$ENDIF}
|
|
|
|
Msg.CharCode := VKey.VKey;
|
|
|
|
if BeforeEvent then begin
|
|
if SysKey
|
|
then Msg.msg := CN_SYSKEYDOWN
|
|
else Msg.msg := CN_KEYDOWN;
|
|
end else begin
|
|
if SysKey
|
|
then Msg.msg := LM_SYSKEYDOWN
|
|
else Msg.msg := LM_KEYDOWN;
|
|
end;
|
|
|
|
// todo repeat
|
|
// Flags := Flags or KF_REPEAT;
|
|
|
|
Msg.KeyData := CommonKeyData or (Flags shl 16) or $0001 {TODO: repeatcount};
|
|
|
|
// send the message directly to the LCL
|
|
NotifyApplicationUserInput(Msg.Msg);
|
|
Result := DeliverMessage(TargetData, Msg) = 0;
|
|
|
|
if Msg.CharCode <> Vkey.Vkey
|
|
then begin
|
|
// key was changed by LCL
|
|
StopKeyEvent('key_press_event');
|
|
end;
|
|
|
|
if (not EventStopped) and CanSendChar
|
|
then begin
|
|
EventTrace('char', data);
|
|
|
|
KeyPressesChar:=#0;
|
|
if Event^.Length = 1 then begin
|
|
// ASCII key was pressed
|
|
KeyPressesChar := EventString^;
|
|
end else if Event^.KeyVal<128 then begin
|
|
// non ASCII key was pressed
|
|
//{$IFDEF GTK2}
|
|
//Msg.CharCode := gdk_keyval_to_unicode(Event^.KeyVal);
|
|
//{$ELSE}
|
|
KeyPressesChar := chr(byte(Event^.KeyVal));
|
|
//{$ENDIF}
|
|
end;
|
|
//debugln('GDK_KEY_PRESS ',dbgs(ord(KeyPressesChar)),' BeforeEvent=',dbgs(BeforeEvent),' ',DbgSName(TObject(TargetData)));
|
|
|
|
if KeyPressesChar<>#0 then begin
|
|
// ASCII key: send a normal KeyPress Event for Delphi compatibility
|
|
FillChar(Msg,SizeOf(Msg),0);
|
|
|
|
Msg.KeyData := CommonKeyData;
|
|
|
|
if BeforeEvent then begin
|
|
if SysKey
|
|
then Msg.msg := CN_SYSCHAR
|
|
else Msg.msg := CN_CHAR
|
|
end else begin
|
|
if SysKey
|
|
then Msg.msg := LM_SYSCHAR
|
|
else Msg.msg := LM_CHAR;
|
|
end;
|
|
|
|
Msg.Result:=0;
|
|
Msg.CharCode:=ord(KeyPressesChar);
|
|
// send the message directly (not queued) to the LCL
|
|
//debugln('GDK_KEY_PRESS ',DbgSName(TObject(TargetData)),' ',dbgs(Msg.msg));
|
|
Result := DeliverMessage(TargetData, Msg) = 0;
|
|
|
|
if (ord(KeyPressesChar)<>Msg.CharCode)
|
|
then begin
|
|
// key was changed by lcl
|
|
//writeln('HandleGTKKeyUpDown A ',Msg.CharCode,' BeforeEvent=',BeforeEvent);
|
|
if (Msg.CharCode=0) or (Msg.CharCode>=128) then
|
|
// key set to invalid => just stop
|
|
StopKeyEvent('key_press_event')
|
|
else begin
|
|
// try to change the key
|
|
EventString^:=chr(Msg.CharCode);
|
|
EventString[1]:=#0;
|
|
Event^.KeyVal:=Msg.CharCode;
|
|
gdk_event_key_set_string(Event,EventString);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
end;
|
|
|
|
if (not EventStopped) and (not BeforeEvent) then begin
|
|
// send the UTF8 keypress
|
|
// try to get the UTF8 representation of the key
|
|
{$IFDEF GTK1}
|
|
Character:='';
|
|
if (Event^.length>0) and (Event^.length<7) then begin
|
|
SetLength(Character,Event^.length);
|
|
System.Move(Event^.thestring^,Character[1],length(Character));
|
|
end;
|
|
{$ELSE GTK2}
|
|
Character := UnicodeToUTF8(gdk_keyval_to_unicode(Event^.KeyVal));
|
|
{$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
|
|
Result:=TWinControl(LCLObject).IntfUTF8KeyPress(Character,1);
|
|
if Result or (Character='') then
|
|
StopKeyEvent('key_press_event');
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{$IFDEF Gtk1}
|
|
Result:=true;
|
|
{$ELSE}
|
|
Result:=EventStopped;
|
|
{$ENDIF}
|
|
//DebugLn('[HandleGTKKeyUpDown] ',DbgSName(TObject(Data)),' Result=',dbgs(Result));
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Procedure: InitKeyboardTables
|
|
Params: none
|
|
Returns: none
|
|
|
|
Initializes the CharToVK and CKeyToVK tables
|
|
------------------------------------------------------------------------------}
|
|
{$IFDEF UNIX}
|
|
{$DEFINE InitKeyboardTables}
|
|
procedure InitKeyboardTables;
|
|
|
|
procedure FindVKeyInfo(const AKeySym: TKeySym; var AVKey: Byte;
|
|
var AExtended, AHasMultiVK: Boolean);
|
|
var
|
|
ByteKey: Byte;
|
|
begin
|
|
AExtended := False;
|
|
AHasMultiVK := False;
|
|
AVKey := $FF;
|
|
|
|
case AKeySym of
|
|
32..255: begin
|
|
ByteKey:=Byte(AKeySym);
|
|
case Chr(ByteKey) of // Normal ASCII chars
|
|
// only unshifted is needed for first match
|
|
// '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,
|
|
GDK_KEY_KP_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_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
|
|
// I guess it is extended to differentiate between normal Fn
|
|
AExtended := True;
|
|
AVKey := VK_F1 + AKeySym - GDK_KEY_KP_F1;
|
|
end;
|
|
GDK_KEY_KP_Multiply:
|
|
begin
|
|
// Keypad key is not extended
|
|
AVKey := VK_MULTIPLY;
|
|
end;
|
|
GDK_KEY_KP_Add:
|
|
begin
|
|
// Keypad key is not extended
|
|
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
|
|
// Keypad key is not extended
|
|
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_Delete: AVKey := VK_DELETE;
|
|
|
|
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: AVKey := VK_SHIFT;
|
|
GDK_Key_Control_L: AVKey := VK_CONTROL;
|
|
GDK_Key_Control_R: AVKey := VK_CONTROL;
|
|
// 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: AVKey := VK_MENU;
|
|
GDK_Key_Super_L: AVKey := VK_LWIN;
|
|
GDK_Key_Super_R: AVKey := VK_RWIN;
|
|
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;
|
|
|
|
procedure NextFreeVK(var AFreeVK: Byte);
|
|
begin
|
|
case AFreeVK of
|
|
$96: AFreeVK := $E1;
|
|
$E1: AFreeVK := $E3;
|
|
$E4: AFreeVK := $E6;
|
|
$E6: AFreeVK := $E9;
|
|
$F5: begin
|
|
DebugLn('[WARNING] Out of OEM specific VK codes, changing to unassigned');
|
|
AFreeVK := $88;
|
|
end;
|
|
$8F: AFreeVK := $97;
|
|
$9F: AFreeVK := $D8;
|
|
$DA: AFreeVK := $E5;
|
|
$E5: AFreeVK := $E8;
|
|
$E8: begin
|
|
DebugLn('[WARNING] Out of unassigned VK codes, assigning $FF');
|
|
AFreeVK := $FF;
|
|
end;
|
|
$FF: AFreeVK := $FF; // stay there
|
|
else
|
|
Inc(AFreeVK);
|
|
end;
|
|
end;
|
|
|
|
const
|
|
KEYFLAGS: array[0..3] of Byte = (
|
|
$00,
|
|
VKEY_FLAG_SHIFT,
|
|
VKEY_FLAG_ALT,
|
|
VKEY_FLAG_SHIFT or VKEY_FLAG_ALT
|
|
);
|
|
EXTFLAG: array[Boolean] of Byte = (
|
|
$00,
|
|
VKEY_FLAG_EXT
|
|
);
|
|
MULTIFLAG: array[Boolean] of Byte = (
|
|
$00,
|
|
VKEY_FLAG_MULTI_VK
|
|
);
|
|
XEVENTSTATE: array[0..3] of DWord = (
|
|
0,
|
|
GDK_SHIFT_MASK,
|
|
GDK_MOD1_MASK,
|
|
GDK_MOD1_MASK or GDK_SHIFT_MASK
|
|
);
|
|
|
|
var
|
|
Display: Pointer;
|
|
ByteKey: Byte;
|
|
n, m: Integer;
|
|
LoKey, HiKey: Integer;
|
|
KeySym: array[0..3] of TKeySym;
|
|
VKey, FreeVK, Flags, idx: Byte;
|
|
HasMultiVK, DoMultiVK, Extended, HasKey, ComputeVK, WarningShown: Boolean;
|
|
K: PVKeyArray1;
|
|
KeySymChars: array[0..16] of Char;
|
|
KeySymCharLen: Integer;
|
|
XKeyEvent: TXKeyEvent;
|
|
begin
|
|
Display := X11Display;
|
|
if Display = nil then Exit;
|
|
|
|
// Init dummy XEvent to retrieve the char corresponding to a key
|
|
FillChar(XKeyEvent, SizeOf(XKeyEvent), 0);
|
|
XKeyEvent._Type := GDK_KEY_PRESS;
|
|
XKeyEvent.Display := Display;
|
|
XKeyEvent.Same_Screen := True;
|
|
|
|
// Retrieve the KeyCode bounds
|
|
XDisplayKeyCodes(Display, @LoKey, @HiKey);
|
|
|
|
Assert((LoKey >= 0) and (HiKey <= 255)); // perdef
|
|
FreeVK := $92; // first OEM specific VK
|
|
WarningShown := False;
|
|
for n := LoKey to HiKey do
|
|
begin
|
|
VKey := $FF;
|
|
HasKey := False;
|
|
for m := 0 to 3 do
|
|
begin
|
|
ByteKey:=Byte(n);
|
|
KeySym[m] := XKeyCodeToKeysym(Display, ByteKey, m);
|
|
if (VKey = $FF) and (KeySym[m] <> 0)
|
|
then begin
|
|
HasKey := True;
|
|
FindVKeyInfo(KeySym[m], VKey, Extended, HasMultiVK);
|
|
end;
|
|
end;
|
|
// Continue if there is no keysym found
|
|
if not HasKey then Continue;
|
|
|
|
ComputeVK := VKey = $FF;
|
|
if ComputeVK
|
|
then begin
|
|
VKey := FreeVK;
|
|
NextFreeVK(FreeVK);
|
|
end;
|
|
|
|
// The keypadkeys have 2 VK_keycodes :(
|
|
// In that case we have to FIndKeyInfo for every keysym
|
|
DoMultiVK := HasMultiVK;
|
|
|
|
for m := 0 to 3 do
|
|
begin
|
|
if KeySym[m] = 0 then Continue;
|
|
if (m > 1) and (KeySym[m] = KeySym[m - 2]) then Continue;
|
|
|
|
if DoMultiVK
|
|
then FindVKeyInfo(KeySym[m], VKey, Extended, HasMultiVK);
|
|
|
|
if VKey = $FF
|
|
then Flags := $FF
|
|
else begin
|
|
Flags := KEYFLAGS[m] or EXTFLAG[Extended] or MULTIFLAG[DoMultiVK];
|
|
MVKeyInfo[VKey].KeySym[m] := KeySym[m];
|
|
end;
|
|
|
|
K := KeySymToVKeyArray(KeySym[m], True);
|
|
idx := KeySym[m] and $FF;
|
|
|
|
// some X servers define separate keycodes for "dead-key" chars.
|
|
// So we might have already a VK assigned
|
|
if K^[idx].VKey <> 0
|
|
then begin
|
|
// VK assigned
|
|
// if the current VK is computed then return it to the pool
|
|
// else use the new VK. If the assigned VK was computed, bad luck.
|
|
// Some day we might this do smarter, but since those extra keys
|
|
// are at the end, we probably wont hit the situation.
|
|
if ComputeVK
|
|
then begin
|
|
FreeVK := VKey;
|
|
VKey := K^[idx].VKey;
|
|
Flags := K^[idx].Flags;
|
|
end;
|
|
end;
|
|
K^[idx].VKey := VKey;
|
|
K^[idx].Flags := Flags;
|
|
|
|
// Retrieve the chars for this KeySym
|
|
XKeyEvent.KeyCode := n;
|
|
XKeyEvent.State := XEVENTSTATE[m];
|
|
KeySymCharLen := XLookupString(@XKeyEvent, KeySymChars, SizeOf(KeySymChars) - 1, nil, nil);
|
|
if (KeySymCharLen > 0) and (KeySymChars[KeySymCharLen - 1] = #0)
|
|
then Dec(KeySymCharLen)
|
|
else KeySymChars[KeySymCharLen] := #0;
|
|
if (KeySymCharLen <= 0) then Continue;
|
|
|
|
// Warn if the KeySymChar is longer than 1.
|
|
if KeySymCharLen > 1
|
|
then begin
|
|
if not WarningShown
|
|
then begin
|
|
WarningShown := True;
|
|
DebugLn('[WARNING] *******************************************************');
|
|
DebugLn('[WARNING] ** **');
|
|
DebugLn('[WARNING] ** Multibyte character encodings (like UTF8) are not **');
|
|
DebugLn('[WARNING] ** supported at the moment. **');
|
|
DebugLn('[WARNING] ** For full keyboard event support, make sure that **');
|
|
DebugLn('[WARNING] ** the LANG environment var has no UTF8 **');
|
|
DebugLn('[WARNING] ** **');
|
|
DebugLn('[WARNING] *******************************************************');
|
|
end;
|
|
Continue;
|
|
end;
|
|
|
|
// If we are here length(KeySymChars) = 1
|
|
|
|
MCharToVK[KeySymChars[0]].VKey := VKey;
|
|
MCharToVK[KeySymChars[0]].Flags := Flags;
|
|
|
|
if VKey <> $FF
|
|
then MVKeyInfo[VKey].KeyChar[m] := KeySymChars[0];
|
|
end;
|
|
MKeyCodeToVK[n] := VKey;
|
|
if VKey <> $FF
|
|
then MVKeyInfo[VKey].KeyCode := Byte(n);
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
{$IFDEF WIN32}
|
|
{$DEFINE InitKeyboardTables}
|
|
procedure InitKeyboardTables;
|
|
var
|
|
n: Integer;
|
|
VK: Byte;
|
|
begin
|
|
for n := 0 to 255 do
|
|
begin
|
|
MCharToVK[Chr(n)] := Windows.VkKeyScan(Chr(n));
|
|
VK := MapVirtualKey(n, 3);
|
|
MKeyCodeToVK[n] := VK;
|
|
MVKToKeyCode[VK] := n;
|
|
end
|
|
end;
|
|
{$ENDIF}
|
|
|
|
{$IFNDEF InitKeyboardTables}
|
|
procedure InitKeyboardTables;
|
|
begin
|
|
DebugLn('[WARNING] Keyboardtables not initialized (platform not supported)');
|
|
end;
|
|
{$ENDIF}
|
|
|
|
{------------------------------------------------------------------------------
|
|
Procedure: DoneKeyboardTables
|
|
Params: none
|
|
Returns: none
|
|
|
|
Frees the dynamic keyboard tables
|
|
------------------------------------------------------------------------------}
|
|
procedure DoneKeyboardTables;
|
|
var
|
|
n1, n2, n3: Byte;
|
|
K1: PVKeyArray1;
|
|
K2: PVKeyArray2;
|
|
K3: PVKeyArray3;
|
|
i: Integer;
|
|
begin
|
|
for n3 := 0 to 255 do
|
|
begin
|
|
K3 := MKeySymToVK[n3];
|
|
if K3 = nil then Continue;
|
|
for n2 := 0 to 255 do
|
|
begin
|
|
K2 := K3^[n2];
|
|
if K2 = nil then Continue;
|
|
for n1 := 0 to 255 do
|
|
begin
|
|
K1 := K2^[n1];
|
|
if K1 = nil then Continue;
|
|
Dispose(K1);
|
|
end;
|
|
Dispose(K2);
|
|
end;
|
|
Dispose(K3);
|
|
end;
|
|
|
|
if LCLHandledKeyEvents<>nil then begin
|
|
for i:=0 to LCLHandledKeyEvents.Count-1 do
|
|
TObject(LCLHandledKeyEvents[i]).Free;
|
|
LCLHandledKeyEvents.Free;
|
|
LCLHandledKeyEvents:=nil;
|
|
for i:=0 to LCLHandledKeyAfterEvents.Count-1 do
|
|
TObject(LCLHandledKeyAfterEvents[i]).Free;
|
|
LCLHandledKeyAfterEvents.Free;
|
|
LCLHandledKeyAfterEvents:=nil;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Function: CharToVKandFlags
|
|
Params: AChar: A character to translate
|
|
Returns: LoByte: The VK code
|
|
HiByte: The A|C|S conbination the get this key
|
|
|
|
------------------------------------------------------------------------------}
|
|
function CharToVKandFlags(const AChar: Char): Word;
|
|
begin
|
|
Result := MCharToVK[AChar].VKey
|
|
or (MCharToVK[AChar].Flags and VKEY_FLAG_KEY_MASK) shl 8;
|
|
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;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Function: IsToggleKey
|
|
Params: AVKey: A Virtual key
|
|
Returns: True if the requeste dkey is a toggle key
|
|
|
|
------------------------------------------------------------------------------}
|
|
function IsToggleKey(const AVKey: Byte): Boolean;
|
|
begin
|
|
Result := AVKey in [VK_CAPITAL, VK_SCROLL, VK_NUMLOCK];
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Procedure: GTKEventState2ShiftState
|
|
Params: KeyState: The gtk keystate
|
|
Returns: the TShiftState for the given KeyState
|
|
|
|
GTKEventState2ShiftState converts a GTK event state to a LCL/Delphi TShiftState
|
|
------------------------------------------------------------------------------}
|
|
function GTKEventState2ShiftState(KeyState: Word): TShiftState;
|
|
begin
|
|
result:=[];
|
|
if (KeyState and GDK_SHIFT_MASK) <> 0 then Result := Result + [ssShift];
|
|
if (KeyState and GDK_LOCK_MASK) <> 0 then Result := Result + [ssCaps];
|
|
if (KeyState and GDK_CONTROL_MASK) <> 0 then Result := Result + [ssCtrl];
|
|
if (KeyState and GDK_MOD1_MASK) <> 0 then Result := Result + [ssAlt];
|
|
//if (KeyState and GDK_MOD2_MASK) <> 0 then Result := Result + [??ssWindows??];
|
|
if (KeyState and GDK_MOD3_MASK) <> 0 then Result := Result + [ssNum];
|
|
if (KeyState and GDK_MOD4_MASK) <> 0 then Result := Result + [ssSuper];
|
|
if (KeyState and GDK_MOD5_MASK) <> 0 then Result := Result + [ssScroll];
|
|
if (KeyState and GDK_BUTTON1_MASK) <> 0 then Result := Result + [ssLeft];
|
|
if (KeyState and GDK_BUTTON2_MASK) <> 0 then Result := Result + [ssMiddle];
|
|
if (KeyState and GDK_BUTTON3_MASK) <> 0 then Result := Result + [ssRight];
|
|
//if (KeyState and GDK_BUTTON4_MASK) <> 0 then Result := Result + [??WheelMouse??];
|
|
//if (KeyState and GDK_BUTTON5_MASK) <> 0 then Result := Result + [??WheelMouse??];
|
|
if (KeyState and GDK_RELEASE_MASK) <> 0 then Result := Result + [ssAltGr];
|
|
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: TList; // list of TFileSelHistoryListEntry
|
|
FilterList: TList; // list of TFileSelFilterListEntry
|
|
AHistoryEntry: PFileSelHistoryEntry;
|
|
AFilterEntry: PFileSelFilterEntry;
|
|
i: integer;
|
|
FileSelWidget: PGtkFileSelection;
|
|
LCLFilterMenu, LCLHistoryMenu: PGTKWidget;
|
|
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
|
|
|
|
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);
|
|
LCLHistoryMenu:=PGTKWidget(gtk_object_get_data(PGtkObject(FileSelWidget),
|
|
'LCLHistoryMenu'));
|
|
if LCLHistoryMenu<>nil then FreeWidgetInfo(LCLHistoryMenu);
|
|
|
|
// free history
|
|
HistoryList:=TList(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;
|
|
|
|
// free filter
|
|
FilterList:=TList(gtk_object_get_data(PGtkObject(DlgWindow),
|
|
'LCLFilterList'));
|
|
if FilterList<>nil then begin
|
|
for i:=0 to FilterList.Count-1 do begin
|
|
AFilterEntry:=PFileSelFilterEntry(FilterList[i]);
|
|
StrDispose(AFilterEntry^.Description);
|
|
AFilterEntry^.Description:=nil;
|
|
StrDispose(AFilterEntry^.Mask);
|
|
AFilterEntry^.Mask:=nil;
|
|
Dispose(AFilterEntry);
|
|
end;
|
|
FilterList.Free;
|
|
gtk_object_set_data(PGtkObject(DlgWindow),'LCLFilterList',nil);
|
|
end;
|
|
|
|
// free preview handle
|
|
if ADialog is TPreviewFileDialog then begin
|
|
if TPreviewFileDialog(ADialog).PreviewFileControl<>nil then
|
|
TPreviewFileDialog(ADialog).PreviewFileControl.Handle:=0;
|
|
end;
|
|
end;
|
|
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): Integer;
|
|
begin
|
|
if Target=nil then DebugLn('[DeliverMessage] Target = nil');
|
|
{$IFDEF VerboseDeliverMessage}
|
|
DebugLn('DeliverMessage ',HexStr(Cardinal(Target),8),
|
|
' ',TComponent(Target).Name,':',TObject(Target).ClassName,
|
|
' Message=',GetMessageName(TLMessage(AMessage).Msg));
|
|
{$ENDIF}
|
|
if (TLMessage(AMessage).Msg=LM_PAINT)
|
|
or (TLMessage(AMessage).Msg=LM_INTERNALPAINT)
|
|
or (TLMessage(AMessage).Msg=LM_GtkPaint) then
|
|
CurrentSentPaintMessageTarget:=TObject(Target);
|
|
try
|
|
if TObject(Target) is TControl
|
|
then TControl(Target).WindowProc(TLMessage(AMessage))
|
|
else TObject(Target).Dispatch(TLMessage(AMessage));
|
|
except
|
|
Application.HandleException(nil);
|
|
end;
|
|
|
|
Result := TLMessage(AMessage).Result;
|
|
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
|
|
Assert(False, 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');
|
|
|
|
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;
|
|
//TODO: remove old compatebility
|
|
gtk_object_set_data(Widget, 'Class', Pointer(AnObject));
|
|
end;
|
|
|
|
//TODO: cleanup when WidgetInfo is fully implemented
|
|
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;
|
|
|
|
// Fallback;
|
|
if Result = nil
|
|
then Result := TObject(gtk_object_get_data(Widget, 'Class'));
|
|
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;
|
|
|
|
{------------------------------------------------------------------------------
|
|
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
|
|
// parent is layout
|
|
gtk_Layout_move(PGtkLayout(Parent), Child, Left, Top)
|
|
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
|
|
// parent is invalid
|
|
DebugLn('[FixedMoveControl] WARNING: Invalid Fixed Widget');
|
|
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=',HexStr(Cardinal(Parent),8),
|
|
' Child=',HexStr(Cardinal(Child),8)
|
|
);
|
|
end;
|
|
|
|
begin
|
|
//DebugLn('FixedPutControl Parent=[',GetWidgetDebugReport(Parent),']',
|
|
// ' Child=[',GetWidgetDebugReport(Child),']');
|
|
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;
|
|
|
|
{------------------------------------------------------------------------------
|
|
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
|
|
RaiseException('MoveGListLinkBehind Item not found');
|
|
if (After<>nil) and (g_list_position(First,After)<0) then
|
|
RaiseException('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;
|
|
end else
|
|
RaiseException('GetControlWindow Widget=nil');
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function GetDCOffset(DC: TDeviceContext): TPoint;
|
|
|
|
Returns the DC offset for the DC Origin.
|
|
------------------------------------------------------------------------------}
|
|
function GetDCOffset(DC: TDeviceContext): TPoint;
|
|
var
|
|
Fixed : PGTKWIdget;
|
|
Adjustment: PGtkAdjustment;
|
|
begin
|
|
if (DC<>nil) then begin
|
|
Result:=DC.Origin;
|
|
{$Ifdef GTK2}
|
|
if (DC.Wnd<>0) and GTK_WIDGET_NO_WINDOW(PGTKWidget(DC.Wnd))
|
|
and (not GtkWidgetIsA(PGTKWidget(DC.Wnd),GTKAPIWidget_GetType))
|
|
then begin
|
|
Inc(Result.X, PGTKWidget(DC.Wnd)^.Allocation.x);
|
|
Inc(Result.y, PGTKWidget(DC.Wnd)^.Allocation.y);
|
|
end;
|
|
{$EndIf}
|
|
if (DC.SpecialOrigin) and (DC.Wnd<>0) then begin
|
|
Fixed := GetFixedWidget(PGTKWidget(DC.Wnd));
|
|
if GtkWidgetIsA(Fixed,GTK_LAYOUT_GET_TYPE) then begin
|
|
Adjustment:=gtk_layout_get_hadjustment(PGtkLayout(Fixed));
|
|
if Adjustment<>nil then
|
|
dec(Result.X,TruncToInt(Adjustment^.Value-Adjustment^.Lower));
|
|
Adjustment:=gtk_layout_get_vadjustment(PGtkLayout(Fixed));
|
|
if Adjustment<>nil then
|
|
dec(Result.Y,TruncToInt(Adjustment^.Value-Adjustment^.Lower));
|
|
end;
|
|
end;
|
|
end else begin
|
|
Result.X:=0;
|
|
Result.Y:=0;
|
|
end;
|
|
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);
|
|
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 := Integer(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);
|
|
if MainWidget = nil then MainWidget := 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;
|
|
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;
|
|
end;
|
|
gtk_object_set_data(AWidget,'widgetinfo',nil);
|
|
|
|
Dispose(Info);
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
procedure DestroyWidget(Widget: PGtkWidget);
|
|
|
|
-------------------------------------------------------------------------------}
|
|
procedure DestroyWidget(Widget: PGtkWidget);
|
|
begin
|
|
FreeWidgetInfo(Widget);
|
|
gtk_widget_destroy(Widget);
|
|
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 TCustomNotebook(ANoteBook).HandleAllocated then exit;
|
|
NoteBookWidget:=PGtkNotebook(TCustomNotebook(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;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
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 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;
|
|
var
|
|
ClientWidget: PGtkWidget;
|
|
ClientWindow: PGdkWindow;
|
|
begin
|
|
ClientWidget:=GetFixedWidget(TheWidget);
|
|
if ClientWidget<>TheWidget then begin
|
|
ClientWindow:=GetControlWindow(ClientWidget);
|
|
if ClientWindow<>nil then begin
|
|
BeginGDKErrorTrap;
|
|
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}
|
|
EndGDKErrorTrap;
|
|
exit;
|
|
end;
|
|
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: UpdateMouseCaptureControl
|
|
Params: none
|
|
Returns: none
|
|
|
|
Sets MCaptureControl 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),']',
|
|
' to [',GetWidgetDebugReport(CurMouseCaptureWidget),']');
|
|
{$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(MouseCaptureWidget), LM_CAPTURECHANGED, 0,
|
|
HWnd(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_GetType) 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)
|
|
or (TWinControl(LCLObject) is TToolButton))
|
|
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;
|
|
begin
|
|
{$IFDEF VerboseMouseCapture}
|
|
DebugLn('ReleaseMouseCapture ',ord(MouseCaptureType),' MouseCaptureWidget=[',GetWidgetDebugReport(MouseCaptureWidget),']');
|
|
{$ENDIF}
|
|
if MouseCaptureType=mctGTK then exit;
|
|
OldMouseCaptureWidget:=MouseCaptureWidget;
|
|
MouseCaptureWidget:=nil;
|
|
MouseCaptureType:=mctGTK;
|
|
gtk_grab_remove(OldMouseCaptureWidget);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure: SetCursor
|
|
Params: AWinControl : TWinControl
|
|
Returns: Nothing
|
|
|
|
Sets the cursor for a widget.
|
|
------------------------------------------------------------------------------}
|
|
procedure SetCursor(AWinControl : TWinControl; ACursor: TCursor);
|
|
|
|
procedure DoSetCursor(AWindow: PGdkWindow; Cursor: pGDKCursor);
|
|
begin
|
|
if Cursor <> nil then begin
|
|
gdk_window_set_cursor(AWindow, Cursor);
|
|
end;
|
|
end;
|
|
|
|
procedure SetCursorRecursive(AWindow: PGdkWindow; Cursor: PGdkCursor);
|
|
var
|
|
ChildWindows, ListEntry: PGList;
|
|
begin
|
|
DoSetCursor(AWindow, Cursor);
|
|
|
|
ChildWindows:=gdk_window_get_children(AWindow);
|
|
|
|
ListEntry:=ChildWindows;
|
|
while ListEntry<>nil do begin
|
|
SetCursorRecursive(PGdkWindow(ListEntry^.Data), Cursor);
|
|
ListEntry:=ListEntry^.Next;
|
|
end;
|
|
g_list_free(ChildWindows);
|
|
end;
|
|
|
|
var
|
|
AWidget, FixWidget: PGtkWidget;
|
|
AWindow: PGdkWindow;
|
|
NewCursor: PGdkCursor;
|
|
begin
|
|
if not ((AWinControl is TWinControl) and AWinControl.HandleAllocated)
|
|
then exit;
|
|
|
|
AWidget:= PGtkWidget(AWinControl.Handle);
|
|
|
|
if csDesigning in AWinControl.ComponentState then begin
|
|
|
|
AWindow:=GetControlWindow(AWidget);
|
|
if AWindow = nil then exit;
|
|
if ACursor = crDefault then
|
|
SetCursorRecursive(AWindow, GetGDKMouseCursor(crDefault))
|
|
else begin
|
|
NewCursor:= GetGDKMouseCursor(ACursor);
|
|
if NewCursor <> nil then SetCursorRecursive(AWindow, NewCursor);
|
|
end;
|
|
|
|
end else begin
|
|
|
|
FixWidget:= GetFixedWidget(AWidget);
|
|
AWindow:= GetControlWindow(FixWidget);
|
|
if AWindow = nil then exit;
|
|
|
|
NewCursor:= GetGDKMouseCursor(AWinControl.Cursor);
|
|
if NewCursor <> nil then DoSetCursor(AWindow, NewCursor);
|
|
end;
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
procedure: SignalConnect
|
|
Params: AWidget: PGTKWidget
|
|
ASignal: PChar
|
|
AProc: Pointer
|
|
AInfo: PWidgetInfo
|
|
Returns: Nothing
|
|
|
|
Connects a gtk signal handler.
|
|
This is wrappers 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 wrappers 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 ComparePChar(DesignSignalNames[Result],Name)
|
|
and (DesignSignalAfter[Result]=After) then exit;
|
|
Result:=dstUnknown;
|
|
end;
|
|
|
|
function GetDesignSignalMask(Widget: PGtkWidget): TDesignSignalMask;
|
|
begin
|
|
Result:=TDesignSignalMask(gtk_object_get_data(PGtkObject(Widget),
|
|
'LCLDesignMask'));
|
|
end;
|
|
|
|
procedure SetDesignSignalMask(Widget: PGtkWidget; NewMask: TDesignSignalMask);
|
|
begin
|
|
gtk_object_set_data(PGtkObject(Widget),'LCLDesignMask',Pointer(NewMask));
|
|
end;
|
|
|
|
function GetDesignOnlySignalFlag(Widget: PGtkWidget;
|
|
DesignSignalType: TDesignSignalType): boolean;
|
|
begin
|
|
Result:=(GetDesignSignalMask(Widget)
|
|
and DesignSignalMasks[DesignSignalType])<>0;
|
|
end;
|
|
|
|
procedure ConnectSignal(const AnObject:PGTKObject; const ASignal: PChar;
|
|
const ACallBackProc: Pointer; const ALCLObject: TObject;
|
|
const AReqSignalMask: TGdkEventMask; const ASFlags: TConnectSignalFlags);
|
|
var
|
|
RealizeHandler, Handler: PGTKHandler;
|
|
RealizeID, SignalID: guint;
|
|
WinWidgetInfo: PWinWidgetInfo;
|
|
MainWidget: PGtkWidget;
|
|
OldDesignMask, NewDesignMask: TDesignSignalMask;
|
|
DesignSignalType: TDesignSignalType;
|
|
begin
|
|
if ACallBackProc = nil then exit;
|
|
|
|
// first loop through the handlers to:
|
|
// - check if a handler already exists
|
|
// - Find the realize handler to change data
|
|
Handler := gtk_object_get_data_by_id (AnObject, gtk_handler_quark);
|
|
SignalID := g_signal_lookup(ASignal, GTK_OBJECT_TYPE(AnObject));
|
|
if SignalID<0 then
|
|
RaiseGDBException('ConnectSignal');
|
|
if csfConnectRealize in ASFlags then
|
|
RealizeID := g_signal_lookup('realize', GTK_OBJECT_TYPE(AnObject))
|
|
else
|
|
RealizeID := 0;
|
|
RealizeHandler := nil;
|
|
DesignSignalType:=DesignSignalNameToType(ASignal,csfAfter in ASFlags);
|
|
|
|
while (Handler <> nil) do begin
|
|
with Handler^ do
|
|
begin
|
|
// check if signal is already connected
|
|
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
|
|
Assert(False, Format('Trace:WARNING: [ConnectSignal] %s signal <%s> set twice', [ALCLObject.ClassName, ASignal]));
|
|
// 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;
|
|
|
|
// look for realize handler
|
|
if (csfConnectRealize in ASFlags)
|
|
and (Id > 0)
|
|
and (Signal_ID = RealizeID)
|
|
and (Func = TGTKSignalFunc(@GTKRealizeCB))
|
|
and (func_data = Pointer(ALCLObject))
|
|
and ((flags and bmSignalAfter)=0) // test if not after
|
|
then RealizeHandler := Handler;
|
|
|
|
Handler := Next;
|
|
end;
|
|
end;
|
|
|
|
// if we are here, then no handler was defined yet
|
|
// -> register handler
|
|
//if (Msg=LM_LBUTTONUP) then DebugLn('CONNECT ',ReqSignalMask,' Widget=',HexStr(Cardinal(AnObject),8));
|
|
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)
|
|
and (RealizeHandler = nil) and (RealizeID<>0)
|
|
then begin
|
|
//DebugLn('REALIZE CONNECT Widget=',HexStr(Cardinal(AnObject),8));
|
|
g_signal_connect(AnObject, 'realize',
|
|
TGTKSignalFunc(@GTKRealizeCB), ALCLObject);
|
|
g_signal_connect_after(AnObject, 'realize',
|
|
TGTKSignalFunc(@GTKRealizeAfterCB), ALCLObject);
|
|
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 ',HexStr(Cardinal(TheWidget),8));
|
|
if GtkWidgetIsA(TheWidget,GTK_TYPE_CONTAINER) then begin
|
|
//if AWinControl is TListView then DebugLn('ConnectChilds B ');
|
|
// this is a container widget -> connect all childs
|
|
{$IFDEF Gtk2}
|
|
ChildEntry2:=gtk_container_get_children(PGtkContainer(TheWidget));
|
|
while ChildEntry2<>nil do begin
|
|
if PGtkWidget(ChildEntry2^.Data)<>TheWidget then
|
|
ConnectSignals(PGtkWidget(ChildEntry2^.Data));
|
|
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 ',HexStr(Cardinal(TheWidget),8));
|
|
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 ',HexStr(Cardinal(TheWidget),8));
|
|
// 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=',HexStr(Cardinal(Widget),8),' CreateIfNotExists=',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=',HexStr(Cardinal(AnAccelGroup),8),' IsMenu=',GtkWidgetIsA(Widget,GTK_MENU_TYPE));
|
|
{$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=',HexStr(Cardinal(AccelGroup),8));
|
|
{$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=',HexStr(Cardinal(Result),8));
|
|
{$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;
|
|
Result:=GetAccelKey(Widget);
|
|
if Result=nil then begin
|
|
if Key<>GDK_VOIDSYMBOL then begin
|
|
New(Result);
|
|
FillChar(Result^,SizeOf(Result),0);
|
|
end;
|
|
end else begin
|
|
if Key=GDK_VOIDSYMBOL 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=',HexStr(Cardinal(Widget),8),
|
|
' Key=',Key,' Mods=',HexStr(Cardinal(Mods),8),
|
|
' Signal="',Signal,'" Result=',HexStr(Cardinal(Result),8));
|
|
{$ENDIF}
|
|
gtk_object_set_data(PGtkObject(Widget), 'AccelKey', Result);
|
|
end;
|
|
|
|
procedure ClearAccelKey(Widget: PGtkWidget);
|
|
begin
|
|
SetAccelKey(Widget,GDK_VOIDSYMBOL,0,'');
|
|
end;
|
|
|
|
procedure RealizeAccelerator(Component: TComponent; Widget : PGtkWidget);
|
|
var
|
|
AccelKey: PAcceleratorKey;
|
|
AccelGroup: PGTKAccelGroup;
|
|
begin
|
|
if (Component=nil) or (Widget=nil) then
|
|
RaiseException('RealizeAccelerate: invalid input');
|
|
|
|
// Set the accelerator
|
|
AccelKey:=GetAccelKey(Widget);
|
|
if (AccelKey=nil) or (AccelKey^.Realized) then exit;
|
|
|
|
if AccelKey^.Key<>GDK_VOIDSYMBOL then begin
|
|
AccelGroup:=GetAccelGroupForComponent(Component,true);
|
|
if AccelGroup<>nil then begin
|
|
{$IFDEF VerboseAccelerator}
|
|
DebugLn('RealizeAccelerator Add Accelerator ',
|
|
Component.Name,':',Component.ClassName,
|
|
' Widget=',HexStr(Cardinal(Widget),8),
|
|
' Signal=',AccelKey^.Signal,
|
|
' Key=',AccelKey^.Key,' Mods=',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
|
|
RaiseException('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=',HexStr(Cardinal(Widget),8),
|
|
' Signal=',AccelKey^.Signal,
|
|
' Key=',AccelKey^.Key,' Mods=',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
|
|
RaiseException('Accelerate: invalid input');
|
|
{$IFDEF VerboseAccelerator}
|
|
DebugLn('Accelerate ',Component.Name,':',Component.ClassName,' Key=',Key,' Mods=',HexStr(Cardinal(Mods),8),' 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<>GDK_VOIDSYMBOL) 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;
|
|
begin
|
|
{ Map the shift states }
|
|
GDKModifier:= 0;
|
|
ShortCutToKey(NewShortCut, NewKey, NewModifier);
|
|
if ssShift in NewModifier then GDKModifier:= GDKModifier + GDK_SHIFT_MASK;
|
|
if ssAlt in NewModifier then GDKModifier:= GDKModifier + GDK_MOD1_MASK;
|
|
if ssCtrl in NewModifier then GDKModifier:= GDKModifier + GDK_CONTROL_MASK;
|
|
|
|
// 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;
|
|
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure GetGdkPixmapFromGraphic(LCLGraphic: TGraphic;
|
|
var IconImg, IconMask: PGdkPixmap; var Width, Height: integer);
|
|
|
|
------------------------------------------------------------------------------}
|
|
procedure GetGdkPixmapFromGraphic(LCLGraphic: TGraphic;
|
|
var IconImg, IconMask: PGdkPixmap; var Width, Height: integer);
|
|
var
|
|
GDIObject: PGdiObject;
|
|
begin
|
|
IconImg:=nil;
|
|
IconMask:=nil;
|
|
Width:=0;
|
|
Height:=0;
|
|
if (LCLGraphic=nil) then exit;
|
|
if LCLGraphic is TBitmap then
|
|
GDIObject:=PgdiObject(TBitmap(LCLGraphic).Handle)
|
|
else
|
|
GDIObject:=nil;
|
|
if GDIObject<>nil then begin
|
|
IconImg:=GDIObject^.GDIBitmapObject;
|
|
IconMask:=GDIObject^.GDIBitmapMaskObject;
|
|
if IconImg<>nil then
|
|
gdk_window_get_size(IconImg, @Width, @Height);
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure GetGdkPixmapFromMenuItem(LCLMenuItem: TMenuItem;
|
|
var IconImg, IconMask: PGdkPixmap; var Width, Height: integer);
|
|
------------------------------------------------------------------------------}
|
|
procedure GetGdkPixmapFromMenuItem(LCLMenuItem: TMenuItem;
|
|
var IconImg, IconMask: PGdkPixmap; var Width, Height: integer);
|
|
begin
|
|
IconImg:=nil;
|
|
IconMask:=nil;
|
|
Width:=0;
|
|
Height:=0;
|
|
if LCLMenuItem=nil then exit;
|
|
if LCLMenuItem.HasBitmap then
|
|
GetGdkPixmapFromGraphic(LCLMenuItem.Bitmap,IconImg,IconMask,Width,Height);
|
|
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;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function GetRadioMenuItemGroup(LCLMenuItem: TMenuItem): PGSList;
|
|
|
|
Returns the radio group list with the GroupIndex of the MenuItem
|
|
------------------------------------------------------------------------------}
|
|
function GetRadioMenuItemGroup(LCLMenuItem: TMenuItem): PGSList;
|
|
var
|
|
ParentMenuItem: TMenuItem;
|
|
i: integer;
|
|
begin
|
|
Result:=nil;
|
|
if (LCLMenuItem=nil) or (LCLMenuItem.GroupIndex=0) then exit;
|
|
ParentMenuItem:=LCLMenuItem.Parent;
|
|
if ParentMenuItem=nil then exit;
|
|
for i:=0 to ParentMenuItem.Count-1 do begin
|
|
if ParentMenuItem[i].RadioItem
|
|
and (ParentMenuItem[i].GroupIndex=LCLMenuItem.GroupIndex)
|
|
and (ParentMenuItem[i]<>LCLMenuItem)
|
|
and ParentMenuItem[i].HandleAllocated
|
|
and GtkWidgetIsA(Pointer(ParentMenuItem[i].Handle),
|
|
GTK_TYPE_RADIO_MENU_ITEM) then
|
|
begin
|
|
Result:=gtk_radio_menu_item_group(
|
|
GTK_RADIO_MENU_ITEM(Pointer(ParentMenuItem[i].Handle)));
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function GetRadioMenuItemGroup(MenuItem: PGtkRadioMenuItem): PGSList;
|
|
|
|
Returns the radio group list with the GroupIndex of the MenuItem
|
|
------------------------------------------------------------------------------}
|
|
function GetRadioMenuItemGroup(MenuItem: PGtkRadioMenuItem): PGSList;
|
|
begin
|
|
if MenuItem=nil then
|
|
Result:=nil
|
|
else
|
|
Result:=GetRadioMenuItemGroup(TMenuItem(GetLCLObject(MenuItem)));
|
|
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;
|
|
IconImg, IconMask: PGdkPixmap;
|
|
AWindow: PGdkWindow;
|
|
IconWidth, IconHeight: integer;
|
|
IconSize: TPoint;
|
|
begin
|
|
if (MenuItem=nil) then exit;
|
|
if not (GTK_WIDGET_DRAWABLE (PGtkWidget(MenuItem))) then exit;
|
|
|
|
// get icon
|
|
LCLMenuItem:=TMenuItem(GetLCLObject(MenuItem));
|
|
if not LCLMenuItem.HasIcon then begin
|
|
// call default draw function
|
|
OldCheckMenuItemDrawProc(MenuItem,Area);
|
|
exit;
|
|
end;
|
|
IconSize:=LCLMenuItem.GetIconSize;
|
|
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;
|
|
ALeft := {$Ifdef GTK2}Widget^.Allocation.x + {$EndIf}
|
|
(BorderWidth + gtk_widget_get_xthickness(gtk_widget_get_style(Widget)) + 2)
|
|
+((PGtkMenuItem(MenuItem)^.toggle_size-IconWidth) div 2);
|
|
ATop := {$Ifdef GTK2} Widget^.Allocation.y + {$EndIf}
|
|
(Widget^.Allocation.Height - IconHeight) div 2;
|
|
|
|
// draw icon
|
|
if (LCLMenuItem.HasBitmap) then begin
|
|
GetGdkPixmapFromMenuItem(LCLMenuItem,IconImg,IconMask,IconWidth,IconHeight);
|
|
gdk_gc_set_clip_mask(gtk_widget_get_style(Widget)^.Black_gc, IconMask);
|
|
gdk_gc_set_clip_origin(gtk_widget_get_style(Widget)^.Black_gc,ALeft,ATop);
|
|
gdk_draw_pixmap(AWindow,gtk_widget_get_style(Widget)^.Black_gc,
|
|
IconImg,0,0,ALeft,ATop,-1,-1);
|
|
gdk_gc_set_clip_mask(gtk_widget_get_style(Widget)^.Black_gc, nil);
|
|
end else begin
|
|
DrawImageListIconOnWidget(LCLMenuItem.GetImageList,LCLMenuItem.ImageIndex,
|
|
Widget,false,false,ALeft,ATop);
|
|
end;
|
|
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:=OldCheckMenuItemToggleSize;
|
|
LCLMenuItem:=TMenuItem(GetLCLObject(MenuItem));
|
|
if LCLMenuItem<>nil then begin
|
|
IconSize:=LCLMenuItem.GetIconSize;
|
|
{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;
|
|
//writeln('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}
|
|
//writeln('MenuSizeRequest B ',GetWidgetDebugReport(widget),' ',requisition^.width,',',requisition^.height);
|
|
OldMenuSizeRequestProc(Widget,requisition);
|
|
//writeln('MenuSizeRequest C ',GetWidgetDebugReport(widget),' ',requisition^.width,',',requisition^.height);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure UpdateInnerMenuItem(LCLMenuItem: TMenuItem;
|
|
MenuItemWidget: PGtkWidget);
|
|
|
|
Update the inner widgets of a menuitem widget.
|
|
------------------------------------------------------------------------------}
|
|
procedure UpdateInnerMenuItem(LCLMenuItem: TMenuItem;
|
|
MenuItemWidget: PGtkWidget);
|
|
var
|
|
HBoxWidget: PGtkWidget;
|
|
LabelWidget: PGtkAccelLabel;
|
|
|
|
procedure SetMenuItemLabelText(LCLMenuItem: TMenuItem;
|
|
MenuItemWidget: PGtkWidget);
|
|
var
|
|
ShortCutPos: integer;
|
|
s: string;
|
|
LabelWidget: PGtkLabel;
|
|
begin
|
|
if (MenuItemWidget=nil) or (LCLMenuItem=nil) then exit;
|
|
LabelWidget:=gtk_object_get_data(PGtkObject(MenuItemWidget), 'LCLLabel');
|
|
if LabelWidget=nil then begin
|
|
end;
|
|
//Check for a shortcut key
|
|
s:=LCLMenuItem.Caption;
|
|
ShortCutPos := pos('&', s);
|
|
if ShortCutPos <> 0 then begin
|
|
if (LCLMenuItem.Parent<>nil)
|
|
and (LCLMenuItem.Parent.HandleAllocated)
|
|
and GtkWidgetIsA(PGtkWidget(LCLMenuItem.Parent.Handle),GTK_TYPE_MENU_BAR)
|
|
then begin
|
|
// this is a menu item in the main bar of a form
|
|
// -> accelerator should be Alt+Key
|
|
s[ShortCutPos] := '_';
|
|
Accelerate(LCLMenuItem,MenuItemWidget,
|
|
gtk_label_parse_uline(LabelWidget,PChar(s)),
|
|
GDK_MOD1_MASK,{$Ifdef GTK2}'activate'{$Else}'activate_item'{$EndIF});
|
|
end else begin
|
|
// Because gnome changes menuitem shortcuts via keyboard, we can't
|
|
// set the accelerator.
|
|
// It would be cool, to know if a window manager with the gnome feature
|
|
// is running, but there is probably no reliable code to do that, so we
|
|
// simply delete all ampersands and don't set the letter shortcut.
|
|
DeleteAmpersands(s);
|
|
gtk_label_set_text(LabelWidget,PChar(s));
|
|
{Accelerate(LCLMenuItem,MenuItemWidget,
|
|
gtk_label_parse_uline(LabelWidget,PChar(s)),0,'activate_item');}
|
|
end;
|
|
end
|
|
else begin
|
|
gtk_label_set_text(LabelWidget,PChar(s));
|
|
end;
|
|
end;
|
|
|
|
procedure CreateIcon;
|
|
var
|
|
IconWidth, IconHeight: integer;
|
|
MinHeightWidget: PGtkWidget;
|
|
IconSize: TPoint;
|
|
begin
|
|
// the icon will be painted instead of the toggle
|
|
// of a normal gtkcheckmenuitem
|
|
|
|
// get the icon
|
|
//GetGdkPixmapFromMenuItem(LCLMenuItem,IconImg,IconMask,IconWidth,IconHeight);
|
|
if LCLMenuItem.HasIcon then begin
|
|
IconSize:=LCLMenuItem.GetIconSize;
|
|
IconWidth:=IconSize.X;
|
|
IconHeight:=IconSize.Y;
|
|
// set the toggle width
|
|
GTK_MENU_ITEM(MenuItemWidget)^.toggle_size:=guint16(IconWidth);
|
|
|
|
GTK_MENU_ITEM(MenuItemWidget)^.flag0:=
|
|
PGtkMenuItem(MenuItemWidget)^.flag0 or
|
|
{$IFDEF Gtk2}
|
|
bm_TGtkCheckMenuItem_always_show_toggle;
|
|
{$ELSE}
|
|
bm_show_toggle_indicator;
|
|
{$ENDIF}
|
|
|
|
// set our own draw handler
|
|
if OldCheckMenuItemDrawProc=nil then
|
|
OldCheckMenuItemDrawProc:=
|
|
CHECK_MENU_ITEM_CLASS(MenuItemWidget)^.draw_indicator;
|
|
CHECK_MENU_ITEM_CLASS(MenuItemWidget)^.draw_indicator:=@DrawMenuItemIcon;
|
|
|
|
// 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);
|
|
end else
|
|
MinHeightWidget:=nil;
|
|
gtk_object_set_data(PGtkObject(MenuItemWidget),
|
|
'LCLMinHeight',MinHeightWidget);
|
|
end;
|
|
|
|
procedure CreateLabel;
|
|
begin
|
|
// create a label for the Caption
|
|
LabelWidget:=PGtkAccelLabel(gtk_accel_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='-' then begin
|
|
// a separator is an empty gtkmenuitem
|
|
exit;
|
|
end;
|
|
HBoxWidget:=gtk_hbox_new(false,0);
|
|
gtk_object_set_data(PGtkObject(MenuItemWidget), 'LCLHBox', HBoxWidget);
|
|
CreateIcon;
|
|
CreateLabel;
|
|
gtk_container_add(GTK_CONTAINER(MenuItemWidget),HBoxWidget);
|
|
gtk_widget_show(HBoxWidget);
|
|
end else begin
|
|
// there are already inner widgets
|
|
if LCLMenuItem.Caption='-' 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
|
|
SetMenuItemLabelText(LCLMenuItem,MenuItemWidget);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function CreateMenuItem(LCLMenuItem: TMenuItem): Pointer;
|
|
|
|
Creates a new menuitem widget.
|
|
------------------------------------------------------------------------------}
|
|
function CreateMenuItem(LCLMenuItem: TMenuItem): Pointer;
|
|
var
|
|
MenuItemWidget: PGtkWidget;
|
|
begin
|
|
// create the menuitem widget (normal, check or radio)
|
|
if LCLMenuItem.Caption='-' then
|
|
// create separator
|
|
MenuItemWidget:=gtk_menu_item_new
|
|
else if LCLMenuItem.RadioItem and not LCLMenuItem.HasIcon then begin
|
|
MenuItemWidget:=gtk_radio_menu_item_new(nil);
|
|
end else if LCLMenuItem.IsCheckItem or LCLMenuItem.HasIcon then begin
|
|
MenuItemWidget:=gtk_check_menu_item_new;
|
|
end else
|
|
MenuItemWidget:=gtk_menu_item_new;
|
|
|
|
if GtkWidgetIsA(MenuItemWidget,GTK_TYPE_CHECK_MENU_ITEM) then begin
|
|
// set 'ShowAlwaysCheckable'
|
|
gtk_check_menu_item_set_show_toggle(PGtkCheckMenuItem(MenuItemWidget),
|
|
LCLMenuItem.ShowAlwaysCheckable);
|
|
// set 'Checked'
|
|
gtk_check_menu_item_set_active(PGtkCheckMenuItem(MenuItemWidget),
|
|
LCLMenuItem.Checked);
|
|
{$ifdef GTK2}
|
|
if (OldCheckMenuItemToggleSize=0) then begin
|
|
gtk_menu_item_toggle_size_request(GTK_MENU_ITEM(MenuItemWidget), @OldCheckMenuItemToggleSize);
|
|
OldCheckMenuItemToggleSize := GTK_MENU_ITEM(MenuItemWidget)^.toggle_size;
|
|
end;
|
|
{$else}
|
|
if (OldCheckMenuItemToggleSize=0) then
|
|
OldCheckMenuItemToggleSize:=MENU_ITEM_CLASS(MenuItemWidget)^.toggle_size;
|
|
{$endif}
|
|
g_signal_connect_after(PGTKObject(MenuItemWidget), 'toggled',
|
|
TGTKSignalFunc(@GTKCheckMenuToggeledCB), Pointer(LCLMenuItem));
|
|
end;
|
|
|
|
|
|
// set attributes (enabled and rightjustify)
|
|
gtk_widget_set_sensitive(MenuItemWidget,
|
|
LCLMenuItem.Enabled and (LCLMenuItem.Caption<>'-'));
|
|
if LCLMenuItem.RightJustify then
|
|
gtk_menu_item_right_justify(PGtkMenuItem(MenuItemWidget));
|
|
|
|
// create the hbox containing the label and the control
|
|
UpdateInnerMenuItem(LCLMenuItem,MenuItemWidget);
|
|
|
|
gtk_widget_show(MenuItemWidget);
|
|
Result:=MenuItemWidget;
|
|
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=',HexStr(Cardinal(Widget),8));
|
|
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=',HexStr(Cardinal(FixWidget),8),
|
|
// ' MainWIdget=',HexStr(Cardinal(MainWidget),8));
|
|
LCLControl:=TWinControl(GetLCLObject(MainWidget));
|
|
if (LCLControl<>nil) then begin
|
|
if LCLControl is TWinControl then begin
|
|
//DebugLn('SaveClientSizeNotification ',LCLControl.Name,':',LCLControl.ClassName,
|
|
// ' FixWidget=',HexStr(Cardinal(FixWidget),8),
|
|
// ' MainWidget=',HexStr(Cardinal(MainWidget),8));
|
|
end else begin
|
|
DbgOut('ERROR: SaveClientSizeNotification ',
|
|
' LCLControl=',LCLControl.ClassName,
|
|
' FixWidget=',HexStr(Cardinal(FixWidget),8),
|
|
' MainWidget=',HexStr(Cardinal(MainWidget),8));
|
|
RaiseGDBException('SaveClientSizeNotification');
|
|
end;
|
|
end else begin
|
|
DbgOut('ERROR: SaveClientSizeNotification LCLControl=nil',
|
|
' FixWidget=',HexStr(Cardinal(FixWidget),8),
|
|
' MainWIdget=',HexStr(Cardinal(MainWidget),8));
|
|
RaiseGDBException('SaveClientSizeNotification');
|
|
end;
|
|
{$ENDIF}
|
|
if not FFixWidgetsResized.Contains(FixWidget) then
|
|
FFixWidgetsResized.Add(FixWidget);
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
CreateTopologicalSortedWidgets
|
|
Params: HashArray: TDynHashArray of PGtkWidget
|
|
|
|
Creates a topologically sorted TList of PGtkWidget.
|
|
-------------------------------------------------------------------------------}
|
|
function CreateTopologicalSortedWidgets(HashArray: TDynHashArray): TList;
|
|
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
|
|
//DebugLn(' KKK0');
|
|
Result:=TList.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(' KKK1 HashArray.Count=',HashArray.Count);
|
|
while HashItem<>nil do begin
|
|
TopologicalList[i].Widget:=HashItem^.Item;
|
|
//DebugLn(' KKK21 i=',i,' Widget=',HexStr(Cardinal(TopologicalList[i].Widget),8));
|
|
LCLControl:=TControl(GetLCLObject(TopologicalList[i].Widget));
|
|
if (LCLControl=nil) or (not (LCLControl is TControl)) then
|
|
RaiseException('CreateTopologicalSortedWidgets: '
|
|
+'Widget without LCL control');
|
|
Lvl:=GetParentLevel(LCLControl);
|
|
TopologicalList[i].ParentLevel:=Lvl;
|
|
if MaxLevel<Lvl then
|
|
MaxLevel:=Lvl;
|
|
//DebugLn(' KKK2 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(' KKK5 i=',i,' Lvl=',Lvl,' LevelCounts[Lvl]=',LevelCounts[Lvl],
|
|
// ' Widget=',HexStr(Cardinal(TopologicalList[i].Widget),8));
|
|
Result[LevelCounts[Lvl]]:=TopologicalList[i].Widget;
|
|
end;
|
|
|
|
FreeMem(LevelCounts);
|
|
FreeMem(TopologicalList);
|
|
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);
|
|
{ $DEFINE VerboseUpdateSysColorMap}
|
|
{$IFDEF VerboseUpdateSysColorMap}
|
|
function GdkColorAsString(c: TgdkColor): string;
|
|
begin
|
|
Result:='LCL='+HexStr(Cardinal(TGDKColorToTColor(c)),8)
|
|
+' Pixel='+HexStr(Cardinal(c.Pixel),8)
|
|
+' Red='+HexStr(Cardinal(c.Red),8)
|
|
+' Green='+HexStr(Cardinal(c.Green),8)
|
|
+' Blue='+HexStr(Cardinal(c.Blue),8)
|
|
;
|
|
end;
|
|
{$ENDIF}
|
|
var
|
|
MainStyle: PGtkStyle;
|
|
begin
|
|
if Widget=nil 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}
|
|
|
|
{$IFDEF NewSysColors}
|
|
SysColorMap[COLOR_SCROLLBAR] := TGDKColorToTColor(bg[GTK_STATE_ACTIVE]);
|
|
SysColorMap[COLOR_BACKGROUND] := TGDKColorToTColor(bg[GTK_STATE_PRELIGHT]);
|
|
SysColorMap[COLOR_ACTIVECAPTION] := TGDKColorToTColor(text[GTK_STATE_ACTIVE]);
|
|
SysColorMap[COLOR_INACTIVECAPTION] := TGDKColorToTColor(text[GTK_STATE_INSENSITIVE]);
|
|
SysColorMap[COLOR_MENU] := TGDKColorToTColor(bg[GTK_STATE_NORMAL]);
|
|
SysColorMap[COLOR_WINDOW] := TGDKColorToTColor(white);
|
|
SysColorMap[COLOR_WINDOWFRAME] := TGDKColorToTColor(black);
|
|
SysColorMap[COLOR_MENUTEXT] := TGDKColorToTColor(text[GTK_STATE_NORMAL]);
|
|
SysColorMap[COLOR_WINDOWTEXT] := TGDKColorToTColor(text[GTK_STATE_NORMAL]);
|
|
SysColorMap[COLOR_CAPTIONTEXT] := TGDKColorToTColor(text[GTK_STATE_SELECTED]);
|
|
SysColorMap[COLOR_ACTIVEBORDER] := TGDKColorToTColor(bg[GTK_STATE_ACTIVE]);
|
|
SysColorMap[COLOR_INACTIVEBORDER] := TGDKColorToTColor(bg[GTK_STATE_NORMAL]);
|
|
SysColorMap[COLOR_APPWORKSPACE] := TGDKColorToTColor(bg[GTK_STATE_NORMAL]);
|
|
SysColorMap[COLOR_HIGHLIGHT] := TGDKColorToTColor(bg[GTK_STATE_SELECTED]);
|
|
SysColorMap[COLOR_HIGHLIGHTTEXT] := TGDKColorToTColor(text[GTK_STATE_SELECTED]);
|
|
SysColorMap[COLOR_BTNFACE] := TGDKColorToTColor(bg[GTK_STATE_NORMAL]);
|
|
SysColorMap[COLOR_BTNSHADOW] := TGDKColorToTColor(fg[GTK_STATE_INSENSITIVE]);
|
|
SysColorMap[COLOR_GRAYTEXT] := TGDKColorToTColor(text[GTK_STATE_INSENSITIVE]);
|
|
SysColorMap[COLOR_BTNTEXT] := TGDKColorToTColor(text[GTK_STATE_NORMAL]);
|
|
SysColorMap[COLOR_INACTIVECAPTIONTEXT] := TGDKColorToTColor(text[GTK_STATE_INSENSITIVE]);
|
|
SysColorMap[COLOR_BTNHIGHLIGHT] := TGDKColorToTColor(fg[GTK_STATE_SELECTED]);
|
|
SysColorMap[COLOR_3DDKSHADOW] := TGDKColorToTColor(black);
|
|
SysColorMap[COLOR_3DLIGHT] := TGDKColorToTColor(fg[GTK_STATE_SELECTED]);
|
|
SysColorMap[COLOR_INFOTEXT] := TGDKColorToTColor(text[GTK_STATE_NORMAL]);
|
|
SysColorMap[COLOR_INFOBK] := TGDKColorToTColor(bg[GTK_STATE_PRELIGHT]);
|
|
SysColorMap[COLOR_HOTLIGHT] := TGDKColorToTColor(fg[GTK_STATE_NORMAL]);
|
|
SysColorMap[COLOR_GRADIENTACTIVECAPTION] := TGDKColorToTColor(bg[GTK_STATE_NORMAL]);
|
|
SysColorMap[COLOR_GRADIENTINACTIVECAPTION] := TGDKColorToTColor(bg[GTK_STATE_NORMAL]);
|
|
SysColorMap[COLOR_FORM] := TGDKColorToTColor(bg[GTK_STATE_NORMAL]);
|
|
{$ENDIF}
|
|
end;
|
|
(*
|
|
$C0C0C0, {COLOR_SCROLLBAR}
|
|
$808000, {COLOR_BACKGROUND}
|
|
$800000, {COLOR_ACTIVECAPTION}
|
|
$808080, {COLOR_INACTIVECAPTION}
|
|
$C0C0C0, {COLOR_MENU}
|
|
$FFFFFF, {COLOR_WINDOW}
|
|
$000000, {COLOR_WINDOWFRAME}
|
|
$000000, {COLOR_MENUTEXT}
|
|
$000000, {COLOR_WINDOWTEXT}
|
|
$FFFFFF, {COLOR_CAPTIONTEXT}
|
|
$C0C0C0, {COLOR_ACTIVEBORDER}
|
|
$C0C0C0, {COLOR_INACTIVEBORDER}
|
|
$808080, {COLOR_APPWORKSPACE}
|
|
$800000, {COLOR_HIGHLIGHT}
|
|
$FFFFFF, {COLOR_HIGHLIGHTTEXT}
|
|
$D0D0D0, {COLOR_BTNFACE}
|
|
$808080, {COLOR_BTNSHADOW}
|
|
$808080, {COLOR_GRAYTEXT}
|
|
$000000, {COLOR_BTNTEXT}
|
|
$C0C0C0, {COLOR_INACTIVECAPTIONTEXT}
|
|
$F0F0F0, {COLOR_BTNHIGHLIGHT}
|
|
$000000, {COLOR_3DDKSHADOW}
|
|
$C0C0C0, {COLOR_3DLIGHT}
|
|
$000000, {COLOR_INFOTEXT}
|
|
$E1FFFF, {COLOR_INFOBK}
|
|
$000000, {unasigned}
|
|
$000000, {COLOR_HOTLIGHT}
|
|
$000000, {COLOR_GRADIENTACTIVECAPTION}
|
|
$000000 {COLOR_GRADIENTINACTIVECAPTION}
|
|
*)
|
|
|
|
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: 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
|
|
//DebugLn('[WaitForClipboardAnswer] B');
|
|
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
|
|
//DebugLn('[WaitForClipboardAnswer] E Yeah, Response received');
|
|
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.HandleMessage;
|
|
if (ValidDateSelection) or (c^.Stopping) then begin
|
|
{$IFDEF DEBUG_CLIPBOARD}
|
|
DebugLn('[WaitForClipboardAnswer] E Yeah, Response received');
|
|
{$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: cardinal): TGtkSelectionData;
|
|
var
|
|
TimeID: cardinal;
|
|
i: integer;
|
|
c: PClipboardEventData;
|
|
begin
|
|
{$IFDEF DEBUG_CLIPBOARD}
|
|
DebugLn('[RequestSelectionData] FormatID=',FormatID);
|
|
{$ENDIF}
|
|
FillChar(Result,SizeOf(TGtkSelectionData),0);
|
|
if (ClipboardWidget=nil) or (FormatID=0)
|
|
or (ClipboardTypeAtoms[ClipboardType]=0) then exit;
|
|
|
|
TimeID:=1000;
|
|
repeat
|
|
repeat
|
|
inc(TimeID);
|
|
if TimeID>1100 then exit;
|
|
i:=ClipboardSelectionData.Count-1;
|
|
while (i>=0)
|
|
and (PClipboardEventData(ClipboardSelectionData[i])^.TimeID<>TimeID) do
|
|
dec(i);
|
|
until (i<0);
|
|
New(c);
|
|
c^.TimeID:=TimeID;
|
|
FillChar(c^.Data,SizeOf(TGtkSelectionData),0);
|
|
ClipboardSelectionData.Add(c);
|
|
{$IFDEF DEBUG_CLIPBOARD}
|
|
DebugLn('[RequestSelectionData] TimeID=',TimeID);
|
|
{$ENDIF}
|
|
if gtk_selection_convert(ClipboardWidget, ClipboardTypeAtoms[ClipboardType],
|
|
FormatID, TimeID)<>GdkFalse
|
|
then
|
|
break;
|
|
ClipboardSelectionData.Remove(c);
|
|
Dispose(c);
|
|
until false;
|
|
try
|
|
if not WaitForClipboardAnswer(c) then exit;
|
|
Result:=c^.Data;
|
|
finally
|
|
ClipboardSelectionData.Remove(c);
|
|
Dispose(c);
|
|
end;
|
|
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 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): Pointer;
|
|
var
|
|
ScrolledWidget, ClientAreaWidget: PGtkWidget;
|
|
WindowStyle: PGtkStyle;
|
|
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);
|
|
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 AnsiCompareText(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.
|
|
------------------------------------------------------------------------------}
|
|
Type
|
|
PStyleObject = ^TStyleObject;
|
|
TStyleObject = Record
|
|
Style : PGTKStyle;
|
|
Widget : PGTKWidget;
|
|
end;
|
|
|
|
var
|
|
StandardStyles: array[TLazGtkStyle] of PStyleObject;
|
|
|
|
Function NewStyleObject : PStyleObject;
|
|
begin
|
|
New(Result);
|
|
Result^.Widget := nil;
|
|
Result^.Style := nil;
|
|
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^.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;
|
|
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
|
|
RaiseException('');// 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
|
|
RaiseException('');// 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;
|
|
|
|
{------------------------------------------------------------------------------
|
|
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;
|
|
|
|
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 := gtk_fixed_new;
|
|
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,200,200);
|
|
end;
|
|
|
|
var
|
|
Tp : Pointer;
|
|
l : Longint;
|
|
StyleObject : PStyleObject;
|
|
NoName: PGChar;
|
|
lgs: TLazGtkStyle;
|
|
WidgetName: String;
|
|
//VBox: PGtkWidget;
|
|
AddToStyleWindow: Boolean;
|
|
StyleWindowWidget: PGtkWidget;
|
|
Requisition: TGtkRequisition;
|
|
WindowFixedWidget: 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;
|
|
// create a style widget
|
|
If AnsiCompareText(WName,LazGtkStyleNames[lgsButton])=0 then begin
|
|
StyleObject^.Widget := GTK_BUTTON_NEW;
|
|
lgs:=lgsButton;
|
|
end
|
|
else
|
|
If AnsiCompareText(WName,LazGtkStyleNames[lgsLabel])=0 then begin
|
|
StyleObject^.Widget := GTK_LABEL_NEW('StyleLabel');
|
|
lgs:=lgsLabel;
|
|
end
|
|
else
|
|
If AnsiCompareText(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 AnsiCompareText(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);
|
|
//gtk_widget_show(VBox);
|
|
//gtk_container_add(PGtkContainer(StyleObject^.Widget), VBox);
|
|
//gtk_object_set_data(PGtkObject(StyleObject^.Widget),'vbox',VBox);
|
|
WindowFixedWidget:=gtk_fixed_new;
|
|
gtk_widget_show(WindowFixedWidget);
|
|
gtk_container_add(PGtkContainer(StyleObject^.Widget), WindowFixedWidget);
|
|
gtk_object_set_data(PGtkObject(StyleObject^.Widget),'fixedwidget',WindowFixedWidget);
|
|
gtk_widget_realize(StyleObject^.Widget);
|
|
end
|
|
else
|
|
If AnsiCompareText(WName,LazGtkStyleNames[lgsCheckbox])=0 then begin
|
|
lgs:=lgsCheckbox;
|
|
StyleObject^.Widget := GTK_CHECK_BUTTON_NEW;
|
|
end
|
|
else
|
|
If AnsiCompareText(WName,LazGtkStyleNames[lgsRadiobutton])=0 then begin
|
|
lgs:=lgsRadiobutton;
|
|
StyleObject^.Widget := GTK_RADIO_BUTTON_NEW(nil);
|
|
end
|
|
else
|
|
If AnsiCompareText(WName,LazGtkStyleNames[lgsMenu])=0 then begin
|
|
lgs:=lgsMenu;
|
|
AddToStyleWindow:=false;
|
|
StyleObject^.Widget := GTK_MENU_NEW;
|
|
end
|
|
else
|
|
If AnsiCompareText(WName,LazGtkStyleNames[lgsMenuitem])=0 then begin
|
|
lgs:=lgsMenuitem;
|
|
AddToStyleWindow:=false;
|
|
StyleObject^.Widget := GTK_MENU_ITEM_NEW;
|
|
end
|
|
else
|
|
If AnsiCompareText(WName,LazGtkStyleNames[lgsList])=0 then begin
|
|
lgs:=lgsList;
|
|
StyleObject^.Widget := GTK_LIST_NEW;
|
|
end
|
|
else
|
|
If AnsiCompareText(WName,LazGtkStyleNames[lgsVerticalScrollbar])=0 then begin
|
|
lgs:=lgsVerticalScrollbar;
|
|
StyleObject^.Widget := gtk_vscrollbar_new(nil);
|
|
end
|
|
else
|
|
If AnsiCompareText(WName,LazGtkStyleNames[lgsHorizontalScrollbar])=0 then begin
|
|
lgs:=lgsHorizontalScrollbar;
|
|
StyleObject^.Widget := gtk_hscrollbar_new(nil);
|
|
end
|
|
else
|
|
If AnsiCompareText(WName,LazGtkStyleNames[lgsVerticalPaned])=0 then begin
|
|
lgs:=lgsVerticalPaned;
|
|
StyleObject^.Widget := gtk_vpaned_new;
|
|
end
|
|
else
|
|
If AnsiCompareText(WName,LazGtkStyleNames[lgsHorizontalPaned])=0 then begin
|
|
lgs:=lgsHorizontalPaned;
|
|
StyleObject^.Widget := gtk_hpaned_new;
|
|
end
|
|
else
|
|
If AnsiCompareText(WName,LazGtkStyleNames[lgsNotebook])=0 then begin
|
|
lgs:=lgsNotebook;
|
|
StyleObject^.Widget := CreateStyleNotebook;
|
|
end
|
|
else
|
|
If AnsiCompareText(WName,LazGtkStyleNames[lgsTooltip])=0 then begin
|
|
lgs:=lgsTooltip;
|
|
AddToStyleWindow:=false;
|
|
TP := gtk_tooltips_new;
|
|
StyleObject^.Widget := nil;
|
|
GTK_Tooltips_Force_Window(TP);
|
|
gtk_widget_ensure_style(PGTKTooltips(TP)^.Tip_Window);
|
|
StyleObject^.Style:=gtk_widget_get_style(PGTKTooltips(TP)^.Tip_Window);
|
|
end
|
|
else
|
|
If AnsiCompareText(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;
|
|
RaiseException('');
|
|
end;
|
|
|
|
if (lgs<>lgsUserDefined) and (StandardStyles[lgs]<>nil) then begin
|
|
// consistency error
|
|
RaiseException('');
|
|
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);
|
|
StyleWindowWidget:=GetStyleWidget(lgsWindow);
|
|
WindowFixedWidget:=PGTKWidget(
|
|
gtk_object_get_data(PGtkObject(StyleWindowWidget),'fixedwidget'));
|
|
//writeln('AddToStyleWindow A ',GetWidgetDebugReport(StyleObject^.Widget));
|
|
//gtk_box_pack_end(PGTKBox(VBox), WindowFixedWidget, True, True, 0);
|
|
gtk_fixed_put(PGtkFixed(WindowFixedWidget),StyleObject^.Widget,0,0);
|
|
gtk_widget_set_usize(StyleObject^.Widget,200,200);
|
|
end;
|
|
|
|
WidgetName:='LazStyle'+WName;
|
|
gtk_widget_set_name(StyleObject^.Widget,PChar(WidgetName));
|
|
gtk_widget_ensure_style(StyleObject^.Widget);
|
|
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 AnsiCompareText(WName,'button')=0 then begin
|
|
if StyleObject^.Style^.light_gc[GTK_STATE_NORMAL]=nil then begin
|
|
//DebugLn('GetStyleWithName ',WName);
|
|
if not GtkWidgetIsA(StyleObject^.Widget,GTK_WINDOW_GET_TYPE) then begin
|
|
gtk_widget_realize(StyleObject^.Widget);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
// increase refcount of style
|
|
If StyleObject^.Style <> nil then
|
|
If AnsiCompareText(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;
|
|
If (StyleObject^.Widget <> nil)
|
|
and (AnsiCompareText(WName,LazGtkStyleNames[lgsWindow])=0) then
|
|
UpdateSysColorMap(StyleObject^.Widget);
|
|
|
|
// ToDo: create all gc of the style
|
|
//gtk_widget_set_rc_style(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
|
|
RaiseException('');// 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(or Pango Font Description if using PANGO)
|
|
|
|
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.
|
|
------------------------------------------------------------------------------}
|
|
{$Ifdef GTK2}
|
|
function LoadDefaultFontDesc: PPangoFontDescription;
|
|
var
|
|
Style : PGTKStyle;
|
|
begin
|
|
Result := nil;
|
|
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;
|
|
{$Else}
|
|
function LoadDefaultFont: PGDKFont;
|
|
var
|
|
Style : PGTKStyle;
|
|
begin
|
|
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('-*-*-*-*-*-*-*-*-*-*-*-*-*-*');
|
|
|
|
If Result <> nil then
|
|
Result := gdk_font_ref(Result);
|
|
end;
|
|
{$EndIf}
|
|
|
|
function GetDefaultFontName: string;
|
|
var
|
|
Style: PGtkStyle;
|
|
{$IFDEF GTK2}
|
|
PangoFontDesc: PPangoFontDescription;
|
|
{$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 begin
|
|
if (Style^.RC_Style^.font_name <> nil) then
|
|
Result := Style^.RC_Style^.font_name;
|
|
end;
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
{$IFDEF GTK2}
|
|
If (Style <> nil) then begin
|
|
PangoFontDesc := pango_font_description_copy(Style^.font_desc);
|
|
if PangoFontDesc<>nil then begin
|
|
Result:=pango_font_description_get_family(PangoFontDesc);
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
end;
|
|
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,@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
|
|
BaseColor := Color and $FF;
|
|
|
|
{Set defaults in case something goes wrong}
|
|
FillChar(Result, SizeOf(Result), 0);
|
|
Style:=nil;
|
|
GC:=nil;
|
|
Pixmap:=nil;
|
|
|
|
SysColor := ColorToRGB(BaseColor);
|
|
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}
|
|
Case BaseColor of
|
|
{These are WM/X defined, but might be possible to get}
|
|
|
|
{COLOR_BACKGROUND
|
|
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_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;
|
|
Result.foreground := Style^.bg[GTK_STATE_PRELIGHT];
|
|
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
|
|
ThemeWidget:=GetWidgetWithBackgroundWindow(ThemeWidget);
|
|
if ThemeWidget<>nil then begin
|
|
if GtkWidgetIsA(ThemeWidget,GTK_TYPE_LIST_ITEM) then
|
|
Style:=GetStyle(lgsList);
|
|
if Style=nil then
|
|
Style:=PGtkStyle(gtk_widget_get_style(ThemeWidget));
|
|
end;
|
|
if Style=nil then
|
|
Style := GetStyle(lgsDefault);
|
|
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;
|
|
GC := Style^.bg_gc[GTK_STATE_PRELIGHT];
|
|
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
|
|
Style := GetStyle(lgsDefault);
|
|
If Style = nil then
|
|
exit;
|
|
Result := @Style^.bg[GTK_STATE_PRELIGHT];
|
|
end;
|
|
end;
|
|
|
|
If Result = nil then
|
|
Result := DefaultColor;
|
|
|
|
if (Result <> nil) and (Result <> DefaultColor) then
|
|
RealizeGtkStyleColor(Style,Result);
|
|
end;
|
|
|
|
Procedure StyleFillRectangle(drawable : PGDKDrawable; GC : PGDKGC; Color : TColorRef; x, y, width, height : gint);
|
|
var
|
|
style : PGTKStyle;
|
|
widget : PGTKWidget;
|
|
state : TGTKStateType;
|
|
detail : pgchar;
|
|
begin
|
|
style := nil;
|
|
|
|
Case TColor(Color) of
|
|
{ clMenu:
|
|
begin
|
|
Style := GetStyle('menuitem');
|
|
widget := GetStyleWidget('menuitem');
|
|
state := GTK_STATE_NORMAL;
|
|
detail := 'menuitem';
|
|
end;
|
|
|
|
clBtnFace :
|
|
begin
|
|
Style := GetStyle('button');
|
|
widget := GetStyleWidget('button');
|
|
state := GTK_STATE_NORMAL;
|
|
detail := 'button';
|
|
end;
|
|
|
|
clWindow :
|
|
begin
|
|
Style := GetStyle('default');
|
|
widget := GetStyleWidget('default');
|
|
state := GTK_STATE_NORMAL;
|
|
detail := 'list';
|
|
end; }
|
|
|
|
clInfoBk :
|
|
begin
|
|
Style := GetStyle(lgsWindow);
|
|
widget := GetStyleWidget(lgsWindow);
|
|
// Style := GetStyle('tooltip');
|
|
state := GTK_STATE_NORMAL;
|
|
detail := 'tooltip';
|
|
end;
|
|
|
|
clForm :
|
|
begin
|
|
Style := GetStyle(lgsWindow);
|
|
widget := GetStyleWidget(lgsWindow);
|
|
state := GTK_STATE_NORMAL;
|
|
detail := 'window';
|
|
end;
|
|
end;
|
|
|
|
if Assigned(Style) then
|
|
gtk_paint_flat_box(style, drawable, state, GTK_SHADOW_NONE, 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;
|
|
NewColor: TGdkColor;
|
|
MainWidget: PGtkWidget;
|
|
//i: Integer;
|
|
|
|
procedure CreateRCStyle;
|
|
begin
|
|
if RCStyle=nil then
|
|
RCStyle:=gtk_rc_style_new;
|
|
end;
|
|
|
|
begin
|
|
{$IFDEF NoStyle}
|
|
exit;
|
|
{$ENDIF}
|
|
|
|
if not AWinControl.HandleAllocated then exit;
|
|
|
|
MainWidget:=PGtkWidget(AWinControl.Handle);
|
|
FixWidget:=GetFixedWidget(MainWidget);
|
|
If FixWidget <> MainWidget then
|
|
Widget := FixWidget
|
|
else
|
|
Widget := MainWidget;
|
|
|
|
if not GTK_WIDGET_REALIZED(Widget) then exit;
|
|
|
|
RCStyle:=nil;
|
|
try
|
|
// set default background
|
|
if (AWinControl.Color=clNone) then begin
|
|
// clNone => remove default background
|
|
if (FixWidget^.Window<>nil) then begin
|
|
gdk_window_set_back_pixmap(FixWidget^.Window,nil,GdkFalse);
|
|
end;
|
|
end
|
|
else
|
|
if AWinControl.ColorIsStored
|
|
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_GetType) then exit;
|
|
|
|
NewColor:=TColorToTGDKColor(AWinControl.Color);
|
|
|
|
CreateRCStyle;
|
|
RCStyle^.bg[GTK_STATE_NORMAL]:=NewColor;
|
|
|
|
// Indicate which colors the GtkRcStyle will affect;
|
|
// unflagged colors will follow the theme
|
|
RCStyle^.color_flags[GTK_STATE_NORMAL]:=
|
|
RCStyle^.color_flags[GTK_STATE_NORMAL] or GTK_RC_BG;
|
|
|
|
//DebugLn('UpdateWidgetStyleOfControl Color=',HexStr(Cardinal(AWinControl.Color),8));
|
|
|
|
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
|
|
if (AWinControl.Font.Color and SYS_COLOR_BASE)=0 then begin
|
|
NewColor:=TColorToTGDKColor(AWinControl.Font.Color);
|
|
CreateRCStyle;
|
|
|
|
RCStyle^.text[GTK_STATE_NORMAL]:=NewColor;
|
|
|
|
// Indicate which colors the GtkRcStyle will affect;
|
|
// unflagged colors will follow the theme
|
|
RCStyle^.color_flags[GTK_STATE_NORMAL]:=
|
|
RCStyle^.color_flags[GTK_STATE_NORMAL] or GTK_RC_TEXT;
|
|
|
|
//DebugLn('UpdateWidgetStyleOfControl Font=',AWinControl.Font.Name,' ',AWinControl.Font.Size,' ',HexStr(Cardinal(AWinControl.Font.Color),8));
|
|
end;
|
|
|
|
finally
|
|
if RCStyle<>nil then begin
|
|
DebugLn('UpdateWidgetStyleOfControl Apply Modifications ',AWinControl.Name,' ',GetWidgetClassName(Widget));
|
|
gtk_widget_modify_style(Widget,RCStyle);
|
|
gtk_rc_style_unref(RCStyle);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
Function DeleteAmpersands(var Str : String) : Longint;
|
|
// convert double ampersands to single & and delete single &
|
|
// return the position of the letter after the first deleted single ampersand
|
|
// in the new string
|
|
var
|
|
Tmp : String;
|
|
SrcPos, DestPos, SrcLen: integer;
|
|
begin
|
|
Result := -1;
|
|
|
|
// for speedup reasons check if Str must be changed
|
|
SrcLen:=length(Str);
|
|
SrcPos:=SrcLen;
|
|
while (SrcPos>=1) and (Str[SrcPos]<>'&') do dec(SrcPos);
|
|
if SrcPos<1 then exit;
|
|
|
|
// copy Str to Tmp and convert ampersands on the fly
|
|
SetLength(Tmp,SrcLen);
|
|
SrcPos:=1;
|
|
DestPos:=1;
|
|
while (SrcPos<=SrcLen) do begin
|
|
if Str[SrcPos]<>'&' then begin
|
|
// copy normal char
|
|
Tmp[DestPos]:=Str[SrcPos];
|
|
inc(SrcPos);
|
|
inc(DestPos);
|
|
end else begin
|
|
inc(SrcPos);
|
|
if (SrcPos<=SrcLen) and (Str[SrcPos]='&') then begin
|
|
// double ampersand
|
|
Tmp[DestPos]:='&';
|
|
inc(DestPos);
|
|
inc(SrcPos);
|
|
end else begin
|
|
// single ampersand
|
|
if Result<1 then Result:=DestPos;
|
|
end;
|
|
end;
|
|
end;
|
|
SetLength(Tmp,DestPos-1);
|
|
Str:=Tmp;
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
Function Ampersands2Underscore(Src: PChar) : PChar;
|
|
|
|
Creates a new PChar. Deletes escaping ampersands, replaces the first single
|
|
ampersand with an underscore and deleting all other single ampersands.
|
|
-------------------------------------------------------------------------------}
|
|
function Ampersands2Underscore(Src: PChar) : PChar;
|
|
var
|
|
i, j: Longint;
|
|
ShortenChars, FirstAmpersand, NewLength, SrcLength: integer;
|
|
begin
|
|
// count ampersands and find first ampersand
|
|
ShortenChars:= 0; // chars to delete
|
|
FirstAmpersand:= -1;
|
|
SrcLength:= StrLen(Src);
|
|
|
|
{ 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 begin
|
|
// single ampersand found
|
|
if (FirstAmpersand < 0) then
|
|
// the first will be replaced ...
|
|
FirstAmpersand:= i
|
|
else
|
|
// ... and all others will be deleted
|
|
inc(ShortenChars);
|
|
end;
|
|
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 begin
|
|
// single ampersand found
|
|
if i = FirstAmpersand then begin
|
|
// replace first single ampersand with underscore
|
|
Result[j]:='_';
|
|
end else begin
|
|
// delete single ampersand
|
|
dec(j);
|
|
end;
|
|
end;
|
|
end;
|
|
Inc(i);
|
|
Inc(j);
|
|
end;
|
|
Result[NewLength]:=#0;
|
|
end;
|
|
|
|
{-------------------------------------------------------------------------------
|
|
function Ampersands2Underscore(const ASource: String): String;
|
|
|
|
Deletes escaping ampersands, replaces the first single
|
|
ampersand with an underscore and deleting 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 (n < Length(Result))
|
|
and (Result[n + 1] = '&')
|
|
then begin
|
|
// we got a &&, remove the first
|
|
Delete(Result, n, 1);
|
|
Inc(n);
|
|
Continue;
|
|
end;
|
|
if FirstFound
|
|
then begin
|
|
// simply remove it
|
|
Delete(Result, n, 1);
|
|
Continue;
|
|
end;
|
|
// if we are here it's our first
|
|
FirstFound := True;
|
|
Result[n] := '_';
|
|
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
|
|
//TODO: escape underscores
|
|
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);
|
|
Continue;
|
|
end;
|
|
|
|
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;
|
|
'_': begin
|
|
AText[n] := ' ';
|
|
APattern[n] := '_';
|
|
end;
|
|
end;
|
|
Inc(n);
|
|
end;
|
|
end;
|
|
|
|
|
|
{-------------------------------------------------------------------------------
|
|
Function GetTextExtentIgnoringAmpersands(Font : PGDKFont; Str : PChar;
|
|
LineLength : Longint; lbearing, rbearing, width, ascent, descent : Pgint);
|
|
|
|
Gets text extent of a string, ignoring escaped Ampersands.
|
|
-------------------------------------------------------------------------------}
|
|
{$Ifdef GTK2}
|
|
Procedure GetTextExtentIgnoringAmpersands(FontDesc : PPangoFontDescription; Str : PChar;
|
|
LineLength : Longint; lbearing, rbearing, width, ascent, descent : Pgint);
|
|
{$Else}
|
|
Procedure GetTextExtentIgnoringAmpersands(Font : PGDKFont; Str : PChar;
|
|
LineLength : Longint; lbearing, rbearing, width, ascent, descent : Pgint);
|
|
{$EndIf}
|
|
var
|
|
NewStr : PChar;
|
|
i: integer;
|
|
begin
|
|
NewStr:=Str;
|
|
// first check if Str contains an ampersand:
|
|
if (Str<>nil) then begin
|
|
i:=0;
|
|
while (not (Str[i] in [#0,'&'])) do inc(i);
|
|
if Str[i]='&' then begin
|
|
NewStr := RemoveAmpersands(Str, LineLength);
|
|
LineLength:=StrLen(NewStr);
|
|
end;
|
|
end;
|
|
{$Ifdef GTK2}
|
|
gdk_text_extents(FontDesc, NewStr, LineLength,
|
|
lbearing, rBearing, width, ascent, descent);
|
|
{$Else}
|
|
gdk_text_extents(Font, NewStr, LineLength,
|
|
lbearing, rBearing, width, ascent, descent);
|
|
{$EndIf}
|
|
if NewStr<>Str then
|
|
StrDispose(NewStr);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function FontIsDoubleByteCharsFont(TheFont: PGdkFont): boolean;
|
|
|
|
This is only a heuristic
|
|
------------------------------------------------------------------------------}
|
|
function FontIsDoubleByteCharsFont(TheFont: PGdkFont): boolean;
|
|
var
|
|
SingleCharLen, DoubleCharLen: integer;
|
|
begin
|
|
SingleCharLen:=gdk_text_width(TheFont, 'A', 1);
|
|
DoubleCharLen:=gdk_text_width(TheFont, #0'A', 2);
|
|
Result:=(SingleCharLen=0) and (DoubleCharLen>0);
|
|
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
|
|
if not (csDesigning in AForm.ComponentState) then
|
|
ABorderStyle:=AForm.BorderStyle
|
|
else
|
|
ABorderStyle:=bsSizeable;
|
|
|
|
Case ABorderStyle of
|
|
bsNone : Result := 0;
|
|
|
|
bsSingle : Result := GDK_DECOR_BORDER or GDK_DECOR_TITLE or
|
|
GDK_DECOR_MENU or GDK_DECOR_MINIMIZE or
|
|
GDK_DECOR_MAXIMIZE;
|
|
|
|
bsSizeable : Result := GDK_DECOR_ALL;
|
|
|
|
bsDialog : Result := GDK_DECOR_BORDER or GDK_DECOR_TITLE or
|
|
GDK_DECOR_MENU or GDK_DECOR_MINIMIZE;
|
|
|
|
bsToolWindow : Result := GDK_DECOR_BORDER or GDK_DECOR_TITLE or
|
|
GDK_DECOR_MENU or GDK_DECOR_MINIMIZE;
|
|
|
|
bsSizeToolWin :Result := GDK_DECOR_BORDER or GDK_DECOR_TITLE or
|
|
GDK_DECOR_MENU or GDK_DECOR_MINIMIZE;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Function GetWindowFunction(AForm : TCustomForm) : Longint;
|
|
|
|
------------------------------------------------------------------------------}
|
|
Function GetWindowFunction(AForm : TCustomForm) : Longint;
|
|
var
|
|
ABorderStyle: TFormBorderStyle;
|
|
begin
|
|
if not (csDesigning in AForm.ComponentState) then
|
|
ABorderStyle:=AForm.BorderStyle
|
|
else
|
|
ABorderStyle:=bsSizeable;
|
|
|
|
Case ABorderStyle of
|
|
bsNone : Result := GDK_FUNC_MOVE or GDK_FUNC_CLOSE;
|
|
|
|
bsSingle : Result := GDK_FUNC_RESIZE or GDK_FUNC_MOVE or
|
|
GDK_FUNC_MINIMIZE or GDK_FUNC_CLOSE;
|
|
|
|
bsSizeable : Result := GDK_FUNC_ALL;
|
|
|
|
bsDialog : Result := GDK_FUNC_CLOSE or GDK_FUNC_MINIMIZE or
|
|
GDK_FUNC_MOVE;
|
|
|
|
bsToolWindow : Result := GDK_FUNC_RESIZE or GDK_FUNC_MOVE or
|
|
GDK_FUNC_MINIMIZE or GDK_FUNC_CLOSE;
|
|
|
|
bsSizeToolWin : Result := GDK_FUNC_RESIZE or GDK_FUNC_MOVE or
|
|
GDK_FUNC_MINIMIZE or GDK_FUNC_CLOSE or
|
|
GDK_FUNC_RESIZE;
|
|
end;
|
|
end;
|
|
|
|
function GetGDKMouseCursor(Cursor: TCursor): PGdkCursor;
|
|
begin
|
|
if (Cursor<crLow) or (Cursor>crHigh) then
|
|
Cursor:=crDefault;
|
|
if GDKMouseCursors[Cursor]=nil then
|
|
GDKMouseCursors[Cursor]:=gdk_cursor_new(CursorToGDKCursor[Cursor]);
|
|
Result:=GDKMouseCursors[Cursor];
|
|
end;
|
|
|
|
Procedure FreeGDKCursors;
|
|
var
|
|
i: integer;
|
|
begin
|
|
for i:=Low(GDKMouseCursors) to High(GDKMouseCursors) do begin
|
|
if GDKMouseCursors[i]<>nil then begin
|
|
gdk_Cursor_Destroy(GDKMouseCursors[i]);
|
|
GDKMouseCursors[i]:=nil;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
Procedure FillScreenFonts(ScreenFonts : TStrings);
|
|
var
|
|
{$IFDEF GTK1}
|
|
{$IFDEF UNIX}
|
|
theFonts : PPChar;
|
|
{$ENDIF UNIX}
|
|
{$Else}
|
|
Widget : PGTKWidget;
|
|
Context : PPangoContext;
|
|
families : PPPangoFontFamily;
|
|
{$EndIf}
|
|
Tmp: AnsiString;
|
|
I, N: Integer;
|
|
begin
|
|
ScreenFonts.Clear;
|
|
{$IFDEF GTK1}
|
|
{$IFDEF UNIX}
|
|
theFonts := XListFonts(X11Display,PChar('-*-*-*-*-*-*-*-*-*-*-*-*-*-*'), 10000, @N);
|
|
for I := 0 to N - 1 do
|
|
if theFonts[I] <> nil then begin
|
|
Tmp := ExtractFamilyFromXLFDName(AnsiString(theFonts[I]));
|
|
if Tmp <> '' then
|
|
if ScreenFonts.IndexOf(Tmp) < 0 then
|
|
ScreenFonts.Append(Tmp);
|
|
end;
|
|
XFreeFontNames(theFonts);
|
|
{$ENDIF UNIX}
|
|
{$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(TDeviceContext(DC));
|
|
begin
|
|
{$IfDef Win32}
|
|
Result := DCTextMetric.TextMetric.tmHeight div 2;
|
|
{$Else}
|
|
Result := DCTextMetric.TextMetric.tmAscent;
|
|
{$EndIf}
|
|
end;
|
|
|
|
{$IFDEF ASSERT_IS_ON}
|
|
{$UNDEF ASSERT_IS_ON}
|
|
{$C-}
|
|
{$ENDIF}
|
|
|
|
// included by gtkproc.pp
|
|
|
|
{ =============================================================================
|
|
|
|
$Log$
|
|
Revision 1.309 2004/09/17 20:30:13 vincents
|
|
replaced write by DbgOut
|
|
|
|
Revision 1.308 2004/09/17 10:56:25 micha
|
|
convert LM_SHORTCUT message to interface methods
|
|
|
|
Revision 1.307 2004/09/12 19:00:17 mazen
|
|
*Font width is now used with GTK2
|
|
|
|
Revision 1.306 2004/09/11 10:02:38 mattias
|
|
fixed TLazIntfImage.LoadFromDevice
|
|
|
|
Revision 1.305 2004/09/10 16:28:51 mattias
|
|
implemented very rudimentary TTabControl
|
|
|
|
Revision 1.304 2004/09/05 10:39:01 mattias
|
|
fixed gtk1 intf key handler result
|
|
|
|
Revision 1.303 2004/09/04 22:24:16 mattias
|
|
added default values for compiler skip options and improved many parts of synedit for UTF8
|
|
|
|
Revision 1.302 2004/09/02 17:59:59 mattias
|
|
removed double KeyPress method in synedit
|
|
|
|
Revision 1.301 2004/09/02 16:01:24 mazen
|
|
* fix compile probelm using gtk1
|
|
|
|
Revision 1.300 2004/09/02 14:58:14 mazen
|
|
* fixed theType/_Type related to GTK1/GTK2 difference
|
|
* fix return error which causes GTK2 not to call AfterEvent
|
|
* Test on BeforeEvent and EventStopped now exists directly
|
|
in key press, as no more things are done.
|
|
* _string/theString field are depreciated, please don't use
|
|
them with GTK2
|
|
|
|
Revision 1.299 2004/09/02 09:17:00 mattias
|
|
improved double byte char fonts for gtk1, started synedit UTF8 support
|
|
|
|
Revision 1.298 2004/08/30 15:46:22 mazen
|
|
* Fix a compile problem, still need to find the correct way to fix that.
|
|
|
|
Revision 1.297 2004/08/30 10:49:20 mattias
|
|
fixed focus catch for combobox csDropDownList
|
|
|
|
Revision 1.296 2004/08/29 10:13:59 mattias
|
|
fixed makefile
|
|
|
|
Revision 1.295 2004/08/28 10:22:13 mattias
|
|
added hints for long props in OI from Andrew Haines
|
|
|
|
Revision 1.294 2004/08/18 20:49:02 mattias
|
|
simple forms can now be child controls
|
|
|
|
Revision 1.293 2004/08/17 19:01:37 mattias
|
|
gtk intf now ignores size notifications of unrealized widgets
|
|
|
|
Revision 1.292 2004/08/16 16:03:52 mattias
|
|
added UniCode keyvals
|
|
|
|
Revision 1.291 2004/08/12 15:50:46 mazen
|
|
+ add support for passing non ASCII key values
|
|
* need to check for $F000 if it is the correct value
|
|
|
|
Revision 1.290 2004/08/03 09:01:54 mattias
|
|
LCL now handles for non win32 CN_CHAR
|
|
|
|
Revision 1.289 2004/07/30 14:26:11 mazen
|
|
* move HandleGtkKeyUpDown to gtkProc.inc make it visible to gtk2
|
|
this allow saving a call in a hevely called callback
|
|
|
|
Revision 1.288 2004/07/10 18:17:30 mattias
|
|
added Delphi ToDo support, Application.WndProc, small bugfixes from Colin
|
|
|
|
Revision 1.287 2004/07/03 11:11:09 mattias
|
|
TGTKListStringList now keeps selection on Put and Move
|
|
|
|
Revision 1.286 2004/06/28 15:45:48 mattias
|
|
fixed a mem violation in gtk intf paint msg conversion
|
|
|
|
Revision 1.285 2004/06/28 09:48:46 mattias
|
|
added valgrind flag to compiler options
|
|
|
|
Revision 1.284 2004/06/24 17:45:33 mattias
|
|
fixed TMenuItem.GetIconSize
|
|
|
|
Revision 1.283 2004/06/19 21:06:38 mattias
|
|
menu separators are now created disabled
|
|
|
|
Revision 1.282 2004/06/17 21:24:19 mattias
|
|
implemented painting menuitem icons from ImageList
|
|
|
|
Revision 1.281 2004/06/11 12:53:50 vincents
|
|
fixed memleak in WidgetInfo.UserData used by BitBtn
|
|
|
|
Revision 1.280 2004/05/16 23:24:41 marc
|
|
+ Added WSBitBtn interface
|
|
+ Implemented WSBitBtn interface for gtk
|
|
|
|
Revision 1.279 2004/05/14 12:53:25 mattias
|
|
improved grids e.g. OnPrepareCanvas patch from Jesus
|
|
|
|
Revision 1.278 2004/05/11 12:16:47 mattias
|
|
replaced writeln by debugln
|
|
|
|
Revision 1.277 2004/05/11 09:49:47 mattias
|
|
started sending CN_KEYUP
|
|
|
|
Revision 1.276 2004/04/19 09:30:04 marc
|
|
* Fixed compilation for gtk2
|
|
|
|
Revision 1.275 2004/04/11 18:58:26 micha
|
|
fix (lm_)setcursor changes for gtk target
|
|
|
|
Revision 1.274 2004/04/08 18:27:51 mattias
|
|
fixed memleak in TDefaultComponentEditor.Edit
|
|
|
|
Revision 1.273 2004/04/03 18:08:40 mattias
|
|
fixed TLabel.AutoWrap=true and label on formless parent in gtk intf
|
|
|
|
Revision 1.272 2004/03/28 12:49:23 mattias
|
|
implemented mask merge and extraction for raw images
|
|
|
|
Revision 1.271 2004/03/24 01:21:41 marc
|
|
* Simplified signals for gtkwsbutton
|
|
|
|
Revision 1.270 2004/03/22 19:10:04 mattias
|
|
implemented icons for TPage in gtk, mask for TCustomImageList
|
|
|
|
Revision 1.269 2004/03/18 00:55:56 mattias
|
|
fixed memleak in gtk opendlg
|
|
|
|
Revision 1.268 2004/03/09 15:30:15 peter
|
|
* fixed gtk2 compilation
|
|
|
|
Revision 1.267 2004/03/06 17:12:19 mattias
|
|
fixed CreateBrushIndirect
|
|
|
|
Revision 1.266 2004/03/06 15:37:43 mattias
|
|
fixed FreeDC
|
|
|
|
Revision 1.265 2004/03/05 00:31:52 marc
|
|
* Renamed TGtkObject to TGtkWidgetSet
|
|
|
|
Revision 1.264 2004/02/28 10:16:02 mattias
|
|
fixed 1.0.x compilation
|
|
|
|
Revision 1.263 2004/02/28 00:34:36 mattias
|
|
fixed CreateComponent for buttons, implemented basic Drag And Drop
|
|
|
|
Revision 1.262 2004/02/27 00:42:41 marc
|
|
* Interface CreateComponent splitup
|
|
* Implemented CreateButtonHandle on GTK interface
|
|
on win32 interface it still needs to be done
|
|
* Changed ApiWizz to support multilines and more interfaces
|
|
|
|
Revision 1.261 2004/02/23 23:15:14 mattias
|
|
improved FindDragTarget
|
|
|
|
Revision 1.260 2004/02/23 18:24:38 mattias
|
|
completed new TToolBar
|
|
|
|
Revision 1.259 2004/02/13 15:49:54 mattias
|
|
started advanced LCL auto sizing
|
|
|
|
Revision 1.258 2004/02/08 11:31:32 mattias
|
|
TMenuItem.Bitmap is now auto created on read. Added TMenuItem.HasBitmap
|
|
|
|
Revision 1.257 2004/02/07 18:04:14 mattias
|
|
fixed grids OnDrawCells
|
|
|
|
Revision 1.256 2004/02/04 12:48:17 mattias
|
|
added CLX colors
|
|
|
|
Revision 1.255 2004/02/03 23:42:43 marc
|
|
* Fixed Shift+Fn menu captions
|
|
|
|
Revision 1.254 2004/02/02 15:46:19 mattias
|
|
implemented basic TSplitter, still many ToDos
|
|
|
|
Revision 1.253 2004/02/02 12:44:45 mattias
|
|
implemented interface constraints
|
|
|
|
Revision 1.252 2004/02/02 00:41:06 mattias
|
|
TScrollBar now automatically checks Align and Anchors for useful values
|
|
|
|
Revision 1.251 2004/01/27 21:32:11 mattias
|
|
improved changing style of controls
|
|
|
|
Revision 1.250 2004/01/27 10:09:44 mattias
|
|
fixed renaming of DFM to LFM
|
|
|
|
Revision 1.249 2004/01/26 11:55:35 mattias
|
|
fixed resizing synedit
|
|
|
|
Revision 1.248 2004/01/23 13:55:30 mattias
|
|
style widgets are now realized, so all values are initialized
|
|
|
|
Revision 1.247 2004/01/22 11:23:36 mattias
|
|
started MaskBlt for gtkIF and applied patch for dir dlg in env opts from Vincent
|
|
|
|
Revision 1.246 2004/01/18 11:03:01 mattias
|
|
added finnish translation
|
|
|
|
Revision 1.245 2004/01/14 20:09:50 mattias
|
|
added TColorDialog debugging
|
|
|
|
Revision 1.244 2004/01/13 16:39:02 mattias
|
|
changed consistency stops during var renaming to errors
|
|
|
|
Revision 1.243 2004/01/12 23:56:10 mattias
|
|
improved double buffering, only one issue left: parent gdkwindow paint messages
|
|
|
|
Revision 1.242 2004/01/11 16:38:29 marc
|
|
* renamed (Check|Enable)MenuItem to MenuItemSet(Check|Enable)
|
|
+ Started with accelerator nameing routines
|
|
* precheckin for createwidget splitup
|
|
|
|
Revision 1.241 2004/01/10 22:34:20 mattias
|
|
started double buffering for gtk intf
|
|
|
|
Revision 1.240 2004/01/09 13:49:43 mattias
|
|
improved gtk intf key fetching and OI keyboard navigation
|
|
|
|
Revision 1.239 2004/01/05 01:18:15 mattias
|
|
implemented Double Buffering for synedit and deactivated multi buffering in TGTKObject.ExtTextOut
|
|
|
|
Revision 1.238 2004/01/04 16:44:33 mattias
|
|
updated gtk2 package
|
|
|
|
Revision 1.237 2004/01/03 23:14:59 mattias
|
|
default font can now change height and fixed gtk crash
|
|
|
|
Revision 1.236 2003/12/26 15:23:30 mattias
|
|
started message editor and fixed some range checks
|
|
|
|
Revision 1.235 2003/12/26 10:59:25 mattias
|
|
fixed color coversion range check
|
|
|
|
Revision 1.234 2003/12/25 14:17:07 mattias
|
|
fixed many range check warnings
|
|
|
|
Revision 1.233 2003/12/18 15:15:13 ajgenius
|
|
fix NIL style crash and GTK2 Compiling
|
|
|
|
Revision 1.232 2003/11/30 18:35:20 mattias
|
|
fixed fpc 1.9.1 warns
|
|
|
|
Revision 1.231 2003/11/29 13:17:38 mattias
|
|
made gtklayout using window theme at start
|
|
|
|
Revision 1.230 2003/11/26 21:30:19 mattias
|
|
reduced unit circles, fixed fpImage streaming
|
|
|
|
Revision 1.229 2003/11/25 08:59:01 mattias
|
|
fixed a few more black colors
|
|
|
|
Revision 1.228 2003/11/23 13:13:35 mattias
|
|
added clWindow for gtklistitem
|
|
|
|
Revision 1.227 2003/11/16 01:56:15 mattias
|
|
changed TMenuItem.Graphic to TMenuItem.Bitmap
|
|
|
|
Revision 1.226 2003/11/15 15:30:34 marc
|
|
* Fixed range chek errors in KeySymtoVKeyArray
|
|
|
|
Revision 1.225 2003/11/07 22:50:44 mattias
|
|
fixed finding sysutilh.inc
|
|
|
|
Revision 1.224 2003/11/01 10:27:41 mattias
|
|
fpc 1.1 fixes, started scrollbar hiding, started polymorphing client areas
|
|
|
|
Revision 1.223 2003/10/30 21:26:23 mattias
|
|
removed some hints
|
|
|
|
Revision 1.222 2003/10/24 21:28:16 marc
|
|
Added cleanup code for keyboard tables
|
|
|
|
Revision 1.221 2003/10/22 20:37:31 ajgenius
|
|
fix accel group test to remove GTK2 warnings
|
|
|
|
Revision 1.220 2003/10/22 17:50:16 mattias
|
|
updated rpm scripts
|
|
|
|
Revision 1.219 2003/10/19 16:33:10 marc
|
|
* Fixed VKey keypad handling
|
|
|
|
Revision 1.218 2003/10/17 03:21:21 ajgenius
|
|
fix GTK2 compiling for new Keyboard changes
|
|
|
|
Revision 1.217 2003/10/16 23:54:27 marc
|
|
Implemented new gtk keyevent handling
|
|
|
|
Revision 1.216 2003/10/15 20:33:37 ajgenius
|
|
add csForm, start fixing Style matching for syscolors and fonts
|
|
|
|
Revision 1.215 2003/10/06 16:13:52 ajgenius
|
|
partly fixed gtk2 mouse offsets;
|
|
added new includes to gtk2 lpk
|
|
|
|
Revision 1.214 2003/10/03 01:25:01 ajgenius
|
|
add more gtk1i<->gtk2 key & event wrappers,
|
|
move more GTK2 workarounds from gtk to gtk2 interface,
|
|
start GTK2 interface SetCallback
|
|
|
|
Revision 1.213 2003/09/25 20:44:42 ajgenius
|
|
minor changes for gtk2
|
|
|
|
Revision 1.212 2003/09/25 16:02:16 ajgenius
|
|
try to catch GDK/X drawable errors and raise an AV to stop killing App
|
|
|
|
Revision 1.211 2003/09/24 17:23:54 ajgenius
|
|
more work toward GTK2 - partly fix CheckListBox, & MenuItems
|
|
|
|
Revision 1.210 2003/09/20 13:27:49 mattias
|
|
varois improvements for ParentColor from Micha
|
|
|
|
Revision 1.209 2003/09/19 00:41:52 ajgenius
|
|
remove USE_PANGO define since pango now apears to work properly.
|
|
|
|
Revision 1.208 2003/09/18 14:06:30 ajgenius
|
|
fixed Tgtkobject.drawtext for Pango till the native pango one works better
|
|
|
|
Revision 1.207 2003/09/17 19:40:46 ajgenius
|
|
Initial DoubleBuffering Support for GTK2
|
|
|
|
Revision 1.206 2003/09/17 15:26:41 mattias
|
|
fixed removing TCustomPage
|
|
|
|
Revision 1.205 2003/09/12 17:40:46 ajgenius
|
|
fixes for GTK2(accel groups, menu accel, 'draw'),
|
|
more work toward Pango(DrawText now works, UpdateDCTextMetric mostly works)
|
|
|
|
Revision 1.204 2003/09/11 21:33:11 ajgenius
|
|
partly fixed TWinControl(csFixed)
|
|
|
|
Revision 1.203 2003/09/10 18:03:46 ajgenius
|
|
more changes for pango -
|
|
partly fixed ref counting,
|
|
added Pango versions of TextOut, CreateFontIndirectEx, and GetTextExtentPoint to the GTK2 interface
|
|
|
|
Revision 1.202 2003/09/10 02:33:41 ajgenius
|
|
fixed TColotDialog for GTK2
|
|
|
|
Revision 1.201 2003/09/09 20:46:38 ajgenius
|
|
more implementation toward pango for gtk2
|
|
|
|
Revision 1.200 2003/09/09 04:15:08 ajgenius
|
|
more updates for GTK2, more GTK1 wrappers, removal of more ifdef's, partly fixed signals
|
|
|
|
Revision 1.199 2003/09/06 22:56:03 ajgenius
|
|
started gtk2 stock icon overrides
|
|
partial/temp(?) workaround for dc paint offsets
|
|
|
|
Revision 1.198 2003/09/06 20:23:53 ajgenius
|
|
fixes for gtk2
|
|
added more wrappers for gtk1/gtk2 converstion and sanity
|
|
removed pointless version $Ifdef GTK2 etc
|
|
IDE now "runs" Tcontrol drawing/using problems
|
|
renders it unuseable however
|
|
|
|
Revision 1.197 2003/09/06 17:24:52 ajgenius
|
|
gtk2 changes for pixmap, getcursorpos, mouse events workaround
|
|
|
|
Revision 1.196 2003/09/05 19:29:38 mattias
|
|
Success: The first gtk2 application ran without error
|
|
|
|
Revision 1.195 2003/09/05 19:03:19 ajgenius
|
|
removed a redundant routine which broke gtk1
|
|
|
|
Revision 1.194 2003/09/05 18:19:54 ajgenius
|
|
Make GTK2 "compile". linking fails still
|
|
(Makefile.fpc needs pkgconfig libs/GTK2 linking rules,
|
|
but not sure how not sure how) and when linked via a make script
|
|
(like gtk2 examples do) apps still won't work(yet). I think we
|
|
need to do a lot of work to make sure incompatible(also to get rid
|
|
of deprecated) things are done in GTK2 interface itself, and just
|
|
use more $Ifdef GTK1 in the gtk interface itself.
|
|
|
|
Revision 1.193 2003/09/04 10:51:30 mattias
|
|
fixed default size of preview widget
|
|
|
|
Revision 1.192 2003/08/30 18:53:08 mattias
|
|
using default colors, when theme does not define them
|
|
|
|
Revision 1.191 2003/08/29 21:21:07 mattias
|
|
fixes for gtk2
|
|
|
|
Revision 1.190 2003/08/28 09:10:00 mattias
|
|
listbox and comboboxes now set sort and selection at handle creation
|
|
|
|
Revision 1.189 2003/08/27 21:14:42 mattias
|
|
fixed a few things for gtk2 intf
|
|
|
|
Revision 1.188 2003/07/21 23:43:32 marc
|
|
* Fixed radiogroup menuitems
|
|
|
|
Revision 1.187 2003/07/02 10:02:51 mattias
|
|
fixed TPaintStruct
|
|
|
|
Revision 1.186 2002/08/18 16:50:09 mattias
|
|
fixes for debugging
|
|
|
|
Revision 1.185 2002/08/17 23:41:35 mattias
|
|
many clipping fixes
|
|
|
|
Revision 1.184 2003/06/19 09:26:58 mattias
|
|
fixed changing unitname during update
|
|
|
|
Revision 1.183 2003/06/18 00:10:38 marc
|
|
+ Added exceptionhandler while delivering messages
|
|
|
|
Revision 1.182 2003/06/13 21:08:53 mattias
|
|
moved TColorButton to dialogs.pp
|
|
|
|
Revision 1.181 2003/06/13 14:26:17 ajgenius
|
|
some fixes toward gtk2
|
|
|
|
Revision 1.180 2003/06/13 10:09:04 mattias
|
|
fixed Set/GetPixel
|
|
|
|
Revision 1.179 2003/06/10 00:46:16 mattias
|
|
fixed aligning controls
|
|
|
|
Revision 1.178 2003/06/03 10:29:22 mattias
|
|
implemented updates between source marks and breakpoints
|
|
|
|
Revision 1.177 2003/06/03 08:02:33 mattias
|
|
implemented showing source lines in breakpoints dialog
|
|
|
|
Revision 1.176 2003/05/27 17:58:31 mattias
|
|
fixed range checks
|
|
|
|
Revision 1.175 2003/05/26 21:42:35 mattias
|
|
fixed typos
|
|
|
|
Revision 1.174 2003/05/26 21:28:22 mattias
|
|
fixed absolute file
|
|
|
|
Revision 1.173 2003/05/26 20:05:21 mattias
|
|
made compiling gtk2 interface easier
|
|
|
|
Revision 1.172 2003/05/19 08:16:33 mattias
|
|
fixed allocation of dc backcolor
|
|
|
|
Revision 1.171 2003/05/01 11:44:03 mattias
|
|
fixed changing menuitem separator and normal
|
|
|
|
Revision 1.170 2003/04/26 10:45:34 mattias
|
|
fixed right control release
|
|
|
|
Revision 1.169 2003/04/20 20:32:40 mattias
|
|
implemented removing, re-adding, updating project dependencies
|
|
|
|
Revision 1.168 2003/04/04 14:59:40 ajgenius
|
|
started fixin for gtk2
|
|
|
|
Revision 1.167 2003/04/03 17:42:13 mattias
|
|
added exception handling for createpixmapindirect
|
|
|
|
Revision 1.166 2003/04/02 13:23:24 mattias
|
|
fixed default font
|
|
|
|
Revision 1.165 2003/03/28 19:39:54 mattias
|
|
started typeinfo for double extended
|
|
|
|
Revision 1.164 2003/03/25 13:00:39 mattias
|
|
implemented TMemo.SelLength, improved OI hints
|
|
|
|
Revision 1.163 2003/03/17 13:00:35 mattias
|
|
improved but not fixed transient windows
|
|
|
|
Revision 1.162 2003/03/15 09:42:50 mattias
|
|
fixed transient windows
|
|
|
|
Revision 1.161 2003/03/09 21:13:32 mattias
|
|
localized gtk interface
|
|
|
|
Revision 1.160 2003/03/02 23:08:31 mattias
|
|
fixed TComboBox.OnChange
|
|
|
|
Revision 1.159 2003/02/18 22:56:23 mattias
|
|
fixed key grabbing
|
|
|
|
Revision 1.158 2003/01/27 13:49:16 mattias
|
|
reduced speedbutton invalidates, added TCanvas.Frame
|
|
|
|
Revision 1.157 2003/01/24 11:58:01 mattias
|
|
fixed clipboard waiting and kwrite targets
|
|
|
|
Revision 1.156 2003/01/01 11:11:50 mattias
|
|
fixed testall example
|
|
|
|
Revision 1.155 2002/12/27 17:12:38 mattias
|
|
added more Delphi win32 compatibility functions
|
|
|
|
Revision 1.154 2002/12/22 23:13:31 mattias
|
|
fixed mem leak of tooltips in GetStyle
|
|
|
|
Revision 1.153 2002/12/22 22:42:55 mattias
|
|
custom controls now support child wincontrols
|
|
|
|
Revision 1.152 2002/02/09 01:48:23 mattias
|
|
renamed TinterfaceObject.Init to AppInit and TWinControls can now contain childs in gtk
|
|
|
|
Revision 1.151 2002/12/05 22:16:32 mattias
|
|
double byte char font started
|
|
|
|
Revision 1.150 2002/11/23 13:48:46 mattias
|
|
added Timer patch from Vincent Snijders
|
|
|
|
Revision 1.149 2002/11/09 18:13:35 lazarus
|
|
MG: fixed gdkwindow checks
|
|
|
|
Revision 1.148 2002/11/05 20:03:42 lazarus
|
|
MG: implemented hints
|
|
|
|
Revision 1.147 2002/11/02 22:25:38 lazarus
|
|
MG: implemented TMethodList and Application Idle handlers
|
|
|
|
Revision 1.146 2002/10/30 12:37:26 lazarus
|
|
MG: mouse cursors are now allocated on demand
|
|
|
|
Revision 1.145 2002/10/28 21:04:26 lazarus
|
|
AJ: fixed mem leek in FillScreenFonts
|
|
|
|
Revision 1.144 2002/10/28 18:17:04 lazarus
|
|
MG: impoved focussing, unfocussing on destroy and fixed unit search
|
|
|
|
Revision 1.143 2002/10/27 22:37:12 lazarus
|
|
MG: added verbosity to delivermessage
|
|
|
|
Revision 1.142 2002/10/27 11:51:35 lazarus
|
|
MG: fixed memleaks
|
|
|
|
Revision 1.141 2002/10/25 15:27:03 lazarus
|
|
AJ: Moved form contents creation to gtkproc for code
|
|
reuse between GNOME and GTK, and to make GNOME MDI
|
|
programming easier later on.
|
|
|
|
Revision 1.140 2002/10/22 12:12:09 lazarus
|
|
MG: accelerators are now shared between non modal forms
|
|
|
|
Revision 1.139 2002/10/21 22:12:48 lazarus
|
|
MG: fixed frmactivate
|
|
|
|
Revision 1.138 2002/10/21 18:21:38 lazarus
|
|
AJ:minor styles improvement; fixed drawing checks under all(?) themes
|
|
|
|
Revision 1.137 2002/10/21 14:40:52 lazarus
|
|
MG: fixes for 1.1
|
|
|
|
Revision 1.136 2002/10/21 13:51:58 lazarus
|
|
AJ: GetDefaultFont - try to get GTK builtin value if style fails
|
|
|
|
Revision 1.135 2002/10/21 13:15:24 lazarus
|
|
AJ:Try and fall back on default style if nil(aka default theme)
|
|
|
|
Revision 1.134 2002/10/21 03:23:36 lazarus
|
|
AJ: rearranged GTK init stuff for proper GNOME init & less duplication between interfaces
|
|
|
|
Revision 1.133 2002/10/20 21:54:04 lazarus
|
|
MG: fixes for 1.1
|
|
|
|
Revision 1.132 2002/10/20 21:49:11 lazarus
|
|
MG: fixes for fpc1.1
|
|
|
|
Revision 1.131 2002/10/20 19:03:57 lazarus
|
|
AJ: minor fixes for FPC 1.1
|
|
|
|
Revision 1.130 2002/10/18 16:08:10 lazarus
|
|
AJ: Partial HintWindow Fix; Added Screen.Font & Font.Name PropEditor; Started to fix ComboBox DropDown size/pos
|
|
|
|
Revision 1.129 2002/10/17 21:00:18 lazarus
|
|
MG: fixed uncapturing of mouse
|
|
|
|
Revision 1.128 2002/10/17 15:09:33 lazarus
|
|
MG: made mouse capturing more strict
|
|
|
|
Revision 1.127 2002/10/15 22:28:06 lazarus
|
|
AJ: added forcelinebreaks
|
|
|
|
Revision 1.126 2002/10/15 16:01:37 lazarus
|
|
MG: fixed timers
|
|
|
|
Revision 1.125 2002/10/15 07:01:30 lazarus
|
|
MG: fixed timer checking
|
|
|
|
Revision 1.124 2002/10/10 19:59:41 lazarus
|
|
MG: get always a default font
|
|
|
|
Revision 1.123 2002/10/10 19:43:17 lazarus
|
|
MG: accelerated GetTextMetrics
|
|
|
|
Revision 1.122 2002/10/10 08:57:25 lazarus
|
|
MG: applied cyrillic patch from vasily
|
|
|
|
Revision 1.121 2002/10/10 08:51:15 lazarus
|
|
MG: added paint messages for some gtk internal widgets
|
|
|
|
Revision 1.120 2002/10/09 10:22:55 lazarus
|
|
MG: fixed client origin coordinates
|
|
|
|
Revision 1.119 2002/10/08 23:44:00 lazarus
|
|
AJ: started GNOME interface & modified gtk interface so everything is public/protected
|
|
|
|
Revision 1.118 2002/10/08 14:10:02 lazarus
|
|
MG: added TDeviceContext.SelectedColors
|
|
|
|
Revision 1.117 2002/10/08 13:42:25 lazarus
|
|
MG: added TDevContextColorType
|
|
|
|
Revision 1.116 2002/10/08 10:08:47 lazarus
|
|
MG: accelerated GDIColor allocating
|
|
|
|
Revision 1.115 2002/10/07 20:50:59 lazarus
|
|
MG: accelerated SelectGDKPenProps
|
|
|
|
Revision 1.114 2002/10/06 17:55:46 lazarus
|
|
MG: JITForms now sets csDesigning before creation
|
|
|
|
Revision 1.113 2002/10/05 10:37:22 lazarus
|
|
MG: fixed TComboBox.ItemIndex on CreateWnd
|
|
|
|
Revision 1.112 2002/10/04 20:46:53 lazarus
|
|
MG: improved TComboBox.SetItemIndex
|
|
|
|
Revision 1.111 2002/10/04 16:38:15 lazarus
|
|
MG: no OnChange event when app sets Text of TComboBox
|
|
|
|
Revision 1.110 2002/10/03 14:47:32 lazarus
|
|
MG: added TComboBox.OnPopup+OnCloseUp+ItemWidth
|
|
|
|
Revision 1.109 2002/10/03 06:55:45 lazarus
|
|
MG: fixed Ampersands2Underscore
|
|
|
|
Revision 1.108 2002/10/01 10:05:50 lazarus
|
|
MG: changed PDeviceContext into class TDeviceContext
|
|
|
|
Revision 1.107 2002/09/30 22:39:22 lazarus
|
|
MG: fixed setcursor
|
|
|
|
Revision 1.106 2002/09/30 20:19:13 lazarus
|
|
MG: fixed flickering of modal forms
|
|
|
|
Revision 1.105 2002/09/29 15:08:43 lazarus
|
|
MWE: Applied patch from "Andrew Johnson" <aj_genius@hotmail.com>
|
|
Patch includes:
|
|
-fixes Problems with hiding modal forms
|
|
-temporarily fixes TCustomForm.BorderStyle in bsNone
|
|
-temporarily fixes problems with improper tabbing in TSynEdit
|
|
|
|
Revision 1.104 2002/09/27 20:52:24 lazarus
|
|
MWE: Applied patch from "Andrew Johnson" <aj_genius@hotmail.com>
|
|
|
|
Here is the run down of what it includes -
|
|
|
|
-Vasily Volchenko's Updated Russian Localizations
|
|
|
|
-improvements to GTK Styles/SysColors
|
|
-initial GTK Palette code - (untested, and for now useless)
|
|
|
|
-Hint Windows and Modal dialogs now try to stay transient to
|
|
the main program form, aka they stay on top of the main form
|
|
and usually minimize/maximize with it.
|
|
|
|
-fixes to Form BorderStyle code(tool windows needed a border)
|
|
|
|
-fixes DrawFrameControl DFCS_BUTTONPUSH to match Win32 better
|
|
when flat
|
|
|
|
-fixes DrawFrameControl DFCS_BUTTONCHECK to match Win32 better
|
|
and to match GTK theme better. It works most of the time now,
|
|
but some themes, noteably Default, don't work.
|
|
|
|
-fixes bug in Bitmap code which broke compiling in NoGDKPixbuf
|
|
mode.
|
|
|
|
-misc other cleanups/ fixes in gtk interface
|
|
|
|
-speedbutton's should now draw correctly when flat in Win32
|
|
|
|
-I have included an experimental new CheckBox(disabled by
|
|
default) which has initial support for cbGrayed(Tri-State),
|
|
and WordWrap, and misc other improvements. It is not done, it
|
|
is mostly a quick hack to test DrawFrameControl
|
|
DFCS_BUTTONCHECK, however it offers many improvements which
|
|
can be seen in cbsCheck/cbsCrissCross (aka non-themed) state.
|
|
|
|
-fixes Message Dialogs to more accurately determine
|
|
button Spacing/Size, and Label Spacing/Size based on current
|
|
System font.
|
|
-fixes MessageDlgPos, & ShowMessagePos in Dialogs
|
|
-adds InputQuery & InputBox to Dialogs
|
|
|
|
-re-arranges & somewhat re-designs Control Tabbing, it now
|
|
partially works - wrapping around doesn't work, and
|
|
subcontrols(Panels & Children, etc) don't work. TabOrder now
|
|
works to an extent. I am not sure what is wrong with my code,
|
|
based on my other tests at least wrapping and TabOrder SHOULD
|
|
work properly, but.. Anyone want to try and fix?
|
|
|
|
-SynEdit(Code Editor) now changes mouse cursor to match
|
|
position(aka over scrollbar/gutter vs over text edit)
|
|
|
|
-adds a TRegion property to Graphics.pp, and Canvas. Once I
|
|
figure out how to handle complex regions(aka polygons) data
|
|
properly I will add Region functions to the canvas itself
|
|
(SetClipRect, intersectClipRect etc.)
|
|
|
|
-BitBtn now has a Stored flag on Glyph so it doesn't store to
|
|
lfm/lrs if Glyph is Empty, or if Glyph is not bkCustom(aka
|
|
bkOk, bkCancel, etc.) This should fix most crashes with older
|
|
GDKPixbuf libs.
|
|
|
|
Revision 1.103 2002/09/26 21:29:30 lazarus
|
|
MWE: Fixed window color
|
|
|
|
Revision 1.102 2002/09/20 13:11:13 lazarus
|
|
MG: fixed TPanel and Frame3D
|
|
|
|
Revision 1.101 2002/09/19 16:45:54 lazarus
|
|
MG: fixed Menu.Free and gdkwindow=nil bug
|
|
|
|
Revision 1.100 2002/09/18 17:07:29 lazarus
|
|
MG: added patch from Andrew
|
|
|
|
Revision 1.99 2002/09/16 15:56:02 lazarus
|
|
Resize cursors in designer.
|
|
|
|
Revision 1.98 2002/09/12 16:49:05 lazarus
|
|
MG: fixed SelectClipRegion
|
|
|
|
Revision 1.97 2002/09/12 15:53:10 lazarus
|
|
MG: small bugfixes
|
|
|
|
Revision 1.96 2002/09/12 15:35:57 lazarus
|
|
MG: small bugfixes
|
|
|
|
Revision 1.95 2002/09/10 06:49:21 lazarus
|
|
MG: scrollingwincontrol from Andrew
|
|
|
|
Revision 1.94 2002/09/08 10:02:00 lazarus
|
|
MG: fixed streaming visible=false
|
|
|
|
Revision 1.93 2002/09/06 22:32:21 lazarus
|
|
Enabled cursor property + property editor.
|
|
|
|
Revision 1.92 2002/09/06 19:45:11 lazarus
|
|
Cleanups plus a fix to TPanel parent/drawing problem.
|
|
|
|
Revision 1.91 2002/09/06 16:46:17 lazarus
|
|
MG: improved GetDCOffset
|
|
|
|
Revision 1.90 2002/09/06 16:38:25 lazarus
|
|
MG: added GetDCOffset
|
|
|
|
Revision 1.89 2002/09/06 15:57:36 lazarus
|
|
MG: fixed notebook client area, send messages and minor bugs
|
|
|
|
Revision 1.88 2002/09/05 10:12:08 lazarus
|
|
|
|
New dialog for multiline caption of TCustomLabel.
|
|
Prettified TStrings property editor.
|
|
Memo now has automatic scrollbars (not fully working), WordWrap and Scrollbars property
|
|
Removed saving of old combo text (it broke things and is not needed). Cleanups.
|
|
|
|
Revision 1.87 2002/09/03 20:02:01 lazarus
|
|
Intermediate UI patch to show a bug.
|
|
|
|
Revision 1.86 2002/09/03 11:32:51 lazarus
|
|
|
|
Added shortcut keys to labels
|
|
Support for alphabetically sorting the properties
|
|
Standardize message and add shortcuts ala Kylix
|
|
Published BorderStyle, unpublished BorderWidth
|
|
ShowAccelChar and FocusControl
|
|
ShowAccelChar and FocusControl for TLabel, escaped ampersands now work.
|
|
|
|
Revision 1.85 2002/09/03 08:07:21 lazarus
|
|
MG: image support, TScrollBox, and many other things from Andrew
|
|
|
|
Revision 1.84 2002/09/02 19:10:32 lazarus
|
|
MG: TNoteBook now starts with no Page and TCustomPage has no auto names
|
|
|
|
Revision 1.83 2002/08/31 11:37:11 lazarus
|
|
MG: fixed destroying combobox
|
|
|
|
Revision 1.82 2002/08/31 10:55:16 lazarus
|
|
MG: fixed range check error in ampersands2underscore
|
|
|
|
Revision 1.81 2002/08/31 07:58:22 lazarus
|
|
MG: fixed resetting comobobox text
|
|
|
|
Revision 1.80 2002/08/30 12:32:23 lazarus
|
|
MG: MoveWindowOrgEx, Splitted FWinControls/FControls, TControl drawing, Better DesignerDrawing, ...
|
|
|
|
Revision 1.79 2002/08/29 00:07:02 lazarus
|
|
MG: fixed TComboBox and InvalidateControl
|
|
|
|
Revision 1.78 2002/08/28 09:40:50 lazarus
|
|
MG: reduced paint messages and DC getting/releasing
|
|
|
|
Revision 1.77 2002/08/27 18:45:14 lazarus
|
|
MG: propedits text improvements from Andrew, uncapturing, improved comobobox
|
|
|
|
Revision 1.76 2002/08/27 06:40:51 lazarus
|
|
MG: ShortCut support for buttons from Andrew
|
|
|
|
Revision 1.75 2002/08/24 12:55:00 lazarus
|
|
MG: fixed mouse capturing, OI edit focus
|
|
|
|
Revision 1.74 2002/08/24 07:09:04 lazarus
|
|
MG: fixed bracket hilighting
|
|
|
|
Revision 1.73 2002/08/24 06:51:23 lazarus
|
|
MG: from Andrew: style list fixes, autosize for radio/checkbtns
|
|
|
|
Revision 1.72 2002/08/23 07:05:17 lazarus
|
|
MG: started form renaming
|
|
|
|
Revision 1.71 2002/08/22 16:43:36 lazarus
|
|
MG: improved theme support from Andrew
|
|
|
|
Revision 1.70 2002/08/22 16:22:39 lazarus
|
|
MG: started debugging of mouse capturing
|
|
|
|
Revision 1.69 2002/08/22 07:30:16 lazarus
|
|
MG: freeing more unused GCs
|
|
|
|
Revision 1.68 2002/08/21 13:35:25 lazarus
|
|
MG: accelerations for synedit
|
|
|
|
Revision 1.67 2002/08/21 11:29:36 lazarus
|
|
MG: fixed mem some leaks in ide and gtk
|
|
|
|
Revision 1.66 2002/08/21 10:46:37 lazarus
|
|
MG: fixed unreleased gdiRegions
|
|
|
|
Revision 1.65 2002/08/19 20:34:48 lazarus
|
|
MG: improved Clipping, TextOut, Polygon functions
|
|
|
|
Revision 1.64 2002/08/19 18:00:03 lazarus
|
|
MG: design signals for gtk internal widgets
|
|
|
|
Revision 1.63 2002/08/19 08:53:45 lazarus
|
|
MG: fixed broken commit
|
|
|
|
Revision 1.62 2002/08/19 08:50:28 lazarus
|
|
MG: fixed parser for Clx enums and empty param lists
|
|
|
|
Revision 1.61 2002/08/17 11:38:04 lazarus
|
|
MG: fixed keygrabbing key translation
|
|
|
|
Revision 1.60 2002/08/16 17:47:39 lazarus
|
|
MG: added some IDE menuicons, fixed submenu indicator bug
|
|
|
|
Revision 1.59 2002/08/15 15:46:49 lazarus
|
|
MG: added changes from Andrew (Clipping)
|
|
|
|
Revision 1.58 2002/08/15 15:11:01 lazarus
|
|
MG: fixed showing menu accelarator shortcuts
|
|
|
|
Revision 1.57 2002/08/15 13:37:58 lazarus
|
|
MG: started menuitem icon, checked, radio and groupindex
|
|
|
|
Revision 1.56 2002/08/05 07:43:29 lazarus
|
|
MG: fixed BadCursor bug and Circle Reference of FixedWidget of csPanel
|
|
|
|
Revision 1.55 2002/08/04 07:09:29 lazarus
|
|
MG: fixed client events
|
|
|
|
Revision 1.54 2002/07/23 07:40:52 lazarus
|
|
MG: fixed get widget position for inherited gdkwindows
|
|
|
|
Revision 1.53 2002/07/20 13:47:04 lazarus
|
|
MG: fixed eventmask for realized windows
|
|
|
|
Revision 1.52 2002/07/09 17:18:23 lazarus
|
|
MG: fixed parser for external vars
|
|
|
|
Revision 1.51 2002/06/26 15:11:10 lazarus
|
|
MG: added new tool: Guess misplaced $IFDEF/$ENDIF
|
|
|
|
Revision 1.50 2002/06/21 18:27:28 lazarus
|
|
MG: non visual component icons are now centered
|
|
|
|
Revision 1.49 2002/06/21 17:54:24 lazarus
|
|
MG: in design mode the mouse cursor is now also set for hidden gdkwindows
|
|
|
|
Revision 1.48 2002/06/21 16:59:16 lazarus
|
|
MG: TControl.Cursor is now set, reduced auto reaction of widgets in design mode
|
|
|
|
Revision 1.47 2002/06/19 19:46:10 lazarus
|
|
MG: Form Editing: snapping, guidelines, modified on move/resize, creating components in csDesigning, ...
|
|
|
|
Revision 1.46 2002/06/14 14:57:07 lazarus
|
|
MG: fixed open file at cursor search path
|
|
|
|
Revision 1.45 2002/06/11 13:41:11 lazarus
|
|
MG: fixed mouse coords and fixed mouse clicked thru bug
|
|
|
|
Revision 1.44 2002/06/09 14:00:42 lazarus
|
|
MG: fixed persistent caret and implemented Form.BorderStyle=bsNone
|
|
|
|
Revision 1.43 2002/06/04 15:17:23 lazarus
|
|
MG: improved TFont for XLFD font names
|
|
|
|
Revision 1.42 2002/05/31 06:45:23 lazarus
|
|
MG: deactivated new system colors, till we got a consistent solution
|
|
|
|
Revision 1.41 2002/05/30 14:11:13 lazarus
|
|
MG: added filters and history to TOpenDialog
|
|
|
|
Revision 1.40 2002/05/29 21:44:39 lazarus
|
|
MG: improved TCommon/File/OpenDialog, fixed TListView scrolling and broder
|
|
|
|
Revision 1.39 2002/05/28 19:39:46 lazarus
|
|
MG: added gtk rc file support and started stule dependent syscolors
|
|
|
|
Revision 1.38 2002/05/13 14:47:02 lazarus
|
|
MG: fixed client rectangles, TRadioGroup, RecreateWnd
|
|
|
|
Revision 1.37 2002/05/12 04:56:21 lazarus
|
|
MG: client rect bugs nearly completed
|
|
|
|
Revision 1.36 2002/05/10 06:05:57 lazarus
|
|
MG: changed license to LGPL
|
|
|
|
Revision 1.35 2002/05/09 12:41:30 lazarus
|
|
MG: further clientrect bugfixes
|
|
|
|
Revision 1.34 2002/05/06 08:50:37 lazarus
|
|
MG: replaced logo, increased version to 0.8.3a and some clientrectbugfix
|
|
|
|
Revision 1.33 2002/04/26 12:26:51 lazarus
|
|
MG: improved clean up
|
|
|
|
Revision 1.32 2002/03/31 23:20:38 lazarus
|
|
MG: fixed initial size of TCustomPage
|
|
|
|
Revision 1.31 2002/03/31 22:01:38 lazarus
|
|
MG: fixed unreleased/unpressed Ctrl/Alt/Shift
|
|
|
|
Revision 1.30 2002/03/25 17:59:23 lazarus
|
|
GTK Cleanup
|
|
Shane
|
|
|
|
Revision 1.29 2002/02/18 22:46:11 lazarus
|
|
Implented TMenuItem.ShortCut (not much tested).
|
|
|
|
Revision 1.28 2001/12/10 11:16:00 lazarus
|
|
MG: added GDK_dead_circumflex key
|
|
|
|
Revision 1.26 2001/11/16 20:08:41 lazarus
|
|
Object inspector has hints now.
|
|
Shane
|
|
|
|
Revision 1.25 2001/11/12 16:56:08 lazarus
|
|
MG: CLIPBOARD
|
|
|
|
Revision 1.24 2001/10/31 16:29:23 lazarus
|
|
Fixed the gtk mousemove bug where the control gets the coord's based on it's parent instead of itself.
|
|
Shane
|
|
|
|
Revision 1.23 2001/10/08 12:57:07 lazarus
|
|
MG: fixed GetPixel
|
|
|
|
Revision 1.22 2001/10/08 08:05:08 lazarus
|
|
MG: fixed TColorDialog set color
|
|
|
|
Revision 1.21 2001/10/07 07:28:34 lazarus
|
|
MG: fixed setpixel and TCustomForm.OnResize event
|
|
|
|
Revision 1.20 2001/09/30 08:34:52 lazarus
|
|
MG: fixed mem leaks and fixed range check errors
|
|
|
|
Revision 1.19 2001/06/20 17:34:37 lazarus
|
|
MG: fixed unknown special key code
|
|
|
|
Revision 1.17 2001/06/20 13:35:51 lazarus
|
|
MG: added VK_IRREGULAR and key grabbing
|
|
|
|
Revision 1.16 2001/06/16 09:14:39 lazarus
|
|
MG: added lazqueue and used it for the messagequeue
|
|
|
|
Revision 1.15 2001/06/05 10:32:06 lazarus
|
|
MG: small bugfixes for bitbtn, handles
|
|
|
|
Revision 1.14 2001/03/21 23:48:29 lazarus
|
|
MG: fixed window positions
|
|
|
|
Revision 1.12 2001/03/19 14:44:22 lazarus
|
|
MG: fixed many unreleased DC and GDIObj bugs
|
|
|
|
Revision 1.10 2001/01/25 21:38:57 lazarus
|
|
MWE:
|
|
* fixed lil bug I commetted yesterday (listbox crash)
|
|
|
|
Revision 1.9 2001/01/24 23:26:40 lazarus
|
|
MWE:
|
|
= moved some types to gtkdef
|
|
+ added WinWidgetInfo
|
|
+ added some initialization to Application.Create
|
|
|
|
Revision 1.8 2001/01/23 23:33:55 lazarus
|
|
MWE:
|
|
- Removed old LM_InvalidateRect
|
|
- did some cleanup in old code
|
|
+ added some comments on gtkobject data (gtkproc)
|
|
|
|
Revision 1.7 2001/01/08 21:59:36 lazarus
|
|
MWE:
|
|
~ applieed patch from Peter Vreman to reflect compiler fix
|
|
|
|
Revision 1.6 2000/12/19 18:43:13 lazarus
|
|
Removed IDEEDITOR. This causes the PROJECT class to not function.
|
|
Saving projects no longer works.
|
|
|
|
I added TSourceNotebook and TSourceEditor. They do all the work for saving/closing/opening units. Somethings work but they are in early development.
|
|
Shane
|
|
|
|
Revision 1.5 2000/10/09 22:50:32 lazarus
|
|
MWE:
|
|
* fixed some selection code
|
|
+ Added selection sample
|
|
|
|
Revision 1.4 2000/09/10 23:08:31 lazarus
|
|
MWE:
|
|
+ Added CreateCompatibeleBitamp function
|
|
+ Updated TWinControl.WMPaint
|
|
+ Added some checks to avoid gtk/gdk errors
|
|
- Removed no fixed warning from GetDC
|
|
- Removed some output
|
|
|
|
Revision 1.3 2000/08/10 10:55:45 lazarus
|
|
Changed TCustomDialog to TCommonDialog
|
|
Shane
|
|
|
|
Revision 1.2 2000/07/30 21:48:34 lazarus
|
|
MWE:
|
|
= Moved ObjectToGTKObject to GTKProc unit
|
|
* Fixed array checking in LoadPixmap
|
|
= Moved LM_SETENABLED to API func EnableWindow and EnableMenuItem
|
|
~ Some cleanup
|
|
|
|
Revision 1.1 2000/07/13 10:28:29 michael
|
|
+ Initial import
|
|
|
|
Revision 1.8 2000/06/29 18:08:56 lazarus
|
|
Shane
|
|
Looking for the editor problem I made a few changes. I changed everything back to the original though.
|
|
|
|
Revision 1.7 2000/06/19 18:21:22 lazarus
|
|
Spinedit was never getting created
|
|
Shane
|
|
|
|
Revision 1.6 2000/06/14 21:51:27 lazarus
|
|
MWE:
|
|
+ Added menu accelerators. Not finished
|
|
|
|
Revision 1.5 2000/05/11 22:04:16 lazarus
|
|
MWE:
|
|
+ Added messagequeue
|
|
* Recoded SendMessage and Peekmessage
|
|
+ Added postmessage
|
|
+ added DeliverPostMessage
|
|
|
|
Revision 1.4 2000/05/10 22:52:58 lazarus
|
|
MWE:
|
|
= Moved some global api stuf to gtkobject
|
|
|
|
Revision 1.3 2000/05/10 01:45:12 lazarus
|
|
Replaced writelns with Asserts.
|
|
Put ERROR and WARNING messages back to writelns. CAW
|
|
|
|
Revision 1.2 2000/05/08 15:56:59 lazarus
|
|
MWE:
|
|
+ Added support for mwedit92 in Makefiles
|
|
* Fixed bug # and #5 (Fillrect)
|
|
* Fixed labelsize in ApiWizz
|
|
+ Added a call to the resize event in WMWindowPosChanged
|
|
|
|
Revision 1.1 2000/03/30 22:51:42 lazarus
|
|
MWE:
|
|
Moved from ../../lcl
|
|
|
|
Revision 1.11 2000/03/30 21:57:44 lazarus
|
|
MWE:
|
|
+ Added some general functions to Get/Set the Main/Fixed/CoreChild
|
|
widget
|
|
+ Started with graphic scalig/depth stuff. This is way from finished
|
|
|
|
Hans-Joachim Ott <hjott@compuserve.com>:
|
|
+ Added some improvements for TMEMO
|
|
|
|
Revision 1.10 2000/03/19 23:01:43 lazarus
|
|
MWE:
|
|
= Changed splashscreen loading/colordepth
|
|
= Chenged Save/RestoreDC to platform dependent, since they are
|
|
relative to a DC
|
|
|
|
Revision 1.9 2000/03/16 23:58:46 lazarus
|
|
MWE:
|
|
Added TPixmap for XPM support
|
|
|
|
Revision 1.8 2000/03/08 23:57:38 lazarus
|
|
MWE:
|
|
Added SetSysColors
|
|
Fixed TEdit text bug (thanks to hans-joachim ott <hjott@compuserve.com>)
|
|
Finished GetKeyState
|
|
Added changes from Peter Dyson <peter@skel.demon.co.uk>
|
|
- a new GetSysColor
|
|
- some improvements on ExTextOut
|
|
|
|
Revision 1.7 2000/03/03 22:58:26 lazarus
|
|
MWE:
|
|
Fixed focussing problem.
|
|
LM-FOCUS was bound to the wrong signal
|
|
Added GetKeyState api func.
|
|
Now LCL knows if shift/trl/alt is pressed (might be handy for keyboard
|
|
selections ;-)
|
|
|
|
Revision 1.6 2000/01/22 20:07:47 lazarus
|
|
Some cleanups. It needs much more cleanup than this.
|
|
Worked around a compiler bug (?) in mwCustomEdit.
|
|
Reverted some changes to font generation and increased font size.
|
|
|
|
Revision 1.5 1999/09/17 14:58:54 lazarus
|
|
Changes made to editor.pp
|
|
Can now press END and some other similiar keys work. Typing works,
|
|
but doesn't paint correctly yet.
|
|
|
|
Revision 1.4 1999/07/31 06:39:30 lazarus
|
|
|
|
Modified the IntSendMessage3 to include a data variable. It isn't used
|
|
yet but will help in merging the Message2 and Message3 features.
|
|
|
|
Adjusted TColor routines to match Delphi color format
|
|
|
|
Added a TGdkColorToTColor routine in gtkproc.inc
|
|
|
|
Finished the TColorDialog added to comDialog example. MAH
|
|
|
|
}
|