lazarus/lcl/interfaces/gtk2/gtk2winapi.inc

10038 lines
316 KiB
PHP

{%MainUnit gtk2int.pas}
{******************************************************************************
All GTK Winapi implementations.
Initial Revision : Sat Nov 13 12:53:53 1999
!! Keep alphabetical !!
Support routines go to gtk2proc.pp
******************************************************************************
Implementation
******************************************************************************
*****************************************************************************
This file is part of the Lazarus Component Library (LCL)
See the file COPYING.modifiedLGPL.txt, included in this distribution,
for details about the license.
*****************************************************************************
}
{$IFOPT C-}
// Uncomment for local trace
// {$C+}
// {$DEFINE ASSERT_IS_ON}
{$EndIf}
{off $define VerboseScrollWindowEx}
//##apiwiz##sps## // Do not remove
{------------------------------------------------------------------------------
Method: Arc
Params: left, top, right, bottom, angle1, angle2
Returns: Nothing
Use Arc to draw an elliptically curved line with the current Pen.
The angles angle1 and angle2 are 1/16th of a degree. For example, a full
circle equals 5760 (16*360). Positive values of Angle and AngleLength mean
counter-clockwise while negative values mean clockwise direction.
Zero degrees is at the 3'o clock position.
Angle1 is the starting angle. Angle2 is relative to Angle1 (added).
Example:
Angle1 = 10*16, Angle2 = 30*16 will draw an arc from 10 to 40 degree.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.Arc(DC: HDC; Left, top, right, bottom, angle1,
angle2: Integer): Boolean;
var
DevCtx: TGtkDeviceContext absolute DC;
DCOrigin: TPoint;
Angle: Integer;
begin
Result := IsValidDC(DC);
if not Result then Exit;
// Draw outline
DevCtx.SelectPenProps;
if not (dcfPenSelected in DevCtx.Flags)
then begin
Result := False;
Exit;
end;
if DevCtx.IsNullPen then Exit;
if DevCtx.HasTransf then
begin
DevCtx.TransfRect(Left, Top, Right, Bottom);
DevCtx.TransfNormalize(Left, Right);
DevCtx.TransfNormalize(Top, Bottom);
// we must convert angles too because of possible negative axis orientations
Angle := Angle1 + Angle2;
DevCtx.TransfAngles(Angle1, Angle);
Angle2 := Angle - Angle1;
end;
DCOrigin := DevCtx.Offset;
inc(Left, DCOrigin.X);
inc(Top, DCOrigin.Y);
inc(Right, DCOrigin.X);
inc(Bottom, DCOrigin.Y);
{$IFDEF DebugGDKTraps}BeginGDKErrorTrap;{$ENDIF}
DevCtx.RemovePixbuf;
gdk_draw_arc(DevCtx.Drawable, DevCtx.GC, 0, left, top, right - left, bottom - top,
Angle1*4, Angle2*4);
{$IFDEF DebugGDKTraps}EndGDKErrorTrap;{$ENDIF}
end;
{------------------------------------------------------------------------------
Method: AngleChord
Params: DC, x1, y1, x2, y2, angle1, angle2
Returns: Nothing
Use AngleChord to draw a filled Chord-shape on the canvas. The angles angle1
and angle2 are 1/16th of a degree. For example, a full circle equals 5760
16*360). Positive values of Angle and AngleLength mean counter-clockwise while
negative values mean clockwise direction. Zero degrees is at the 3'o clock
position.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.AngleChord(DC: HDC;
x1, y1, x2, y2, angle1, angle2: Integer): Boolean;
begin
Result := inherited AngleChord(DC, x1, y1, x2, y2, angle1, angle2);
end;
{------------------------------------------------------------------------------
Function: BeginPaint
Params:
Returns:
------------------------------------------------------------------------------}
function TGtk2WidgetSet.BeginPaint(Handle: hWnd; var PS : TPaintStruct) : hdc;
var
Widget: PGtkWidget;
Info: PWidgetInfo;
DC: TGtkDeviceContext;
paintrect : TGDKRectangle;
Control: TWinControl;
begin
Widget:={%H-}PGtkWidget(Handle);
Info:=GetWidgetInfo(Widget);
if Info<>nil then
Inc(Info^.PaintDepth);
PS.hDC:=GetDC(Handle);
DC:=TGtkDeviceContext(PS.hDC);
DC.PaintRectangle:=PS.rcPaint;
Result := PS.hDC;
if Handle <> 0
then Control := TWinControl(GetLCLObject({%H-}Pointer(Handle)))
else Control := nil;
if (Control <> nil)
and TWSWinControlClass(Control.WidgetSetClass).GetDoubleBuffered(Control)
and not GTK_WIDGET_DOUBLE_BUFFERED({%H-}PGTKWidget(Handle))
then begin
//DebugLn(['TGtk2WidgetSet.BeginPaint ',DbgSName(Control)]);
paintrect.x := PS.rcPaint.Left;
paintrect.y := PS.rcPaint.Top;
paintrect.width := PS.rcPaint.Right- PS.rcPaint.Left;
paintrect.height := PS.rcPaint.Bottom - PS.rcPaint.Top;
if (paintrect.width <= 0) or (paintrect.height <=0)
then begin
paintrect.x := 0;
paintrect.y := 0;
gdk_drawable_get_size(TGtkDeviceContext(Result).Drawable,
@paintrect.width, @paintrect.height);
end;
gdk_window_freeze_updates(TGtkDeviceContext(Result).Drawable);
gdk_window_begin_paint_rect (TGtkDeviceContext(Result).Drawable, @paintrect);
end;
end;
{------------------------------------------------------------------------------
Function: BitBlt
Params: DestDC: The destination devicecontext
X, Y: The left/top corner of the destination rectangle
Width, Height: The size of the destination rectangle
SrcDC: The source devicecontext
XSrc, YSrc: The left/top corner of the source rectangle
Rop: The raster operation to be performed
Returns: True if succesful
The BitBlt function copies a bitmap from a source context into a destination
context using the specified raster operation.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.BitBlt(DestDC: HDC; X, Y, Width, Height: Integer;
SrcDC: HDC; XSrc, YSrc: Integer; Rop: DWORD): Boolean;
begin
Result := StretchBlt(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc, Width,
Height, ROP);
end;
{------------------------------------------------------------------------------
Function: CallNextHookEx
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtk2WidgetSet.CallNextHookEx(hHk: HHOOK; ncode: Integer;
wParam: WParam; lParam: LParam): Integer;
begin
Result := 0;
// TODO: TGtk2WidgetSet.CallNextHookEx: Does anything need to be done here?
end;
{------------------------------------------------------------------------------
Function: CallWindowProc
Params: lpPrevWndFunc:
Handle:
Msg:
wParam:
lParam:
Returns:
------------------------------------------------------------------------------}
function TGtk2WidgetSet.CallWindowProc(lpPrevWndFunc: TFarProc; Handle: HWND;
Msg: UINT; wParam: WParam; lParam: lParam): Integer;
var
Proc : TWndMethod;
Mess : TLMessage;
P : Pointer;
begin
Result := -1;
if Handle = 0 then Exit;
P := g_object_get_data({%H-}PGObject(Handle),'WNDPROC');
if P <> nil then
Proc := TWndMethod(P^)
else
Exit;
Mess.msg := msg;
Mess.LParam := LParam;
Mess.WParam := WParam;
Proc(Mess);
Result := Mess.Result;
end;
{------------------------------------------------------------------------------
Function: ClientToScreen
Params: Handle : HWND; var P : TPoint
Returns: true on success
Converts the client-area coordinates of P to screen coordinates.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.ClientToScreen(Handle : HWND; var P : TPoint) : Boolean;
var
Position: TPoint;
Begin
if Handle = 0
then begin
Position.X := 0;
Position.Y := 0;
end
else begin
Position:=GetWidgetClientOrigin({%H-}PGtkWidget(Handle));
end;
Inc(P.X, Position.X);
Inc(P.Y, Position.Y);
//DebugLn(Format('Trace: [GTKObject.ClientToScreen] Handle: 0x%x --> (%d, %d)', [Integer(Handle), P.X, P.y]));
Result := True;
end;
{------------------------------------------------------------------------------
Function: ClipboardFormatToMimeType
Params: FormatID - a registered format identifier (0 is invalid)
Returns: the corresponding mime type as string
------------------------------------------------------------------------------}
function TGtk2WidgetSet.ClipboardFormatToMimeType(
FormatID: TClipboardFormat): string;
var p: PChar;
begin
if FormatID<>0 then begin
p:=gdk_atom_name(FormatID);
Result:=StrPas(p);
g_free(p);
end else
Result:='';
end;
{------------------------------------------------------------------------------
Function: ClipboardGetData
Params: ClipboardType
FormatID - a registered format identifier (0 is invalid)
Stream - If format is available, it will be appended to this stream
Returns: true on success
------------------------------------------------------------------------------}
function TGtk2WidgetSet.ClipboardGetData(ClipboardType: TClipboardType;
FormatID: TClipboardFormat; Stream: TStream): boolean;
var
FormatAtom: TGdkAtom;
SupportedCnt, i: integer;
SupportedFormats: PGdkAtom;
SelData: TGtkSelectionData;
CompoundTextList: PPGChar;
CompoundTextCount: integer;
function IsFormatSupported(CurFormat: TGdkAtom): boolean;
var
i: integer;
AllID: TGdkAtom;
begin
//DebugLn('IsFormatSupported CurFormat=',dbgs(CurFormat),' SupportedCnt=',dbgs(SupportedCnt));
if CurFormat=0 then begin
Result:=false;
exit;
end;
if SupportedCnt<0 then begin
Result:=false;
AllID:=gdk_atom_intern('TARGETS',GdkFalse);
SelData:=RequestSelectionData(ClipboardWidget,ClipboardType,AllID);
{$IFDEF DEBUG_CLIPBOARD}
DebugLn('IsFormatSupported A ',Dbgs(SelData.Selection),
' ',HexStr(Cardinal(ClipboardTypeAtoms[ClipboardType]),8),
' SelData.Target='+dbgs(SelData.Target),' AllID='+dbgs(AllID),
' SelData.TheType='+dbgs(SelData._type)+' ATOM='+dbgs(gdk_atom_intern('ATOM',GdkTrue))+' Name="'+GdkAtomToStr(SelData._type)+'"',
' SelData.Length='+dbgs(SelData.Length),
' SelData.Format='+dbgs(SelData.Format)
);
{$ENDIF}
if (SelData.Selection<>ClipboardTypeAtoms[ClipboardType])
or (SelData.Target<>AllID)
or (SelData._Type<>gdk_atom_intern('ATOM',GdkFalse))
or ((SelData.Format shr 3)<=0) then begin
SupportedCnt:=0;
exit;
end;
SupportedCnt:=SelData.Length div (SelData.Format shr 3);
SupportedFormats:=PGdkAtom(SelData.Data);
//DebugLn('IsFormatSupported SupportedCnt=',dbgs(SupportedCnt));
{$IFDEF DEBUG_CLIPBOARD}
i:=SupportedCnt-1;
while (i>=0) do begin
debugln(' ',dbgs(i),' "',GdkAtomToStr(SupportedFormats[i]),'"');
dec(i);
end;
{$ENDIF}
end;
i:=SupportedCnt-1;
while (i>=0) and (SupportedFormats[i]<>CurFormat) do dec(i);
Result:=(i>=0);
end;
procedure CheckAtomFormat(const atom_name: Pgchar; only_if_exists:gboolean);
var
FormatTry: TGdkAtom;
begin
if FormatAtom<>0 then exit;
FormatTry:=gdk_atom_intern(atom_name,only_if_exists);
if IsFormatSupported(FormatTry) then
FormatAtom:=FormatTry;
end;
begin
{$IfDef DEBUG_CLIPBOARD}
DebugLn('[TGtk2WidgetSet.ClipboardGetData] A ClipboardWidget=',Dbgs(ClipboardWidget),' FormatID=',ClipboardFormatToMimeType(FormatID),' Now=',dbgs(Now));
{$EndIf}
Result:=false;
if (FormatID=0) or (Stream=nil) then exit;
if not (ClipboardType in [ctPrimarySelection,ctSecondarySelection,ctClipboard])
then exit;
// request the data from the selection owner
SupportedCnt:=-1;
SupportedFormats:=nil;
FillChar(SelData,SizeOf(TGtkSelectionData),0);
try
FormatAtom:=FormatID;
if (FormatAtom=gdk_atom_intern('text/plain',GdkTrue)) then begin
// text/plain is supported in various formats in gtk
FormatAtom:=0;
// check for UTF8 text format 'UTF8_STRING'
CheckAtomFormat('UTF8_STRING',GdkFalse);
// The COMPOUND_TEXT format can be converted and is therefore
// used as default for 'text/plain'
if (SupportedCnt=0) then
FormatAtom:=gdk_atom_intern('COMPOUND_TEXT',GdkFalse)
else begin
CheckAtomFormat('COMPOUND_TEXT',GdkFalse);
// then check for simple text format 'text/plain'
CheckAtomFormat('text/plain',GdkFalse);
// then check for simple text format STRING
CheckAtomFormat('STRING',GdkFalse);
// check for some other formats that can be interpreted as text
CheckAtomFormat('FILE_NAME',GdkTrue);
CheckAtomFormat('HOST_NAME',GdkTrue);
CheckAtomFormat('USER',GdkTrue);
// the TEXT format is not reliable, but it should be supported
CheckAtomFormat('TEXT',GdkFalse);
end;
end;
{$IfDef DEBUG_CLIPBOARD}
DebugLn('[TGtk2WidgetSet.ClipboardGetData] B Format=',ClipboardFormatToMimeType(FormatAtom),' FormatAtom=',dbgs(FormatAtom),' Now=',dbgs(Now));
{$EndIf}
if FormatAtom=0 then exit;
// request data from owner
SelData:=RequestSelectionData(ClipboardWidget,ClipboardType,FormatAtom);
{$IfDef DEBUG_CLIPBOARD}
DebugLn('[TGtk2WidgetSet.ClipboardGetData] C Length=',dbgs(SelData.Length),' Now=',dbgs(Now),' ',
' SelData.Selection=',dbgs(SelData.Selection),' SelData.Length=',dbgs(SelData.Length));
{$EndIf}
if (SelData.Selection<>ClipboardTypeAtoms[ClipboardType])
or (SelData.Target<>FormatAtom) then begin
{$IfDef DEBUG_CLIPBOARD}
DebugLn('[TGtk2WidgetSet.ClipboardGetData] REQUESTED FORMAT NOT SUPPORTED Length=',dbgs(SelData.Length));
{$ENDIF}
exit;
end;
// write data to stream
if (SelData.Data<>nil) and (SelData.Length>0) then begin
if (FormatID=gdk_atom_intern('text/plain',GdkTrue)) then begin
// the lcl expects the return format as simple text
// transform if necessary
if FormatAtom=gdk_atom_intern('COMPOUND_TEXT',GdkTrue) then begin
CompoundTextList:=nil;
CompoundTextCount:=gdk_text_property_to_text_list(SelData._Type,
SelData.Format,SelData.Data,SelData.Length,CompoundTextList);
try
{$IfDef DEBUG_CLIPBOARD}
DebugLn('[TGtk2WidgetSet.ClipboardGetData] D CompoundTextCount=',dbgs(CompoundTextCount),' Now=',dbgs(Now));
{$EndIf}
for i:=0 to CompoundTextCount-1 do
if (CompoundTextList[i]<>nil) then
Stream.Write(CompoundTextList[i]^,StrLen(CompoundTextList[i]));
finally
gdk_free_text_list(CompoundTextList);
end;
end else
Stream.Write(SelData.Data^,SelData.Length);
end else begin
Stream.Write(SelData.Data^,SelData.Length);
end;
end;
{$IfDef DEBUG_CLIPBOARD}
DebugLn('[TGtk2WidgetSet.ClipboardGetData] END ',' Now=',dbgs(Now));
{$EndIf}
Result:=true;
finally
if SupportedFormats<>nil then
FreeMem(SupportedFormats);
if (SelData.Data<>nil) and (PGdkAtom(SelData.Data)<>SupportedFormats) then
FreeMem(SelData.Data);
end;
end;
{------------------------------------------------------------------------------
Function: ClipboardGetFormats
Params: ClipboardType
Returns: true on success
Count contains the number of supported formats
List is an array of TClipboardType
! List will be created. You must free it yourself with FreeMem(List) !
------------------------------------------------------------------------------}
function TGtk2WidgetSet.ClipboardGetFormats(ClipboardType: TClipboardType;
var Count: integer; var List: PClipboardFormat): boolean;
var
AllID: TGdkAtom;
FormatAtoms: PGdkAtom;
Cnt, i: integer;
AddTextPlain: boolean;
SelData: TGtkSelectionData;
function IsFormatSupported(CurFormat: TGdkAtom): boolean;
var a: integer;
begin
if CurFormat<>0 then begin
for a:=0 to Cnt-1 do begin
{$IfDef DEBUG_CLIPBOARD}
DebugLn(' IsFormatSupported ',dbgs(CurFormat),' ',dbgs(FormatAtoms[a]));
{$EndIf}
if FormatAtoms[a]=CurFormat then begin
Result:=true;
exit;
end;
end;
end;
Result:=false;
end;
function IsFormatSupported(Formats: TGtkClipboardFormats): boolean;
var Format: TGtkClipboardFormat;
begin
for Format:=Low(TGtkClipboardFormat) to High(TGtkClipboardFormat) do
if (Format in Formats)
and (IsFormatSupported(
gdk_atom_intern(PGChar(GtkClipboardFormatName[Format]),GdkTrue)))
then begin
Result:=true;
exit;
end;
Result:=false;
end;
begin
{$IfDef DEBUG_CLIPBOARD}
DebugLn('[TGtk2WidgetSet.ClipboardGetFormats] A ClipboardWidget=',Dbgs(ClipboardWidget),' Now=',dbgs(Now));
{$EndIf}
Result:=false;
Count:=0;
List:=nil;
if not (ClipboardType in [ctPrimarySelection,ctSecondarySelection,ctClipboard])
then exit;
// request the list of supported formats from the selection owner
AllID:=gdk_atom_intern('TARGETS',GdkFalse);
SelData:=RequestSelectionData(ClipboardWidget,ClipboardType,AllID);
try
{$IfDef DEBUG_CLIPBOARD}
DebugLn('[TGtk2WidgetSet.ClipboardGetFormats] Checking TARGETS answer ',
' selection: '+dbgs(SelData.Selection)+'='+dbgs(ClipboardTypeAtoms[ClipboardType])+
' "'+GdkAtomToStr(SelData.Selection)+'"',
' target: '+dbgs(SelData.Target),'=',dbgs(AllID),
' "'+GdkAtomToStr(SelData.Target),'"',
' theType: '+dbgs(SelData._type)+'='+dbgs(gdk_atom_intern('ATOM',GdkFalse))+
' "'+GdkAtomToStr(SelData._type)+'"',
' Length='+dbgs(SelData.Length),
' Format='+dbgs(SelData.Format),
' Data='+Dbgs(SelData.Data),
' Now='+dbgs(Now)
);
{$EndIf}
if (SelData.Selection<>ClipboardTypeAtoms[ClipboardType])
or (SelData.Target<>AllID)
or (SelData.Format<=0)
or ((SelData._Type<>gdk_atom_intern('ATOM',GdkFalse))
and (SelData._Type<>AllID))
then
exit;
Cnt:=SelData.Length div (SelData.Format shr 3);
if (SelData.Data<>nil) and (Cnt>0) then begin
Count:=Cnt;
FormatAtoms:=PGdkAtom(SelData.Data);
// add transformable lcl formats
// for example: the lcl expects text as 'text/plain', but gtk applications
// also know 'TEXT' and 'STRING'. These formats can automagically
// transformed into the lcl format, so the lcl format is also supported
// and will be added to the list
AddTextPlain:=false;
if (not IsFormatSupported(gdk_atom_intern('text/plain',GdkTrue)))
and (IsFormatSupported([gfCOMPOUND_TEXT,gfTEXT,gfSTRING,gfFILE_NAME,
gfHOST_NAME,gfUSER]))
then begin
AddTextPlain:=true;
inc(Count);
end;
// copy normal supported formats
GetMem(List,SizeOf(TClipboardFormat)*Count);
i:=0;
while (i<Cnt) do begin
{$IfDef DEBUG_CLIPBOARD}
DebugLn('[TGtk2WidgetSet.ClipboardGetFormats] Supported formats: ',
dbgs(i)+'/'+dbgs(Cnt),': ',dbgs(FormatAtoms[i]));
DebugLn(' MimeType="',ClipboardFormatToMimeType(FormatAtoms[i]),'"');
{$EndIf}
List[i]:=FormatAtoms[i];
inc(i);
end;
// add all lcl formats that the gtk-interface can transform from the
// supported formats
if AddTextPlain then begin
List[i]:=gdk_atom_intern('text/plain',GdkFalse);
inc(i);
end;
end;
finally
if SelData.Data<>nil then FreeMem(SelData.Data);
end;
Result:=true;
end;
{------------------------------------------------------------------------------
Function: ClipboardGetOwnerShip
Params: ClipboardType
OnRequestProc - TClipboardRequestEvent is defined in LCLIntf.pp
If OnRequestProc is nil the onwership will end.
FormatCount - number of formats
Formats - array of TClipboardFormat. The supported formats the owner
provides.
Returns: true on success
Sets the supported formats and requests ownership for the clipboard.
Each time the clipboard is read the OnRequestProc will be executed.
If someone else requests the ownership, the OnRequestProc will be executed
with the invalid FormatID 0 to notify the old owner of the lost of ownership.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.ClipboardGetOwnerShip(ClipboardType: TClipboardType;
OnRequestProc: TClipboardRequestEvent; FormatCount: integer;
Formats: PClipboardFormat): boolean;
var TargetEntries: PGtkTargetEntry;
function IsFormatSupported(FormatID: TGdkAtom): boolean;
var i: integer;
begin
if FormatID=0 then begin
Result:=false;
exit;
end;
i:=FormatCount-1;
while (i>=0) and (Formats[i]<>FormatID) do dec(i);
Result:=(i>=0);
end;
procedure AddTargetEntry(var Index: integer; const FormatName: string);
begin
{$IfDef DEBUG_CLIPBOARD}
DebugLn(' AddTargetEntry ',FormatName);
{$EndIf}
TargetEntries[Index].Target := StrAlloc(Length(FormatName) + 1);
StrPCopy(TargetEntries[Index].Target, FormatName);
TargetEntries[Index].flags:=0;
TargetEntries[Index].Info:=Index;
inc(Index);
end;
{function TGtk2WidgetSet.ClipboardGetOwnerShip(ClipboardType: TClipboardType;
OnRequestProc: TClipboardRequestEvent; FormatCount: integer;
Formats: PClipboardFormat): boolean;}
var
TargetEntriesSize, i: integer;
gtkFormat: TGtkClipboardFormat;
ExpFormatCnt: integer;
OldClipboardWidget: PGtkWidget;
begin
if ClipboardType in [ctPrimarySelection, ctSecondarySelection, ctClipboard] then
begin
{$IfDef DEBUG_CLIPBOARD}
DebugLn('[TGtk2WidgetSet.ClipboardGetOwnerShip] A');
{$EndIf}
ClipboardHandler[ClipboardType]:=nil;
Result:=false;
if (ClipboardWidget=nil) or (FormatCount=0) or (Formats=nil) then
begin
// end ownership
if (ClipBoardWidget <> nil)
and (GetControlWindow(ClipboardWidget)<>nil)
and (gdk_selection_owner_get(ClipboardTypeAtoms[ClipboardType]) =
GetControlWindow(ClipboardWidget))
then begin
gtk_selection_owner_set(nil,ClipboardTypeAtoms[ClipboardType],0);
end;
Result:=true;
exit;
end;
// registering targets
FreeClipboardTargetEntries(ClipboardType);
// the gtk-interface adds automatically some gtk formats unknown to the lcl
ExpFormatCnt:=FormatCount;
for gtkFormat:=Low(TGtkClipboardFormat) to High(TGtkClipboardFormat) do
ClipboardExtraGtkFormats[ClipboardType][gtkFormat]:=false;
{$IfDef DEBUG_CLIPBOARD}
DebugLn('[TGtk2WidgetSet.ClipboardGetOwnerShip] B');
{$EndIf}
if IsFormatSupported(gdk_atom_intern('text/plain',GdkTrue)) then
begin
// lcl provides 'text/plain' and the gtk-interface will automatically
// provide some more text formats
ClipboardExtraGtkFormats[ClipboardType][gfUTF8_STRING]:=not IsFormatSupported(
gdk_atom_intern(PGChar(GtkClipboardFormatName[gfUTF8_STRING]),GdkFalse));
ClipboardExtraGtkFormats[ClipboardType][gfCOMPOUND_TEXT]:=
not IsFormatSupported(
gdk_atom_intern(PGChar(GtkClipboardFormatName[gfCOMPOUND_TEXT]),GdkFalse));
ClipboardExtraGtkFormats[ClipboardType][gfSTRING]:=not IsFormatSupported(
gdk_atom_intern(PGChar(GtkClipboardFormatName[gfSTRING]),GdkFalse));
ClipboardExtraGtkFormats[ClipboardType][gfTEXT]:=not IsFormatSupported(
gdk_atom_intern(PGChar(GtkClipboardFormatName[gfTEXT]),GdkFalse));
end;
for gtkFormat:=Low(TGtkClipboardFormat) to High(TGtkClipboardFormat) do
if ClipboardExtraGtkFormats[ClipboardType][gtkFormat] then
inc(ExpFormatCnt);
// build TargetEntries
TargetEntriesSize:=SizeOf(TGtkTargetEntry) * ExpFormatCnt;
GetMem(TargetEntries,TargetEntriesSize);
FillChar(TargetEntries^,TargetEntriesSize,0);
i:=0;
while i<FormatCount do
AddTargetEntry(i,ClipboardFormatToMimeType(Formats[i]));
for gtkFormat:=Low(TGtkClipboardFormat) to High(TGtkClipboardFormat) do
if ClipboardExtraGtkFormats[ClipboardType][gtkFormat] then
AddTargetEntry(i,GtkClipboardFormatName[gtkFormat]);
// set the supported formats
ClipboardTargetEntries[ClipboardType]:=TargetEntries;
ClipboardTargetEntryCnt[ClipboardType]:=ExpFormatCnt;
// reset the clipboard widget (this will set the new target list)
OldClipboardWidget:=ClipboardWidget;
SetClipboardWidget(nil);
SetClipboardWidget(OldClipboardWidget);
// taking the ownership
{$IfDef DEBUG_CLIPBOARD}
DebugLn('[TGtk2WidgetSet.ClipboardGetOwnerShip] C');
{$EndIf}
if gtk_selection_owner_set(ClipboardWidget,
ClipboardTypeAtoms[ClipboardType],0)=GdkFalse
then begin
{$IfDef DEBUG_CLIPBOARD}
DebugLn('[TGtk2WidgetSet.ClipboardGetOwnerShip] D FAILED');
{$EndIf}
exit;
end;
{$IfDef DEBUG_CLIPBOARD}
DebugLn('[TGtk2WidgetSet.ClipboardGetOwnerShip] YEAH, got it!');
{$EndIf}
ClipboardHandler[ClipboardType]:=OnRequestProc;
Result:=true;
end else
{ the gtk does not support this kind of clipboard, so the application can
have the ownership at any time. The TClipboard in clipbrd.pp has an
internal cache system, so that an application can use all types of
clipboards even if the underlying platform does not support it.
Of course this will only be a local clipboard, invisible to other
applications. }
Result:=true;
end;
function TGtk2WidgetSet.ClipboardFormatNeedsNullByte(
const AFormat: TPredefinedClipboardFormat): Boolean;
begin
Result := False;
end;
{------------------------------------------------------------------------------
Function: ClipboardRegisterFormat
Params: AMimeType
Returns: the registered Format identifier (TClipboardFormat)
------------------------------------------------------------------------------}
function TGtk2WidgetSet.ClipboardRegisterFormat(const AMimeType: string
): TClipboardFormat;
var AtomName: PChar;
begin
if Assigned(Application) then begin
AtomName:=PChar(AMimeType);
Result:=gdk_atom_intern(AtomName,GdkFalse);
end else
RaiseGDBException(
'ERROR: TGtk2WidgetSet.ClipboardRegisterFormat gdk not initialized');
end;
{------------------------------------------------------------------------------
Function: CreateBitmap
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtk2WidgetSet.CreateBitmap(Width, Height: Integer; Planes, BitCount: Longint; BitmapBits: Pointer): HBITMAP;
const
MIN_LOADER_HEADER_SIZE = 128;
type
// the loader internally used starts decoding the header after 128 bytes.
// by adding dummy bytes and adjusting the data offset, we make sure that we
// we write atleast 128 bytes
TBitmapHeader = packed record
FileHeader: tagBitmapFileHeader;
InfoHeader: tagBitmapInfoHeader;
Dummy: array[1..MIN_LOADER_HEADER_SIZE] of Byte;
end;
var
GdiObject: PGdiObject;
procedure FillBitmapInfo(out Header: TBitmapHeader);
begin
FillChar(Header{%H-}, SizeOf(Header), 0);
Header.InfoHeader.biSize := SizeOf(Header.InfoHeader);
Header.InfoHeader.biWidth := Width;
Header.InfoHeader.biHeight := Height;
Header.InfoHeader.biPlanes := Planes;
Header.InfoHeader.biBitCount := Bitcount;
Header.InfoHeader.biCompression := BI_RGB;
Header.InfoHeader.biSizeImage := (((BitCount * Width + 31) shr 5) shl 2) * Height;
Header.InfoHeader.biXPelsPerMeter := GetDeviceCaps(0, LOGPIXELSX);
Header.InfoHeader.biYPelsPerMeter := GetDeviceCaps(0, LOGPIXELSY);
Header.FileHeader.bfType := LeToN($4D42);
Header.FileHeader.bfSize := MIN_LOADER_HEADER_SIZE + Header.InfoHeader.biSizeImage;
Header.FileHeader.bfOffBits := MIN_LOADER_HEADER_SIZE;
end;
procedure LoadDataByPixbufLoader;
const
ALIGNDATA: Word = 0;
var
Header: TBitmapHeader;
Loader: PGdkPixbufLoader;
Src: PGDKPixbuf;
res: Boolean;
LineSize, Count: Integer;
BitsPtr: PByte;
begin
Loader := gdk_pixbuf_loader_new;
if Loader = nil then Exit;
FillBitmapInfo(Header);
Src := nil;
try
if not gdk_pixbuf_loader_write(Loader, TGdkPixBufBuffer(@Header), MIN_LOADER_HEADER_SIZE,nil)
then begin
DebugLn('WARNING: [TGtk2WidgetSet.CreateBitmap] Error loading Bitmap Header!');
Exit;
end;
LineSize := (((BitCount * Width + 15) shr 4) shl 1);
if (LineSize and 2) <> 0
then begin
// bitmapdata needs to be DWord aligned, while CreateBitmap is Word aligned
// so "feed" the loader line by line :(
Count := Height;
res := True;
BitsPtr := BitmapBits;
while res and (Count > 0) do
begin
res := gdk_pixbuf_loader_write(Loader, TGdkPixBufBuffer(BitsPtr), LineSize,nil)
and gdk_pixbuf_loader_write(Loader, TGdkPixBufBuffer(@ALIGNDATA), 2,nil);
Inc(BitsPtr, LineSize);
Dec(Count);
end;
end
else begin
// data is DWord aligned :)
res := gdk_pixbuf_loader_write(Loader, TGdkPixBufBuffer(BitmapBits), Header.InfoHeader.biSizeImage,nil);
end;
if not res
then begin
DebugLn('WARNING: [TGtk2WidgetSet.CreateBitmap] Error loading Image!');
Exit;
end;
Src := gdk_pixbuf_loader_get_pixbuf(loader);
if Src = nil
then begin
DebugLn('WARNING: [TGtk2WidgetSet.CreateBitmap] Error loading Pixbuf!');
Exit;
end;
finally
gdk_pixbuf_loader_close(Loader,nil);
end;
if GdiObject^.GDIPixmapObject.Image<>nil then
begin
gdk_pixmap_unref(GdiObject^.GDIPixmapObject.Image);
GdiObject^.GDIPixmapObject.Image:=nil;
end;
if GdiObject^.GDIPixmapObject.Mask<>nil then
begin
gdk_bitmap_unref(GdiObject^.GDIPixmapObject.Mask);
GdiObject^.GDIPixmapObject.Mask:=nil;
end;
gdk_pixbuf_render_pixmap_and_mask(Src,
GdiObject^.GDIPixmapObject.Image, GdiObject^.GDIPixmapObject.Mask, $80);
gdk_pixbuf_unref(Src);
GdiObject^.Depth := gdk_drawable_get_depth(GdiObject^.GDIPixmapObject.Image);
if GdiObject^.Depth = 1
then begin
if GdiObject^.GDIPixmapObject.Mask <> nil
then gdk_pixmap_unref(GdiObject^.GDIPixmapObject.Mask);
GdiObject^.GDIPixmapObject.Mask := nil;
GdiObject^.GDIBitmapType := gbBitmap;
end
else begin
GdiObject^.GDIBitmapType := gbPixmap;
end;
GdiObject^.Visual := gdk_window_get_visual(GDIObject^.GDIPixmapObject.Image);
if GdiObject^.Visual = nil
then GdiObject^.Visual := gdk_visual_get_best_with_depth(GdiObject^.Depth)
else gdk_visual_ref(GdiObject^.Visual);
GdiObject^.Colormap := gdk_colormap_new(GdiObject^.Visual, GdkTrue);
end;
procedure LoadBitmapData;
var
LineSize, n: Integer;
BitsPtr: Pointer;
Src, Dst: PByte;
begin
LineSize := (Width + 7) shr 3;
if (LineSize and 1) <> 0
then begin
// the gdk_bitmap_create_from_data expects data byte aligned while
// Createbitmap is word aligned. adjust data
BitsPtr := GetMem(LineSize * Height);
Dst := BitsPtr;
Src := BitmapBits;
for n := 1 to height do
begin
Move(Src^, Dst^, LineSize);
Inc(Src, LineSize + 1);
Inc(Dst, LineSize);
end;
end
else begin
BitsPtr := BitmapBits;
end;
GdiObject^.GDIBitmapType := gbBitmap;
GdiObject^.GDIBitmapObject := gdk_bitmap_create_from_data(nil, BitsPtr, Width, Height);
GdiObject^.Visual := nil; // bitmaps don't have a visual
GdiObject^.SystemVisual := False;
if BitsPtr <> BitmapBits
then FreeMem(BitsPtr);
end;
begin
//DebugLn(Format('Trace:> [TGtk2WidgetSet.CreateBitmap] Width: %d, Height: %d, Planes: %d, BitCount: %d, BitmapBits: 0x%x', [Width, Height, Planes, BitCount, PtrUInt(BitmapBits)]));
if (BitCount < 1) or (Bitcount > 32)
then begin
Result := 0;
DebugLn(Format('ERROR: [TGtk2WidgetSet.CreateBitmap] Illegal depth %d', [BitCount]));
Exit;
end;
GdiObject := NewGDIObject(gdiBitmap);
if BitmapBits = nil
then begin
if BitCount = 1
then begin
GdiObject^.GDIBitmapType := gbBitmap;
GdiObject^.GDIBitmapObject := gdk_pixmap_new(nil, Width, Height, 1);
GdiObject^.Visual := nil; // bitmaps don't have a visual
end
else begin
GdiObject^.GDIBitmapType := gbPixmap;
GdiObject^.GDIPixmapObject.Image := gdk_pixmap_new(nil, Width, Height, BitCount);
GdiObject^.Visual := gdk_window_get_visual(GdiObject^.GDIPixmapObject.Image);
gdk_visual_ref(GdiObject^.Visual);
end;
GdiObject^.SystemVisual := False;
end
else begin
if BitCount = 1
then begin
LoadBitmapData;
end
else begin
// Load the data by faking it as a windows bitmap stream (this handles all conversion)
// Problem with his method is that it doesn't result in the bitmap requested.
// it is always a device compatible bitmap
// maybe we should add a gdPixBuf type the the GDIObject for formats not compatible
// with a native pixmap format
LoadDataByPixbufLoader;
end;
end;
Result := HBITMAP({%H-}PtrUInt(GdiObject));
//DebugLn(Format('Trace:< [TGtk2WidgetSet.CreateBitmap] --> 0x%x', [Integer(Result)]));
end;
{------------------------------------------------------------------------------
Function: CreateBrushIndirect
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtk2WidgetSet.CreateBrushIndirect(const LogBrush: TLogBrush): HBRUSH;
const
HATCH_BDIAGONAL : array[0..7] of Byte = ($80, $40, $20, $10, $08, $04, $02, $01);
HATCH_CROSS : array[0..7] of Byte = ($08, $08, $08, $FF, $08, $08, $08, $08);
HATCH_DIAGCROSS : array[0..7] of Byte = ($81, $42, $24, $18, $18, $24, $42, $81);
HATCH_FDIAGONAL : array[0..7] of Byte = ($01, $02, $04, $08, $10, $20, $40, $80);
HATCH_HORIZONTAL: array[0..7] of Byte = ($00, $00, $00, $FF, $00, $00, $00, $00);
HATCH_VERTICAL : array[0..7] of Byte = ($08, $08, $08, $08, $08, $08, $08, $08);
var
GObject: PGdiObject;
TmpMask: PGdkBitmap;
begin
//DebugLn(Format('Trace:> [TGtk2WidgetSet.CreateBrushIndirect] Style: %d, Color: %8x', [LogBrush.lbStyle, LogBrush.lbColor]));
{$IFDEF DebugGDKTraps}
BeginGDKErrorTrap;
{$ENDIF}
GObject := NewGDIObject(gdiBrush);
try
{$IFDEF DebugGDIBrush}
DebugLn('[TGtk2WidgetSet.CreateBrushIndirect] ',DbgS(GObject));
{$ENDIF}
GObject^.IsNullBrush := False;
with LogBrush do
begin
case lbStyle of
BS_NULL {BS_HOLLOW}: // Same as BS_HOLLOW.
GObject^.IsNullBrush := True;
BS_SOLID: // Solid brush.
GObject^.GDIBrushFill := GDK_SOLID;
BS_HATCHED: // Hatched brush.
begin
GObject^.GDIBrushFill := GDK_STIPPLED;
case lbHatch of
HS_BDIAGONAL:
GObject^.GDIBrushPixmap := gdk_bitmap_create_from_data(
nil, pgchar(@HATCH_BDIAGONAL[0]), 8, 8);
HS_CROSS:
GObject^.GDIBrushPixmap := gdk_bitmap_create_from_data(
nil, pgchar(@HATCH_CROSS[0]), 8, 8);
HS_DIAGCROSS:
GObject^.GDIBrushPixmap := gdk_bitmap_create_from_data(
nil, pgchar(@HATCH_DIAGCROSS[0]), 8, 8);
HS_FDIAGONAL:
GObject^.GDIBrushPixmap := gdk_bitmap_create_from_data(
nil, pgchar(@HATCH_FDIAGONAL[0]), 8, 8);
HS_HORIZONTAL:
GObject^.GDIBrushPixmap := gdk_bitmap_create_from_data(
nil, pgchar(@HATCH_HORIZONTAL[0]), 8, 8);
HS_VERTICAL:
GObject^.GDIBrushPixmap := gdk_bitmap_create_from_data(
nil, pgchar(@HATCH_VERTICAL[0]), 8, 8);
else
GObject^.GDIBrushFill := GDK_SOLID;
end;
end;
BS_DIBPATTERN, // A pattern brush defined by a device-independent
// bitmap (DIB) specification. If lbStyle is BS_DIBPATTERN, the
// lbHatch member contains a handle to a packed DIB.Windows 95:
// Creating brushes from bitmaps or DIBs larger than 8x8 pixels
// is not supported. If a larger bitmap is given, only a portion
// of the bitmap is used.
BS_DIBPATTERN8X8, // Same as BS_DIBPATTERN.
BS_DIBPATTERNPT, // A pattern brush defined by a device-independent
// bitmap (DIB) specification. If lbStyle is BS_DIBPATTERNPT, the
// lbHatch member contains a pointer to a packed DIB.
BS_PATTERN, // Pattern brush defined by a memory bitmap.
BS_PATTERN8X8: // Same as BS_PATTERN.
begin
GObject^.GDIBrushPixmap := nil;
if IsValidGDIObject(lbHatch) and ({%H-}PGdiObject(lbHatch)^.GDIType = gdiBitmap) then
begin
case {%H-}PGdiObject(lbHatch)^.GDIBitmapType of
gbBitmap:
begin
GObject^.GDIBrushPixmap := {%H-}PGdiObject(lbHatch)^.GDIBitmapObject;
GObject^.GDIBrushFill := GDK_STIPPLED;
end;
gbPixmap:
begin
GObject^.GDIBrushPixmap := {%H-}PGdiObject(lbHatch)^.GDIPixmapObject.Image;
GObject^.GDIBrushFill := GDK_TILED;
end;
gbPixbuf:
begin
GObject^.GDIBrushPixmap := nil;
TmpMask := nil;
gdk_pixbuf_render_pixmap_and_mask({%H-}PGdiObject(lbHatch)^.GDIPixbufObject,
GObject^.GDIBrushPixmap, TmpMask, $80);
gdk_pixmap_unref(TmpMask);
end;
else
begin
DebugLn('TGtk2WidgetSet.CreateBrushIndirect: Unsupported GDIBitmapType')
end;
end
end
else
RaiseGDBException('unsupported bitmap');
if GObject^.GDIBrushPixmap <> nil then
gdk_pixmap_ref(GObject^.GDIBrushPixmap);
end;
else
RaiseGDBException(Format('unsupported Style %d',[lbStyle]));
end;
{$IFDEF DebugGDKTraps}
EndGDKErrorTrap;
{$ENDIF}
if not GObject^.IsNullBrush then
SetGDIColorRef(GObject^.GDIBrushColor, lbColor);
end;
Result := HBRUSH({%H-}PtrUInt(GObject));
except
Result:=0;
DisposeGDIObject(GObject);
DebugLn('TGtk2WidgetSet.CreateBrushIndirect failed');
end;
//DebugLn(Format('Trace:< [TGtk2WidgetSet.CreateBrushIndirect] Got --> %x', [Result]));
end;
{------------------------------------------------------------------------------
Function: CreateCaret
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtk2WidgetSet.CreateCaret(Handle: HWND; Bitmap: hBitmap; width,
Height: Integer): Boolean;
var
GTKObject: PGTKObject;
BMP: PGDKPixmap;
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.CreateCaret] Finish');
GTKObject := {%H-}PGTKObject(Handle);
Result := GTKObject <> nil;
if Result then begin
if gtk_type_is_a(g_object_type(GTKObject), GTKAPIWidget_GetType)
then begin
if IsValidGDIObjectType(Bitmap, gdiBitmap) then
BMP := {%H-}PGdiObject(Bitmap)^.GDIBitmapObject
else
BMP := nil;
GTKAPIWidget_CreateCaret(PGTKAPIWidget(GTKObject), Width, Height, BMP);
end
// else if // TODO: other widgettypes
else begin
Result := False;
end;
end;
end;
{------------------------------------------------------------------------------
Function: CreateCompatibleBitmap
Params: DC:
Width:
Height:
Returns:
Creates a bitmap compatible with the specified device context.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.CreateCompatibleBitmap(DC: HDC; Width, Height: Integer): HBITMAP;
var
DevCtx: TGtkDeviceContext absolute DC;
GDIObject: PGdiObject;
Depth : Longint;
Drawable, DefDrawable: PGDkDrawable;
begin
//DebugLn(Format('Trace:> [TGtk2WidgetSet.CreateCompatibleBitmap] DC: 0x%x, W: %d, H: %d', [DC, Width, Height]));
if IsValidDC(DC) and (DevCtx.Drawable <> nil)
then begin
DefDrawable := DevCtx.Drawable;
Depth := gdk_drawable_get_depth(DevCtx.Drawable);
end
else begin
DefDrawable := nil;
Depth := gdk_visual_get_system^.Depth;
end;
if (Depth < 1) or (Depth > 32)
then begin
Result := 0;
DebugLn(Format('ERROR: [TGtk2WidgetSet.CreateCompatibleBitmap] Illegal depth %d', [Depth]));
Exit;
end;
GdiObject := NewGDIObject(gdiBitmap);
Drawable := gdk_pixmap_new(DefDrawable, Width, Height, Depth);
GdiObject^.Visual := gdk_window_get_visual(Drawable);
if Depth = 1
then begin
GdiObject^.GDIBitmapType := gbBitmap;
GdiObject^.GDIBitmapObject := Drawable;
end
else begin
GdiObject^.GDIBitmapType := gbPixmap;
GdiObject^.GDIPixmapObject.Image := Drawable;
end;
if GdiObject^.Visual = nil
then begin
GdiObject^.Visual := gdk_visual_get_best_with_depth(Depth);
if GdiObject^.Visual = nil
then GdiObject^.Visual := gdk_visual_get_system;
GdiObject^.SystemVisual := True;
end
else begin
gdk_visual_ref(GdiObject^.Visual);
GdiObject^.SystemVisual := False;
end;
GdiObject^.Colormap := gdk_colormap_new(GdiObject^.Visual, GdkTrue);
Result := HBITMAP({%H-}PtrUInt(GdiObject));
//DebugLn(Format('Trace:< [TGtk2WidgetSet.CreateCompatibleBitmap] DC: 0x%x --> 0x%x', [DC, Result]));
end;
{------------------------------------------------------------------------------
Function: CreateCompatibleDC
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtk2WidgetSet.CreateCompatibleDC(DC: HDC): HDC;
var
pNewDC: TGtkDeviceContext;
begin
Result := 0;
pNewDC := NewDC;
// ToDo: TGtk2WidgetSet.CreateCompatibleDC: when is a DC compatible?
// do not copy
// In a compatible DC you have to select a bitmap into it
(*
if IsValidDC(DC) then
with TGtkDeviceContext(DC)^ do
begin
pNewDC^.hWnd := hWnd;
pNewDC^.Drawable := Drawable;
pNewDC^.GC := gdk_gc_new(Drawable);
end
else begin
// We can't do anything yet
// Wait till a bitmap get selected
end;
*)
with pNewDC do
begin
gdk_color_black(gdk_colormap_get_system, @CurrentTextColor.Color);
BuildColorRefFromGDKColor(CurrentTextColor);
gdk_color_white(gdk_colormap_get_system, @CurrentBackColor.Color);
BuildColorRefFromGDKColor(CurrentBackColor);
end;
Result := HDC(pNewDC);
//DebugLn(Format('trace: [TGtk2WidgetSet.CreateCompatibleDC] DC: 0x%x --> 0x%x', [Integer(DC), Integer(Result)]));
end;
function TGtk2WidgetSet.DestroyCursor(Handle: HCURSOR): Boolean;
begin
Result := Handle <> 0;
if Result then
gdk_cursor_destroy({%H-}PGdkCursor(Handle));
end;
function TGtk2WidgetSet.DestroyIcon(Handle: HICON): Boolean;
begin
Result := (Handle <> 0) and
(
GDK_IS_PIXBUF({%H-}Pointer(Handle)) or
// todo: replace with GDK_IS_CURSOR when fpc will have it
G_TYPE_CHECK_INSTANCE_TYPE({%H-}Pointer(Handle),GDK_TYPE_CURSOR)
);
if Result then
if GDK_IS_PIXBUF({%H-}Pointer(Handle)) then
gdk_pixbuf_unref({%H-}PGdkPixbuf(Handle))
else
gdk_cursor_unref({%H-}PGdkCursor(Handle));
end;
function TGtk2WidgetSet.DPtoLP(DC: HDC; var Points; Count: Integer): BOOL;
var
DevCtx: TGtkDeviceContext absolute DC;
P: PPoint;
begin
Result := False;
if not IsValidDC(DC) then Exit(False);
if not DevCtx.HasTransf then Exit(True);
P := @Points;
while Count > 0 do
begin
Dec(Count);
DevCtx.InvTransfPoint(P^.X, P^.Y);
Inc(P);
end;
Result := True;
end;
{
Gtk2 has no function to build an elliptical region so we approximate it to a
polygon.
}
function TGtk2WidgetSet.CreateEllipticRgn(X1, Y1, X2, Y2: Integer): HRGN;
var
Points: TPointArray;
gPoints: array of TGdkPoint;
i: Integer;
GObject: PGdiObject;
RegionObj: PGdkRegion;
begin
Points:=EllipsePolygon(Rect(X1,Y1,X2,Y2));
SetLength(gPoints,length(Points));
for i:=0 to length(Points)-1 do begin
gPoints[i].x:=Points[i].x;
gPoints[i].y:=Points[i].y;
end;
GObject := NewGDIObject(gdiRegion);
RegionObj := gdk2.gdk_region_polygon(@gPoints[0], length(gPoints), GDK_WINDING_RULE);
GObject^.GDIRegionObject := RegionObj;
Result := HRGN({%H-}PtrUInt(GObject));
//DebugLn('TGtk2WidgetSet.CreateRectRgn A ',GDKRegionAsString(RegionObj));
end;
{------------------------------------------------------------------------------
Function: CreateFontIndirect
Params: const LogFont: TLogFont
Returns: HFONT
Creates a font GDIObject.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.CreateFontIndirect(const LogFont: TLogFont): HFONT;
begin
Result := CreateFontIndirectEx(LogFont,'');
end;
{------------------------------------------------------------------------------
Function: CreateFontIndirectEx
Params: const LogFont: TLogFont; const LongFontName: string
Returns: HFONT
Creates a font GDIObject.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.CreateFontIndirectEx(const LogFont: TLogFont;
const LongFontName: string): HFONT;
{off $DEFINE VerboseFonts}
var
GdiObject: PGdiObject;
FullString, aFamily, aStyle, ALongFontName: String;
aStretch: TPangoStretch;
aSize, aWeight: Integer;
aSizeInPixels: Boolean;
PangoDesc: PPangoFontDescription;
CachedFont: TGtkFontCacheDescriptor;
AttrList: PPangoAttrList;
AttrListTemporary: Boolean;
Attr: PPangoAttribute;
CurFont: PPangoLayout;
begin
{$IFDEF VerboseFonts}
DebugLn('TGtk2WidgetSet.CreateFontIndirectEx A Name=',LogFont.lfFaceName,' Height=',dbgs(LogFont.lfHeight),' LongName=',LongFontName);
{$ENDIF}
Result := 0;
PangoDesc := nil;
GdiObject := nil;
if LongFontName = '' then
ALongFontName := LogFont.lfFaceName
else
ALongFontName := LongFontName;
try
// first search in cache
CachedFont:=FontCache.FindGTkFontDesc(LogFont, ALongFontName);
if CachedFont<>nil then begin
CachedFont.Item.IncreaseRefCount;
GdiObject := NewGdiObject(gdiFont);
GdiObject^.UntransfFontHeight := 0;
GdiObject^.GDIFontObject := TGtkFontCacheItem(CachedFont.Item).GtkFont;
{$IFDEF VerboseFonts}
WriteLn('Was already in cache');
{$ENDIF}
exit;
end;
with LogFont do
begin
if lfFaceName[0] = #0
then begin
//DebugLn('ERROR: [Tgt2kObject.CreateFontIndirectEx] No fontname');
Exit;
end;
// if we have really default font
if (lfHeight = 0) and
(lfWeight = FW_NORMAL) and
(lfItalic = 0) and
(lfUnderline = 0) and
(lfStrikeOut = 0) and
(lfOrientation = 0) and
IsFontNameDefault(lfFacename) then
begin
// use default font
{$IFDEF VerboseFonts}
DebugLn(['TGtk2WidgetSet.CreateFontIndirectEx Creating default font']);
{$ENDIF}
GdiObject := CreateDefaultFont;
exit;
end;
FontNameToPangoFontDescStr(ALongFontname, aFamily, aStyle, aSize, aSizeInPixels);
ExtractPangoFontFaceSuffixes(aFamily, aStretch, aWeight);
// if font specified size, prefer this instead of 'possibly' inaccurate
// lfHeight note that lfHeight may actually have a most accurate value
// but there is no way to know this at this point.
// setting the size, this could be done in two ways
// method 1: fontdesc using fontname like "helvetica 12"
// method 2: fontdesc using fontname like "helvetica" and later modify size
// to obtain consistent font sizes method 2 should be used
// for method 1 converting lfheight to fontsize can lead to rounding errors
// for example, font size=12, lfheight=-12 (75dpi), at 75 dpi aSize=11
// so we would get a font "helvetica 11" instead of "helvetica 12"
// size information, and later modify font size
// using method 2
if IsFontNameDefault(aFamily) then
begin
CurFont := GetDefaultGtkFont(False);
if PANGO_IS_LAYOUT(CurFont) then
begin
PangoDesc := pango_layout_get_font_description(CurFont);
if PangoDesc = nil then
PangoDesc := pango_context_get_font_description(pango_layout_get_context(CurFont));
aFamily := StrPas(pango_font_description_get_family(PangoDesc));
if (aSize = 0) and (lfHeight = 0) then
begin
aSize := pango_font_description_get_size(PangoDesc);
if not pango_font_description_get_size_is_absolute(PangoDesc) then
aSize := PANGO_PIXELS(aSize);
end;
end;
end;
if (aSize = 0) and (lfHeight = 0) then
FullString := '10' // use some default: TODO: find out the default size of the widget
else
if aSize > 0 then
begin
FullString := IntToStr(aSize);
if aSizeInPixels then
FullString := FullString + 'px';
end
else
FullString := '';
if Pos(',', AFamily) > 0 then
FullString := AFamily + ' ' + aStyle + ' ' + FullString
else
FullString := AFamily + ', ' + aStyle + ' ' + FullString;
PangoDesc := pango_font_description_from_string(PChar(FullString));
if aStretch <> PANGO_STRETCH_NORMAL then
pango_font_description_set_stretch(PangoDesc, aStretch);
if (pango_font_description_get_weight(PangoDesc) = PANGO_WEIGHT_NORMAL) then
begin
if (lfWeight = FW_DONTCARE) or
{ handle non bold styles (lfWeight is set to "normal" by default) }
(lfWeight = PANGO_WEIGHT_NORMAL) or
{ handle bold styles (lfWeight is set to "bold" because TFont has fsBold style) }
((lfWeight = PANGO_WEIGHT_BOLD) and (aWeight >= FW_SEMIBOLD)) then
pango_font_description_set_weight(PangoDesc, aWeight)
else if (lfWeight <> FW_DONTCARE) then
pango_font_description_set_weight(PangoDesc, lfWeight);
end;
if (pango_font_description_get_style (PangoDesc) = PANGO_STYLE_NORMAL)
and (lfItalic <> 0) then
pango_font_description_set_style(PangoDesc, PANGO_STYLE_ITALIC);
if (aSize=0) and (lfHeight<>0) then
begin
// a size is not specified, try to calculate one based on lfHeight
// and use this value not in the font name but set this value appart
// NOTE: in gtk2.8 is possible to use pango_font_description_set_absolute_size
// which would be great with the given lfheight value, but older gtk2 version
// doesn't have this function
if lfHeight < 0 then
aSize := -lfHeight * PANGO_SCALE
else
aSize := lfHeight * PANGO_SCALE;
pango_font_description_set_absolute_size(PangoDesc, aSize);
end;
// create font
// TODO: use context widget (CreateFontIndirectEx needs a parameter for this: Context: HWnd)
GdiObject := NewGdiObject(gdiFont);
GdiObject^.UntransfFontHeight := 0;
GdiObject^.GDIFontObject:=gtk_widget_create_pango_layout(
GetStyleWidget(lgsdefault), nil);
CurFont:=GdiObject^.GDIFontObject;
pango_layout_set_font_description(CurFont,PangoDesc);
if (LogFont.lfUnderline<>0) or (LogFont.lfStrikeOut<>0) then
begin
AttrListTemporary := false;
AttrList := pango_layout_get_attributes(CurFont);
if (AttrList = nil) then
begin
AttrList := pango_attr_list_new();
AttrListTemporary := True;
end;
if LogFont.lfUnderline<>0 then
begin
Attr := pango_attr_underline_new(PANGO_UNDERLINE_SINGLE);
pango_attr_list_change(AttrList, Attr);
end;
if LogFont.lfStrikeOut<>0 then
begin
Attr := pango_attr_strikethrough_new(True);
pango_attr_list_change(AttrList, Attr);
end;
pango_layout_set_attributes(CurFont, AttrList);
if AttrListTemporary then
pango_attr_list_unref(AttrList);
end;
pango_layout_set_single_paragraph_mode(CurFont, True);
pango_layout_set_width(CurFont, -1);
pango_layout_set_alignment(CurFont, PANGO_ALIGN_LEFT);
if (lfEscapement <> 0) then
begin
// the rotation is done via the pango matrix of the context
// it must be set by the device context
end;
end;
finally
if (CachedFont = nil) and (GdiObject<>nil) and (GdiObject^.GDIFontObject <> nil) then
begin
// add to cache
CachedFont := FontCache.Add(GdiObject^.GDIFontObject, LogFont, ALongFontName);
//decrement refcount for GdiObject^.GDIFontObject so that object gets
//released when removing from FontCache.
g_object_unref(GdiObject^.GDIFontObject);
if CachedFont <> nil then
begin
CachedFont.PangoFontDescription := PangoDesc;
PangoDesc := nil;
end;
end;
{$IFDEF VerboseFonts}
if (GdiObject<>nil) and (GdiObject^.GDIFontObject <> nil) then begin
DebugLn(['TGtk2WidgetSet.CreateFontIndirectEx New pangolayout=',dbgs(GdiObject^.GDIFontObject),' Cached=',FontCache.FindGTKFont(GdiObject^.GDIFontObject)<>nil]);
end;
{$ENDIF}
// clean up helper objects
if PangoDesc<>nil then
pango_font_description_free(PangoDesc);
if (GdiObject<>nil) then begin
if (GdiObject^.GDIFontObject = nil) then begin
DebugLn(['TGtk2WidgetSet.CreateFontIndirectEx Unable to create font A']);
DisposeGDIObject(GdiObject);
Result := 0;
end else begin
// return the new font
GdiObject^.LogFont:=LogFont;
Result := HFONT({%H-}PtrUInt(GdiObject));
end;
end else begin
{$IFDEF VerboseFonts}
DebugLn(['TGtk2WidgetSet.CreateFontIndirectEx Unable to create font B']);
{$ENDIF}
end;
{$IFDEF VerboseFonts}
DebugLn(['TGtk2WidgetSet.CreateFontIndirectEx END Result=',dbgs(Pointer(PtrInt(Result)))]);
{$ENDIF}
end;
end;
function TGtk2WidgetSet.CreateIconIndirect(IconInfo: PIconInfo): HICON;
var
bitmap: PGdkBitmap;
pixmap: PGdkPixmap;
pixbuf: PGdkPixbuf;
Width, Height: integer;
MaxWidth, MaxHeight: guint;
begin
Result := 0;
if not IsValidGDIObject(IconInfo^.hbmColor) then Exit;
if {%H-}PGDIObject(IconInfo^.hbmColor)^.GDIBitmapType = gbPixbuf then
begin
pixbuf := gdk_pixbuf_copy({%H-}PGDIObject(IconInfo^.hbmColor)^.GDIPixbufObject);
end
else
begin
pixmap := {%H-}PGDIObject(IconInfo^.hbmColor)^.GDIPixmapObject.Image;
//DbgDumpPixmap(pixmap, '');
gdk_drawable_get_size(pixmap, @Width, @Height);
if not IconInfo^.fIcon then
begin
gdk_display_get_maximal_cursor_size(gdk_display_get_default,
@MaxWidth, @MaxHeight);
if (Width > integer(MaxWidth))
or (Height > integer(MaxHeight)) then Exit;
end;
bitmap := CreateGdkMaskBitmap(IconInfo^.hbmColor, IconInfo^.hbmMask);
pixbuf := CreatePixbufFromImageAndMask(pixmap, 0, 0, Width, Height, nil, bitmap);
if bitmap <> nil then
gdk_bitmap_unref(bitmap);
end;
if IconInfo^.fIcon then
begin
Result := HICON({%H-}PtrUInt(pixbuf));
end
else
begin
// create cursor from pixbuf
Result := HCURSOR({%H-}PtrUInt(gdk_cursor_new_from_pixbuf(gdk_display_get_default,
pixbuf, IconInfo^.xHotSpot, IconInfo^.yHotSpot)));
if pixbuf <> nil then
gdk_pixbuf_unref(pixbuf);
end;
end;
{------------------------------------------------------------------------------
Function: CreatePalette
Params: LogPalette
Returns: a handle to the Palette created
------------------------------------------------------------------------------}
function TGtk2WidgetSet.CreatePalette(const LogPalette: TLogPalette): HPALETTE;
var
GObject: PGdiObject;
begin
//DebugLn('trace:[TGtk2WidgetSet.CreatePalette]');
GObject := NewGDIObject(gdiPalette);
GObject^.SystemPalette := False;
GObject^.PaletteRealized := False;
GObject^.VisualType := GDK_VISUAL_PSEUDO_COLOR;
GObject^.PaletteVisual := nil;
{$IFDEF DebugGDKTraps}
BeginGDKErrorTrap;
{$ENDIF}
GObject^.PaletteVisual := gdk_visual_get_best_with_type(GObject^.VisualType);
if GObject^.PaletteVisual = nil
then begin
GObject^.PaletteVisual := GDK_Visual_Get_System;
GDK_Visual_Ref(GObject^.PaletteVisual);
end;
GObject^.PaletteColormap := GDK_Colormap_new(GObject^.PaletteVisual, GdkTrue);
{$IFDEF DebugGDKTraps}
EndGDKErrorTrap;
{$ENDIF}
GObject^.RGBTable := TDynHashArray.Create(-1);
GObject^.RGBTable.OnGetKeyForHashItem:=@GetRGBAsKey;
GObject^.IndexTable := TDynHashArray.Create(-1);
GObject^.IndexTable.OnGetKeyForHashItem:=@GetIndexAsKey;
InitializePalette(GObject, LogPalette.palPalEntry, LogPalette.palNumEntries);
Result := HPALETTE({%H-}PtrUInt(GObject));
end;
{------------------------------------------------------------------------------
Function: CreatePenIndirect
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtk2WidgetSet.CreatePenIndirect(const LogPen: TLogPen): HPEN;
var
GObject: PGdiObject;
begin
//DebugLn('trace:[TGtk2WidgetSet.CreatePenIndirect]');
//write('CreatePenIndirect->');
GObject := NewGDIObject(gdiPen);
GObject^.UnTransfPenWidth := 0;
GObject^.GDIPenDashes := nil;
GObject^.IsExtPen := False;
with LogPen do
begin
GObject^.GDIPenStyle := lopnStyle;
GObject^.GDIPenWidth := lopnWidth.X;
SetGDIColorRef(GObject^.GDIPenColor,lopnColor);
end;
Result := HPEN({%H-}PtrUInt(GObject));
end;
{------------------------------------------------------------------------------
Method: CreatePolygonRgn
Params: Points, NumPts, FillMode
Returns: the handle to the region
Creates a Polygon, a closed many-sided shaped region. The Points parameter is
an array of points that give the vertices of the polygon. FillMode=Winding
determines what points are going to be included in the region. When Winding
is True, points are selected by using the Winding fill algorithm. When Winding
is False, points are selected by using using the even-odd (alternative) fill
algorithm. NumPts indicates the number of points to use.
The first point is always connected to the last point.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.CreatePolygonRgn(Points: PPoint; NumPts: Integer;
FillMode: integer): HRGN;
var
i: integer;
PointArray: PGDKPoint;
GObject: PGdiObject;
fr : TGDKFillRule;
begin
Result := 0;
if NumPts<=1 then exit; // gdk_region_polygon will crash on a polygon with 1 point
GObject := NewGDIObject(gdiRegion);
GetMem(PointArray,SizeOf(TGdkPoint)*NumPts);
for i:=0 to NumPts-1 do begin
PointArray[i].x:=Points[i].x;
PointArray[i].y:=Points[i].y;
end;
If FillMode=Winding then
fr := GDK_WINDING_RULE
else
fr := GDK_EVEN_ODD_RULE;
GObject^.GDIRegionObject := gdk_region_polygon(PointArray, NumPts, fr);
FreeMem(PointArray);
Result := HRGN({%H-}PtrUInt(GObject));
end;
{------------------------------------------------------------------------------
Function: CreateRectRgn
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtk2WidgetSet.CreateRectRgn(X1,Y1,X2,Y2 : Integer): HRGN;
var
R: TGDKRectangle;
RRGN: PGDKRegion;
GObject: PGdiObject;
RegionObj: PGdkRegion;
begin
GObject := NewGDIObject(gdiRegion);
if X1<=X2 then begin
R.X := gint16(X1);
R.Width := X2 - X1;
end else begin
R.X := gint16(X2);
R.Width := X1 - X2;
end;
if Y1<=Y2 then begin
R.Y := gint16(Y1);
R.Height := Y2 - Y1;
end else begin
R.Y := gint16(Y2);
R.Height := Y1 - Y1;
end;
RRGN := gdk_region_new;
RegionObj:=PGdkRegion(gdk_region_union_with_rect(RRGN,@R));
GObject^.GDIRegionObject := RegionObj;
gdk_region_destroy(RRGN);
Result := HRGN({%H-}PtrUInt(GObject));
//DebugLn('TGtk2WidgetSet.CreateRectRgn A ',GDKRegionAsString(RegionObj));
end;
{------------------------------------------------------------------------------
Function: CombineRgn
Params: Dest, Src1, Src2, fnCombineMode
Returns: longint
Combine the 2 Source Regions into the Destination Region using the specified
Combine Mode. The Destination must already be initialized. The Return value
is the Destination's Region type, or ERROR.
The Combine Mode can be one of the following:
RGN_AND : Gets a region of all points which are in both source regions
RGN_COPY : Gets an exact copy of the first source region
RGN_DIFF : Gets a region of all points which are in the first source
region but not in the second.(Source1 - Source2)
RGN_OR : Gets a region of all points which are in either the first
source region or in the second.(Source1 + Source2)
RGN_XOR : Gets all points which are in either the first Source Region
or in the second, but not in both.
The result can be one of the following constants
Error
NullRegion
SimpleRegion
ComplexRegion
------------------------------------------------------------------------------}
function TGtk2WidgetSet.CombineRgn(Dest, Src1, Src2: HRGN;
fnCombineMode: Longint): Longint;
var
Continue: Boolean;
D, S1, S2: PGDKRegion;
DObj, S1Obj, S2Obj: PGDIObject;
begin
Result := SIMPLEREGION;
DObj := {%H-}PGdiObject(Dest);
S1Obj := {%H-}PGdiObject(Src1);
S2Obj := {%H-}PGdiObject(Src2);
Continue := IsValidGDIObject(Dest) and IsValidGDIObject(Src1)
and IsValidGDIObject(Src2);
if not Continue then begin
DebugLn('WARNING: [TGtk2WidgetSet.CombineRgn] Invalid HRGN');
exit(Error);
end;
if DObj^.RefCount>1 then
begin
DebugLn('WARNING: [TGtk2WidgetSet.CombineRgn] Invalid Dest');
exit(RegionType(DObj^.GDIRegionObject));
end;
S1 := S1Obj^.GDIRegionObject;
S2 := S2Obj^.GDIRegionObject;
//DebugLn('TGtk2WidgetSet.CombineRgn A fnCombineMode=',Dbgs(fnCombineMode));
case fnCombineMode of
RGN_AND :
D := PGDKRegion(gdk_region_intersect(S1, S2));
RGN_COPY :
D := gdk_region_copy(S1);
RGN_DIFF :
D := PGDKRegion(gdk_region_subtract(S1, S2));
RGN_OR :
D := PGDKRegion(gdk_region_union(S1, S2));
RGN_XOR :
D := PGDKRegion(gdk_region_xor(S1, S2));
else begin
Result:= ERROR;
D := nil;
end;
end;
if Assigned(DObj^.GDIRegionObject) then
gdk_region_destroy(DObj^.GDIRegionObject);
DObj^.GDIRegionObject := D;
Result := RegionType(D);
//DebugLn('TGtk2WidgetSet.CombineRgn B Mode=',dbgs(fnCombineMode),
// ' S1=',GDKRegionAsString(S1),' S2=',GDKRegionAsString(S2),' D=',GDKRegionAsString(D),'');
end;
{------------------------------------------------------------------------------
Function: DeleteDC
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtk2WidgetSet.DeleteDC(hDC: HDC): Boolean;
begin
// TODO:
// for now it's just the same, however CreateDC/FreeDC
// and GetDC/ReleaseDC are couples
// we should use gdk_new_gc for create and gtk_new_gc for Get
Result:= (ReleaseDC(0, hDC) = 1);
end;
{------------------------------------------------------------------------------
Function: DeleteObject
Params: none
Returns: Nothing
DeleteObject is allowed while the object is still selected. The msdn docs
are misleading. Marc tested with resource profiler under win XP.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.DeleteObject(GDIObject: HGDIOBJ): Boolean;
procedure RaiseInvalidGDIObject;
begin
{$ifdef TraceGdiCalls}
DebugLn();
DebugLn('TGtk2WidgetSet.DeleteObject: TraceCall for invalid object: ');
DumpBackTrace(PgdiObject(GdiObject)^.StackAddrs);
DebugLn();
DebugLn('Exception will follow:');
DebugLn();
{$endif}
RaiseGDBException('TGtk2WidgetSet.DeleteObject invalid GdiObject='+dbgs(GdiObject));
end;
var
GDIObjectExists: boolean;
begin
if GDIObject = 0 then
begin
Result := True;
Exit;
end;
{$IFDEF DebugLCLComponents}
if DebugGdiObjects.IsDestroyed(Pointer(GDIObject)) then
begin
DebugLn(['TGtk2WidgetSet.DeleteObject object already deleted ',GDIObject]);
debugln(DebugGdiObjects.GetInfo(PGdiObject(GDIObject),true));
Halt;
end;
{$ENDIF}
// Find out if we want to release internal GDI object
GDIObjectExists := FGDIObjects.Contains({%H-}PGdiObject(GDIObject));
Result := GDIObjectExists;
if not GDIObjectExists then
begin
RaiseInvalidGDIObject;
end;
Result := ReleaseGDIObject({%H-}PGdiObject(GDIObject));
end;
function TGtk2WidgetSet.DestroyCaret(Handle: HWND): Boolean;
var
GTKObject: PGTKObject;
begin
GTKObject := {%H-}PGTKObject(Handle);
Result := true;
if GTKObject<>nil then begin
if gtk_type_is_a(g_object_type(GTKObject), GTKAPIWidget_GetType)
then begin
GTKAPIWidget_DestroyCaret(PGTKAPIWidget(GTKObject));
end
// else if // TODO: other widgettypes
else begin
Result := False;
end;
end;
end;
function TGtk2WidgetSet.DrawFrameControl(DC: HDC; const Rect : TRect;
uType, uState : Cardinal) : Boolean;
{const
ADJUST_FLAG: array[Boolean] of Integer = (0, BF_ADJUST);
PUSH_EDGE_FLAG: array[Boolean] of Integer = (EDGE_RAISED, EDGE_SUNKEN);
PUSH_EDGE_FLAG2: array[Boolean] of Integer = (0, BF_FLAT);}
var
DevCtx: TGtkDeviceContext absolute DC;
Widget: PGtkWidget;
R: TRect;
ClipArea: TGdkRectangle;
procedure DrawButtonPush;
var
State: TGtkStateType;
Shadow: TGtkShadowType;
aStyle : PGTKStyle;
aDC: TGtkDeviceContext;
DCOrigin: TPoint;
begin
//if Widget<>nil then begin
// use the gtk paint functions to draw a widget style dependent button
//writeln('DrawButtonPush ',
// ' DFCS_BUTTONPUSH=',uState and DFCS_BUTTONPUSH,
// ' DFCS_PUSHED=',uState and DFCS_PUSHED,
// ' DFCS_INACTIVE=',uState and DFCS_INACTIVE,
// ' DFCS_FLAT=',uState and DFCS_FLAT,
// '');
// set State (the interior filling style)
if (DFCS_PUSHED and uState)<>0 then
State := GTK_STATE_ACTIVE //button pressed(GTK ignores disabled)
else if (DFCS_INACTIVE and uState)<>0 then
State := GTK_STATE_INSENSITIVE //button disabled
else if (DFCS_HOT and uState)<>0 then
State := GTK_STATE_PRELIGHT // button enabled, special (e.g. mouse over)
else
State := GTK_STATE_NORMAL; // button enabled, normal
// set Shadow (the border style)
if (DFCS_PUSHED and uState)<>0 then begin
// button down
Shadow:=GTK_SHADOW_IN;
end else begin
if (((DFCS_FLAT+DFCS_CHECKED) and uState)=DFCS_FLAT) then begin
// button up, flat, no special
Shadow:=GTK_SHADOW_ETCHED_OUT;
//Shadow:=GTK_SHADOW_NONE;
end else begin
// button up
Shadow:=GTK_SHADOW_OUT;
end;
end;
aDC:=TGtkDeviceContext(DC);
DCOrigin:= aDC.Offset;
If Widget <> nil then
aStyle := gtk_widget_get_style(Widget)
else
aStyle := GetStyle(lgsButton);
if aStyle = nil then
aStyle := GetStyle(lgsGTK_Default);
// MG: You can't assign a style to any window. Why it is needed anyway?
//aStyle := gtk_style_attach(gtk_style_ref(aStyle),aDC.Drawable);
if aStyle<>nil then
begin
aDC.RemovePixbuf;
if (Shadow=GTK_SHADOW_NONE) then
gtk_paint_flat_box(aStyle,aDC.Drawable,
State,
Shadow,
@ClipArea,
GetStyleWidget(lgsButton),
'button',
R.Left+DCOrigin.X,R.Top+DCOrigin.Y,
R.Right-R.Left,R.Bottom-R.Top)
else
gtk_paint_box(aStyle,aDC.Drawable,
State,
Shadow,
@ClipArea,
GetStyleWidget(lgsButton),
'button',
R.Left+DCOrigin.X,R.Top+DCOrigin.Y,
R.Right-R.Left,R.Bottom-R.Top);
end;
Result := True;
end;
procedure DrawCheckOrRadioButton(IsRadioButton: Boolean);
const
LazGtkStyleMap: array[Boolean] of TLazGtkStyle = (lgsCheckbox, lgsRadiobutton);
var
State: TGtkStateType;
Shadow: TGtkShadowType;
aDC: TGtkDeviceContext;
DCOrigin: TPoint;
Style : PGTKStyle;
Widget : PGTKWidget;
begin
// use the gtk paint functions to draw a widget style dependent check/radio button
if (DFCS_BUTTON3STATE and uState)<>0 then
Shadow := GTK_SHADOW_ETCHED_IN //3state style
else if (DFCS_CHECKED and uState)<>0 then
Shadow := GTK_SHADOW_IN //checked style
else
Shadow := GTK_SHADOW_OUT; //unchecked style
if (DFCS_PUSHED and uState)<>0 then
State := GTK_STATE_ACTIVE //button pressed(GTK ignores disabled)
else if (DFCS_INACTIVE and uState)<>0 then
State := GTK_STATE_INSENSITIVE //button disabled
else if (DFCS_HOT and uState)<>0 then
State := GTK_STATE_PRELIGHT // button enabled, special (e.g. mouse over)
else
State := GTK_STATE_NORMAL; // button enabled, normal
aDC:=TGtkDeviceContext(DC);
DCOrigin := aDC.Offset;
Style := GetStyle(LazGtkStyleMap[IsRadioButton]);
if Style = nil then
begin
Style := GetStyle(lgsGTK_Default);
if Style <> nil then
Style := gtk_style_attach(gtk_style_ref(Style),aDC.Drawable);
end;
Widget := GetStyleWidget(LazGtkStyleMap[IsRadioButton]);
if Widget = nil then
Widget := GetStyleWidget(lgsDefault);
if Widget <> nil then
Widget^.Window := aDC.Drawable;
Result := Style <> nil;
if Result then
begin
aDC.RemovePixbuf;
if IsRadioButton then
gtk_paint_option(Style,aDC.Drawable, State,
Shadow, @ClipArea, Widget, 'radiobutton',
R.Left+DCOrigin.X,R.Top+DCOrigin.Y,
R.Right-R.Left, R.Bottom-R.Top)
else
gtk_paint_check(Style,aDC.Drawable, State,
Shadow, @ClipArea, Widget, 'checkbutton',
R.Left+DCOrigin.X,R.Top+DCOrigin.Y,
R.Right-R.Left, R.Bottom-R.Top);
end;
end;
var
ClientWidget: PGtkWidget;
begin
Result := False;
if IsValidDC(DC) then
begin
if DevCtx.HasTransf then
begin
R := DevCtx.TransfRectIndirect(Rect);
DevCtx.TransfNormalize(R.Left, R.Right);
DevCtx.TransfNormalize(R.Top, R.Bottom);
end else
R := Rect;
Widget:=TGtkDeviceContext(DC).Widget;
//It's possible to draw in a DC without a widget, e.g., a Bitmap
if Widget <> nil then
begin
ClientWidget:=GetFixedWidget(Widget);
if ClientWidget<>nil then
Widget:=ClientWidget;
end;
end else
Widget:=nil;
ClipArea := DevCtx.ClipRect;
case uType of
DFC_CAPTION:
begin //all draw CAPTION commands here
end;
DFC_MENU:
begin
end;
DFC_SCROLL:
begin
end;
DFC_BUTTON:
begin
//DebugLn(Format('Trace: [TGtk2WidgetSet.DrawFrameControl] DFC_BUTTON --> draw rect = %d,%d,%d,%d',[R.Left,R.Top,R.Right,R.Bottom]));
//figure out the style first
if (uState and $1F) in [DFCS_BUTTONCHECK, DFCS_BUTTON3STATE] then
begin
//DebugLn('Trace:State ButtonCheck');
DrawCheckOrRadioButton(False);
end
else if (DFCS_BUTTONRADIO and uState) <> 0 then
begin
//DebugLn('Trace:State ButtonRadio');
DrawCheckOrRadioButton(True);
end
else if (DFCS_BUTTONPUSH and uState) <> 0 then
begin
//DebugLn('Trace:State ButtonPush');
DrawButtonPush;
end
else if (DFCS_BUTTONRADIOIMAGE and uState) <> 0 then
begin
//DebugLn('Trace:State ButtonRadioImage');
end
else if (DFCS_BUTTONRADIOMASK and uState) <> 0 then
begin
//DebugLn('Trace:State ButtonRadioMask');
end
else
DebugLn(Format('ERROR: [TGtk2WidgetSet.DrawFrameControl] Unknown State 0x%x', [uState]));
end;
else
DebugLn(Format('ERROR: [TGtk2WidgetSet.DrawFrameControl] Unknown type %d', [uType]));
end;
end;
function TGtk2WidgetSet.DrawFocusRect(DC: HDC; const Rect: TRect): boolean;
var
DevCtx: TGtkDeviceContext absolute DC;
Origin: TPoint;
procedure DrawPixel(X1,Y1: Integer);
begin
inc(X1,Origin.X);
inc(Y1,Origin.Y);
TGtkDeviceContext(DC).RemovePixbuf;
gdk_draw_point(TGtkDeviceContext(DC).Drawable, TGtkDeviceContext(DC).GC, X1, Y1);
end;
procedure DrawVertLine(X1,Y1,Y2: integer);
begin
if Y2<Y1 then
while Y2<Y1 do begin
DrawPixel(X1, Y1);
dec(Y1, 2);
end
else
while Y1<Y2 do begin
DrawPixel(X1, Y1);
inc(Y1, 2);
end;
end;
procedure DrawHorzLine(X1,Y1,X2: integer);
begin
if X2<X1 then
while X2<X1 do begin
DrawPixel(X1, Y1);
dec(X1, 2);
end
else
while X1<X2 do begin
DrawPixel(X1, Y1);
inc(X1, 2);
end;
end;
var
OldROP: Integer;
APen, TempPen: HPEN;
LogPen : TLogPen;
R: TRect;
P: Pointer;
AValue: TGValue;
Style: PGtkStyle;
begin
Result := False;
if IsValidDC(DC) then
begin
with LogPen do
begin
lopnStyle := PS_DOT;
lopnWidth.X := 2;
lopnColor := clWhite;
end;
if DevCtx.HasTransf then
R := DevCtx.TransfRectIndirect(Rect)
else
R := Rect;
// paint a themed focus rectangle with fallback to the default method
P := GetStyleWidget(lgsDefault);
if P <> nil then
begin
FillChar(AValue{%H-}, SizeOf(AValue), 0);
g_value_init(@AValue, G_TYPE_INT);
gtk_widget_style_get_property(P, 'focus-line-width', @AValue);
if AValue.data[0].v_int > 0 then
LogPen.lopnWidth.X := AValue.data[0].v_int;
end;
if (DevCtx.Widget <> nil) then
begin
Style := gtk_widget_get_style(DevCtx.Widget);
if (Style <> nil) then
begin
gtk_paint_focus(
Style, DevCtx.Drawable, GTK_WIDGET_STATE(DevCtx.Widget){GTK_STATE_ACTIVE},
nil, DevCtx.Widget, nil,
R.Left, R.Top,
R.Width, R.Height);
Result := True;
exit;
end;
end;
APen := CreatePenIndirect(LogPen);
TempPen := SelectObject(DC, APen);
OldRop := SetROP2(DC, R2_XORPEN);
Origin := DevCtx.Offset;
try
DrawHorzLine(R.Left, R.Top, R.Right-1);
DrawVertLine(R.Right-1, R.Top, R.Bottom-1);
DrawHorzLine(R.Right-1, R.Bottom-1, R.Left);
DrawVertLine(R.Left, R.Bottom-1, R.Top);
Result := True;
finally
SelectObject(DC, TempPen);
DeleteObject(APen);
SetROP2(DC, OldROP);
end;
end;
end;
{------------------------------------------------------------------------------
Function: DrawEdge
Params: DC: HDC; var Rect: TRect; edge: Cardinal; grfFlags: Cardinal
Returns: Boolean
Draws one or more edges of a rectangle. The rectangle is the area
Left to Right-1 and Top to Bottom-1.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.DrawEdge(DC: HDC; var ARect: TRect; Edge: Cardinal;
grfFlags: Cardinal): Boolean;
procedure DrawEdges(var R: TRect; GC: pgdkGC; Drawable:PGdkDrawable;
const TopLeftColor, BottomRightColor: TGDKColor);
begin
gdk_gc_set_foreground(GC, @TopLeftColor);
if (grfFlags and BF_TOP) = BF_TOP then begin
gdk_draw_line(Drawable, GC, R.Left, R.Top, R.Right, R.Top);
inc(R.Top);
end;
if (grfFlags and BF_LEFT) = BF_LEFT then begin
gdk_draw_line(Drawable, GC, R.Left, R.Top, R.Left, R.Bottom);
inc(R.Left);
end;
gdk_gc_set_foreground(GC, @BottomRightColor);
if (grfFlags and BF_BOTTOM) = BF_BOTTOM then begin
gdk_draw_line(Drawable, GC, R.Left, R.Bottom-1, R.Right, R.Bottom-1);
dec(R.Bottom);
end;
if (grfFlags and BF_RIGHT) = BF_RIGHT then begin
gdk_draw_line(Drawable, GC, R.Right-1, R.Top, R.Right-1, R.Bottom);
dec(R.Right);
end;
end;
var
InnerTL, OuterTL,
InnerBR, OuterBR, MiddleColor: TGDKColor;
BInner, BOuter: Boolean;
R: TRect;
DCOrigin: TPoint;
begin
//DebugLn('TGtk2WidgetSet.DrawEdge Edge=',DbgS(Edge),8),' grfFlags=',DbgS(Cardinal(grfFlags));
Result := IsValidDC(DC);
if Result then
with TGtkDeviceContext(DC) do
begin
R := ARect;
LPtoDP(DC, R, 2);
DCOrigin := Offset;
Types.OffsetRect(R, DCOrigin.X, DCOrigin.Y);
// try to use the gdk functions, so that the current theme is used
BInner := False;
BOuter := False;
// TODO: change this to real colors
if (edge and BDR_RAISEDINNER) = BDR_RAISEDINNER
then begin
InnerTL := AllocGDKColor(GetSysColor(COLOR_BTNHIGHLIGHT));
InnerBR := AllocGDKColor(GetSysColor(COLOR_BTNSHADOW));
BInner := True;
end;
if (edge and BDR_SUNKENINNER) = BDR_SUNKENINNER
then begin
InnerTL := AllocGDKColor(GetSysColor(COLOR_BTNSHADOW));
InnerBR := AllocGDKColor(GetSysColor(COLOR_BTNHIGHLIGHT));
BInner := True;
end;
if (edge and BDR_RAISEDOUTER) = BDR_RAISEDOUTER
then begin
OuterTL := AllocGDKColor(GetSysColor(COLOR_BTNHIGHLIGHT));
OuterBR := AllocGDKColor(GetSysColor(COLOR_BTNSHADOW));
BOuter := True;
end;
if (edge and BDR_SUNKENOUTER) = BDR_SUNKENOUTER
then begin
OuterTL := AllocGDKColor(GetSysColor(COLOR_BTNSHADOW));
OuterBR := AllocGDKColor(GetSysColor(COLOR_BTNHIGHLIGHT));
BOuter := True;
end;
gdk_gc_set_fill(GC, GDK_SOLID);
SelectedColors := dcscCustom;
// Draw outer rect
if BOuter then
begin
RemovePixbuf;
DrawEdges(R, GC,Drawable,OuterTL,OuterBR);
end;
// Draw inner rect
if BInner then
begin
RemovePixbuf;
DrawEdges(R,GC,Drawable,InnerTL,InnerBR);
end;
// gdk_colormap_free_colors(gdk_colormap_get_system, @OuterTL, 1);
// gdk_colormap_free_colors(gdk_colormap_get_system, @OuterBR, 1);
// gdk_colormap_free_colors(gdk_colormap_get_system, @InnerTL, 1);
// gdk_colormap_free_colors(gdk_colormap_get_system, @InnerBR, 1);
//Draw interiour
if ((grfFlags and BF_MIDDLE) = BF_MIDDLE) then
begin
RemovePixbuf;
MiddleColor := AllocGDKColor(GetSysColor(COLOR_BTNFACE));
gdk_gc_set_foreground(GC, @MiddleColor);
gdk_draw_rectangle(Drawable, GC, 1, R.Left, R.Top,
R.Right - R.Left, R.Bottom - R.Top);
end;
// adjust rect if needed
if (grfFlags and BF_ADJUST) = BF_ADJUST then
begin
ARect := R;
Types.OffsetRect(ARect, -DCOrigin.X, -DCOrigin.Y);
DPtoLP(DC, ARect, 2);
end;
Result := True;
end;
end;
{------------------------------------------------------------------------------
Method: DrawText
Params: DC, Str, Count, Rect, Flags
Returns: If the string was drawn, or CalcRect run
------------------------------------------------------------------------------}
function TGtk2WidgetSet.DrawText(DC: HDC; Str: PChar; Count: Integer;
var Rect: TRect; Flags: Cardinal): Integer;
const
TabString = ' ';
var
pIndex: Longint;
AStr: String;
TM: TTextmetric;
theRect: TRect;
Lines: PPChar;
I, NumLines: Longint;
TempDC: HDC;
TempPen: HPEN;
TempBrush: HBRUSH;
l: LongInt;
Pt: TPoint;
SavedRect: TRect; // if font orientation <> 0
LineHeight: Integer;
Size: TSize;
function LeftOffset: Longint;
begin
if (Flags and DT_RIGHT) = DT_RIGHT then
Result := DT_RIGHT
else
if (Flags and DT_CENTER) = DT_CENTER then
Result := DT_CENTER
else
Result := DT_LEFT;
end;
function TopOffset: Longint;
begin
if (Flags and DT_BOTTOM) = DT_BOTTOM then
Result := DT_BOTTOM
else
if (Flags and DT_VCENTER) = DT_VCENTER then
Result := DT_VCENTER
else
Result := DT_TOP;
end;
function CalcRect: Boolean;
begin
Result := (Flags and DT_CALCRECT) = DT_CALCRECT;
end;
function TextExtentPoint(Str: PChar; Count: Integer; var Sz: TSize): Boolean;
var
NewStr: String;
begin
if (Flags and DT_EXPANDTABS) <> 0 then
begin
NewStr := StringReplace(Str, #9, TabString, [rfReplaceAll]);
Result := GetTextExtentPoint(DC, PChar(NewStr), Length(NewStr), Sz);
end
else
Result := GetTextExtentPoint(Dc, Str, Count, Sz);
end;
procedure DoCalcRect;
var
AP: TSize;
J, MaxWidth,
LineWidth, ActualHeight: Integer;
begin
theRect := Rect;
MaxWidth := theRect.Right - theRect.Left;
if (Flags and DT_SINGLELINE) > 0 then
begin
// ignore word and line breaks
TextExtentPoint(PChar(AStr), length(AStr), AP{%H-});
theRect.Bottom := theRect.Top + TM.tmHeight;
if (Flags and DT_CALCRECT)<>0 then
begin
theRect.Right := theRect.Left + AP.cX;
theRect.Bottom := theRect.Top + AP.cY;
end
else
begin
theRect.Right := theRect.Left + Min(MaxWidth, AP.cX);
theRect.Bottom := theRect.Top + AP.cY;
if (Flags and DT_VCENTER) > 0 then
begin
Types.OffsetRect(theRect, 0, ((Rect.Bottom - Rect.Top) - (theRect.Bottom - theRect.Top)) div 2);
end
else
if (Flags and DT_BOTTOM) > 0 then
begin
Types.OffsetRect(theRect, 0, (Rect.Bottom - Rect.Top) - (theRect.Bottom - theRect.Top));
end;
end;
end
else
begin
// consider line breaks
if (Flags and DT_WORDBREAK) = 0 then
begin
// do not break at word boundaries
TextExtentPoint(PChar(AStr), length(AStr), AP);
MaxWidth := AP.cX;
end;
Self.WordWrap(DC, PChar(AStr), MaxWidth, Lines, NumLines);
if (Flags and DT_CALCRECT)<>0 then
begin
LineWidth := 0;
ActualHeight := 0;
if (Lines <> nil) then
begin
for J := 0 to NumLines - 1 do
begin
TextExtentPoint(Lines[J], StrLen(Lines[J]), AP);
LineWidth := Max(LineWidth, AP.cX);
Inc(ActualHeight, AP.cY);
end;
end;
LineWidth := Min(MaxWidth, LineWidth);
end else
begin
LineWidth := MaxWidth;
ActualHeight := NumLines*TM.tmHeight;
end;
theRect.Right := theRect.Left + LineWidth;
theRect.Bottom := theRect.Top + ActualHeight;
if NumLines>1 then
Inc(theRect.Bottom, (NumLines-1)*TM.tmExternalLeading);// space between lines
//debugln('TGtk2WidgetSet.DrawText A ',dbgs(theRect),' TM.tmHeight=',dbgs(TM.tmHeight),' LineWidth=',dbgs(LineWidth),' NumLines=',dbgs(NumLines));
end;
if not CalcRect then
case LeftOffset of
DT_CENTER:
Types.OffsetRect(theRect, (Rect.Right - theRect.Right) div 2, 0);
DT_RIGHT:
Types.OffsetRect(theRect, Rect.Right - theRect.Right, 0);
end;
end;
// if our Font.Orientation <> 0 we must recalculate X,Y offset
// also it works only with DT_TOP DT_LEFT. Gtk2 can handle multiline
// text in this case too.
procedure CalculateOffsetWithAngle(const AFontAngle: Integer;
var TextLeft,TextTop: Integer);
var
OffsX, OffsY: integer;
Angle: Double;
Size: TSize;
R: TRect;
begin
R := SavedRect;
OffsX := R.Right - R.Left;
OffsY := R.Bottom - R.Top;
Size.cx := OffsX;
Size.cy := OffsY;
Angle := AFontAngle / 10;
if Angle < 0 then
Angle := 360 + Angle;
if Angle <= 90 then
begin
OffsX := 0;
OffsY := Trunc(Size.cx * sin(Angle * Pi / 180));
end else
if Angle <= 180 then
begin
OffsX := Trunc(Size.cx * -cos(Angle * Pi / 180));
OffsY := Trunc(Size.cx * sin(Angle * Pi / 180) +
Size.cy * cos((180 - Angle) * Pi / 180));
end else
if Angle <= 270 then
begin
OffsX := Trunc(Size.cx * -cos(Angle * Pi / 180) +
Size.cy * sin((Angle - 180) * Pi / 180));
OffsY := Trunc(Size.cy * sin((270 - Angle) * Pi / 180));
end else
if Angle <= 360 then
begin
OffsX := Trunc(Size.cy * sin((360 - Angle) * Pi / 180));
OffsY := 0;
end;
TextTop := OffsY;
TextLeft := OffsX;
end;
function NeedOffsetCalc: Boolean;
var
AClipRect: TRect;
begin
{see issue #27547}
AClipRect := RectFromGdkRect(TGtkDeviceContext(DC).ClipRect);
Types.OffsetRect(AClipRect, -AClipRect.Left, -AClipRect.Top);
Result := (TGtkDeviceContext(DC).CurrentFont^.LogFont.lfOrientation <> 0) and
(Flags and DT_SINGLELINE <> 0) and
(Flags and DT_VCENTER = 0) and (Flags and DT_CENTER = 0) and
(Flags and DT_RIGHT = 0) and (Flags and DT_BOTTOM = 0) and
(Flags and DT_CALCRECT = 0) and not IsRectEmpty(SavedRect) and
EqualRect(AClipRect, Rect);
end;
procedure DrawLineRaw(theLine: PChar; LineLength, TopPos: Longint);
var
Points: array[0..1] of TSize;
LeftPos: Longint;
begin
if LeftOffset <> DT_LEFT then
GetTextExtentPoint(DC, theLine, LineLength, {%H-}Points[0]);
if TempBrush = HBRUSH(-1) then
TempBrush := SelectObject(DC, GetStockObject(NULL_BRUSH));
case LeftOffset of
DT_LEFT:
LeftPos := theRect.Left;
DT_CENTER:
LeftPos := theRect.Left + (theRect.Right - theRect.Left) div 2
- Points[0].cX div 2;
DT_RIGHT:
LeftPos := theRect.Right - Points[0].cX;
end;
Pt := Point(0, 0);
// Draw line of Text
if NeedOffsetCalc then
begin
Pt.X := SavedRect.Left;
Pt.Y := SavedRect.Top;
CalculateOffsetWithAngle(TGtkDeviceContext(DC).CurrentFont^.LogFont.lfOrientation, Pt.X, Pt.Y);
end;
TextUtf8Out(DC, LeftPos + Pt.X, TopPos + Pt.Y, theLine, lineLength);
end;
procedure DrawLine(theLine: PChar; LineLength, TopPos: Longint);
var
Points: array[0..1] of TSize;
LogP: TLogPen;
LeftPos: Longint;
begin
if TempBrush = HBRUSH(-1) then
TempBrush := SelectObject(DC, GetStockObject(NULL_BRUSH));
FillByte({%H-}Points[0],SizeOf(Points[0])*2,0);
if LeftOffset <> DT_Left then
GetTextExtentPoint(DC, theLine, LineLength, Points[0]);
case LeftOffset of
DT_LEFT:
LeftPos := theRect.Left;
DT_CENTER:
LeftPos := theRect.Left + (theRect.Right - theRect.Left) div 2
- Points[0].cX div 2;
DT_RIGHT:
LeftPos := theRect.Right - Points[0].cX;
end;
Pt := Point(0, 0);
if NeedOffsetCalc then
begin
Pt.X := SavedRect.Left;
Pt.Y := SavedRect.Top;
CalculateOffsetWithAngle(TGtkDeviceContext(DC).CurrentFont^.LogFont.lfOrientation, Pt.X, Pt.Y);
end;
// Draw line of Text
TextUtf8Out(DC, LeftPos + Pt.X, TopPos + Pt.Y, theLine, LineLength);
// Draw Prefix
if (pIndex > 0) and (pIndex<=LineLength) then
begin
// Create & select pen of font color
if TempPen = HPEN(-1) then
begin
LogP.lopnStyle := PS_SOLID;
LogP.lopnWidth.X := 1;
LogP.lopnColor := GetTextColor(DC);
TempPen := SelectObject(DC, CreatePenIndirect(LogP));
end;
{Get prefix line position}
GetTextExtentPoint(DC, theLine, pIndex - 1, Points[0]);
Points[0].cX := LeftPos + Points[0].cX;
Points[0].cY := TopPos + tm.tmHeight - TM.tmDescent + 1;
GetTextExtentPoint(DC, @aStr[pIndex], UTF8CodepointSize(@aStr[pIndex]), Points[1]);
Points[1].cX := Points[0].cX + Points[1].cX;
Points[1].cY := Points[0].cY;
{Draw prefix line}
Polyline(DC, PPoint(@Points[0]), 2);
end;
end;
begin
if (Str=nil) or (Str[0]=#0) then Exit(0);
//DebugLn(Format('trace:> [TGtk2WidgetSet.DrawText] DC:0x%x, Str:''%s'', Count: %d, Rect = %d,%d,%d,%d, Flags:%d',
// [DC, Str, Count, Rect.Left, Rect.Top, Rect.Right, Rect.Bottom, Flags]));
if not IsValidDC(DC) then Exit(0);
if (Count < -1) or (IsRectEmpty(Rect) and
((Flags and DT_CALCRECT = 0) and (Flags and DT_NOCLIP = 0))) then Exit(0);
// Don't try to use StrLen(Str) in cases count >= 0
// In those cases str is NOT required to have a null terminator !
if Count = -1 then Count := StrLen(Str);
Lines := nil;
NumLines := 0;
TempDC := HDC(-1);
TempPen := HPEN(-1);
TempBrush := HBRUSH(-1);
try
if (Flags and (DT_SINGLELINE or DT_CALCRECT or DT_NOPREFIX or DT_NOCLIP or DT_EXPANDTABS)) =
(DT_SINGLELINE or DT_NOPREFIX or DT_NOCLIP)
then begin
//DebugLn(['TGtk2WidgetSet.DrawText Calc single line']);
CopyRect(theRect, Rect);
SavedRect := Rect;
DrawLineRaw(Str, Count, Rect.Top);
Result := Rect.Bottom - Rect.Top;
Exit;
end;
SetLength(AStr{%H-},Count);
if Count>0 then
System.Move(Str^,AStr[1],Count);
if (Flags and DT_EXPANDTABS) <> 0 then
AStr := StringReplace(AStr, #9, TabString, [rfReplaceAll]);
if (Flags and DT_NOPREFIX) <> DT_NOPREFIX then
pIndex := DeleteAmpersands(AStr)
else
pIndex := -1;
GetTextMetrics(DC, TM{%H-});
DoCalcRect;
Result := theRect.Bottom - theRect.Top;
if (Flags and DT_CALCRECT) = DT_CALCRECT
then begin
//DebugLn(['TGtk2WidgetSet.DrawText Complex Calc']);
CopyRect(Rect, theRect);
exit;
end;
TempDC := SaveDC(DC);
if (Flags and DT_NOCLIP) <> DT_NOCLIP then
begin
if theRect.Right > Rect.Right then
theRect.Right := Rect.Right;
if theRect.Bottom > Rect.Bottom then
theRect.Bottom := Rect.Bottom;
IntersectClipRect(DC, theRect.Left, theRect.Top,
theRect.Right, theRect.Bottom);
end;
if (Flags and DT_SINGLELINE) = DT_SINGLELINE
then begin
// DebugLn(['TGtk2WidgetSet.DrawText Draw single line']);
SavedRect := TheRect;
DrawLine(PChar(AStr), length(AStr), theRect.Top);
Exit; //we're ready
end;
// multiple lines
if Lines = nil then Exit; // nothing to do
if NumLines = 0 then Exit; //
//DebugLn(['TGtk2WidgetSet.DrawText Draw multiline']);
SavedRect := Classes.Rect(0, 0, 0, 0); // no font orientation change if multilined text
for i := 0 to NumLines - 1 do
begin
if theRect.Top > theRect.Bottom then Break;
if ((Flags and DT_EDITCONTROL) = DT_EDITCONTROL)
and (tm.tmHeight > (theRect.Bottom - theRect.Top))
then Break;
if Lines[i] <> nil then
begin
l:=StrLen(Lines[i]);
DrawLine(Lines[i], l, theRect.Top);
dec(pIndex,l+length(LineEnding));
GetTextExtentPoint(DC, Lines[i], l, Size{%H-});
LineHeight := Size.cY;
end
else
LineHeight := TM.tmHeight;
Inc(theRect.Top, LineHeight + TM.tmExternalLeading);// space between lines
end;
finally
Reallocmem(Lines, 0);
if TempBrush <> HBRUSH(-1) then
SelectObject(DC, TempBrush);// DeleteObject not needed here, because it was a default Brush
if TempPen <> HPEN(-1) then
DeleteObject(SelectObject(DC, TempPen));
if TempDC <> HDC(-1) then
RestoreDC(DC, TempDC);
end;
end;
{------------------------------------------------------------------------------
Function: EnableScrollBar
Params: Wnd, wSBflags, wArrows
Returns: Nothing
------------------------------------------------------------------------------}
function TGtk2WidgetSet.EnableScrollBar(Wnd: HWND; wSBflags, wArrows: Cardinal): Boolean;
begin
// TODO: implement TGtk2WidgetSet.EnableScrollBar
Result := False;
end;
{------------------------------------------------------------------------------
Function: EnableWindow
Params: hWnd:
bEnable:
Returns:
If the window was previously disabled, the return value is TRUE.
If the window was not previously disabled, the return value is FALSE.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.EnableWindow(hWnd: HWND; bEnable: Boolean): Boolean;
begin
Result := False;
if hWnd <> 0 then
begin
Result := not GTK_WIDGET_SENSITIVE({%H-}PGtkWidget(HWND));
gtk_widget_set_sensitive({%H-}PGtkWidget(hWnd), bEnable);
InvalidateLastWFPResult(nil, RectFromGdkRect({%H-}PGtkWidget(HWND)^.allocation));
end;
end;
{------------------------------------------------------------------------------
Function: EndPaint
Params:
Returns:
------------------------------------------------------------------------------}
function TGtk2WidgetSet.EndPaint(Handle: hwnd; var PS: TPaintStruct): Integer;
var
Widget: PGtkWidget;
Info: PWidgetInfo;
Control: TWinControl;
begin
Result:=1;
if PS.HDC = 0 then Exit;
if Handle <> 0
then Control := TWinControl(GetLCLObject({%H-}Pointer(Handle)))
else Control := nil;
if (Control <> nil)
and TWSWinControlClass(Control.WidgetSetClass).GetDoubleBuffered(Control)
and not GTK_WIDGET_DOUBLE_BUFFERED({%H-}PGTKWidget(Handle))
then begin
gdk_window_thaw_updates(TGtkDeviceContext(PS.HDC).Drawable);
gdk_window_end_paint (TGtkDeviceContext(PS.HDC).Drawable);
end;
Widget := {%H-}PGtkWidget(Handle);
Info:=GetWidgetInfo(Widget);
if Info<>nil then
dec(Info^.PaintDepth);
ReleaseDC(Handle, PS.HDC);
end;
function TGtk2WidgetSet.EnumDisplayMonitors(hdc: HDC; lprcClip: PRect;
lpfnEnum: MonitorEnumProc; dwData: LPARAM): LongBool;
var
i: integer;
begin
Result := True;
for i := 0 to gdk_screen_get_n_monitors(gdk_screen_get_default) - 1 do
begin
Result := Result and lpfnEnum(i + 1, 0, nil, dwData);
if not Result then break;
end;
end;
{.$define VerboseEnumFonts}
{$IFDEF GTK2OLDENUMFONTFAMILIES}
function TGtk2WidgetSet.EnumFontFamilies(DC: HDC; Family: Pchar;
EnumFontFamProc: FontEnumProc; LParam:Lparam):longint;
var
xFonts: PPChar;
FontList: TStringList;
EnumLogFont: TEnumLogFont;
Metric: TNewTextMetric;
I,N: Integer;
tmp: String;
FontType: Integer;
begin
result := 0;
if not Assigned(EnumFontFamProc) then begin
result := 2;
DebugLn('EnumFontFamProc Callback not set');
// todo: raise exception?
exit;
end;
FontList := TStringlist.Create;
try
if Family<>'' then
Tmp := '-*-'+Family+'-*-*-*-*-*-*-*-*-*-*-*-*'
else
Tmp := '-*'; // get rid of aliases
{$ifdef VerboseEnumFonts}
WriteLn('Looking for fonts matching: ', tmp);
{$endif}
{$ifdef HasX}
XFonts := XListFonts(gdk_display, pchar(Tmp), 10000, @N);
{$else}
{$IFDEF VerboseGtkToDos}{$warning implement getting XFonts for this OS}{$ENDIF}
XFonts := nil;
N:=0;
{$endif}
try
for I := 0 to N - 1 do
if XFonts[I] <> nil then begin
Tmp := ExtractFamilyFromXLFDName(XFonts[I]);
{$ifdef VerboseEnumFonts}
WriteLn(I:5,' [', tmp, '] Font=',XFonts[i]);
{$endif}
if Tmp <> '' then begin
if family='' then begin
// get just the font names
if FontList.IndexOf(Tmp) < 0 then begin
EnumLogFont.elfLogFont := XLFDNameToLogFont(XFonts[i]);
FillChar(Metric, SizeOf(Metric), #0);
FontType := 0; // todo: GetFontTypeFromXLDF or FontId
EnumLogFont.elfFullName := '';
EnumFontFamProc(EnumLogFont, Metric, FontType, Lparam);
FontList.Append(Tmp);
end;
end else begin
EnumLogFont.elfLogFont := XLFDNameToLogFont(XFonts[i]);
EnumlogFont.elfFullname := '';
EnumLogFont.elfStyle := '';
FillChar(Metric, SizeOf(Metric), #0);
FontType := 0; // todo: GetFontTypeFromXLDF or FontId
EnumFontFamProc(EnumLogFont, Metric, FontType, Lparam);
end;
end;
end;
finally
{$ifdef HasX}
XFreeFontNames(XFonts);
{$endif}
end;
finally
Fontlist.Free;
end;
end;
function TGtk2WidgetSet.EnumFontFamiliesEx(DC: HDC; lpLogFont: PLogFont;
Callback: FontEnumExProc; Lparam:LParam; Flags: dword): longint;
type
TXLFD=record
Foundry: string[15];
Family, CharsetReg, CharsetCod: string[32];
WeightName,widthName,StyleName: string[20];
Slant: string[5];
PixelSize,PointSize,ResX,ResY: Integer;
end;
var
Xlfd: TXLFD;
CharsetFilter: TStringList;
PitchFilter: TStringList;
EnumLogFont: TEnumLogFontEx;
Metric: TNewTextMetricEx;
function ParseXLFDFont(const font: string): boolean;
function MyStrToIntDef(const s: string; def: integer): integer;
begin
result := StrToIntDef(s, Def);
if result=0 then
result := def
end;
begin
result := IsFontNameXLogicalFontDesc(font);
fillchar(Xlfd, SizeOf(Xlfd), 0);
if result then with Xlfd do begin
Foundry := ExtractXLFDItem(Font, XLFD_FOUNDRY);
Family := ExtractXLFDItem(Font, XLFD_FAMILY);
CharsetReg := ExtractXLFDItem(Font, XLFD_CHARSET_REG);
CharSetCod := ExtractXLFDItem(Font, XLFD_CHARSET_COD);
WeightName := ExtractXLFDItem(Font, XLFD_WEIGHTNAME);
Slant := ExtractXLFDItem(Font, XLFD_SLANT);
WidthName := ExtractXLFDItem(Font, XLFD_WIDTHNAME);
StyleName := ExtractXLFDItem(Font, XLFD_STYLENAME);
ResX := MyStrToIntDef(ExtractXLFDItem(Font, XLFD_RESX), 72);
ResY := MyStrToIntDef(ExtractXLFDItem(Font, XLFD_RESX), 72);
PixelSize := StrToIntDef(ExtractXLFDItem(Font, XLFD_PIXELSIZE), 0);
PointSize := StrToIntDef(ExtractXLFDItem(Font, XLFD_POINTSIZE), 0);
end;
end;
function XLFDToFontStyle: string;
var
s: string;
begin
result := xlfd.WeightName;
s :=lowercase(xlfd.Slant);
if s='i' then result := result + ' '+ 'italic' else
if s='o' then result := result + ' '+ 'oblique' else
if s='ri' then result := result + ' '+ 'reverse italic' else
if s='ro' then result := result + ' '+ 'reverse oblique'
else begin
if (S<>'r')and(S<>'') then
result := result + ' ' + S;
end;
end;
procedure QueueCharsetFilter(Charset: byte);
var
i: integer;
rec: PCharsetEncodingRec;
s: string;
begin
for i:=0 to CharsetEncodingList.count-1 do begin
Rec := CharsetEncodingList[i];
if (Rec=nil) or (Rec^.CharSet<>Charset) or (not Rec^.EnumMap) then
continue;
s := Rec^.CharSetReg;
if Rec^.CharsetRegPart then
s := s + '*';
s := s + '-' + Rec^.CharSetCod;
if Rec^.CharsetCodPart then
s := s + '*';
CharsetFilter.Add(s);
end;
end;
procedure QueuePitchFilter(Pitch: byte);
begin
if pitch and FIXED_PITCH = FIXED_PITCH then begin
PitchFilter.Add('m');
PitchFilter.Add('c'); // character cell it's also fixed pitch
end;
if pitch and VARIABLE_PITCH = VARIABLE_PITCH then
PitchFilter.Add('p');
if pitch and MONO_FONT = MONO_FONT then
PitchFilter.Add('m');
if PitchFilter.Count=0 then
PitchFilter.Add('*');
end;
function XLFDToCharset: byte;
const
CharsetPriority: array[1..19] of byte =
(
SYMBOL_CHARSET, MAC_CHARSET, SHIFTJIS_CHARSET,
HANGEUL_CHARSET, JOHAB_CHARSET, GB2312_CHARSET,
CHINESEBIG5_CHARSET, GREEK_CHARSET, TURKISH_CHARSET,
VIETNAMESE_CHARSET, HEBREW_CHARSET, ARABIC_CHARSET,
BALTIC_CHARSET, RUSSIAN_CHARSET, THAI_CHARSET,
EASTEUROPE_CHARSET, OEM_CHARSET, FCS_ISO_10646_1,
ANSI_CHARSET
);
var
i,n: integer;
rec: PCharsetEncodingRec;
begin
for i := Low(CharsetPriority) to High(CharsetPriority) do
for n:= 0 to CharsetEncodingList.count-1 do begin
rec := CharsetEncodingList[n];
if (rec=nil) or (rec^.CharSet<>CharsetPriority[i]) then
continue;
// try to match registry part
if rec^.CharSetReg<>'*' then begin
if rec^.CharsetRegPart then begin
if pos(rec^.CharSetReg, xlfd.CharsetReg)=0 then
continue;
end else begin
if AnsiCompareText(Rec^.CharSetReg, xlfd.CharsetReg) <> 0 then
continue;
end;
end;
// try to match coding part
if rec^.CharSetCod<>'*' then begin
if rec^.CharsetCodPart then begin
if pos(rec^.CharSetCod, xlfd.CharsetCod)=0 then
continue;
end else begin
if AnsiCompareText(Rec^.CharSetCod, xlfd.CharsetCod) <> 0 then
continue;
end;
end;
// this one is good enought to match bot registry and encondig part
result := CharsetPriority[i];
exit;
end;
result := DEFAULT_CHARSET;
end;
function XLFDCharsetToScript: string;
begin
result := xlfd.CharsetReg + '-' + xlfd.CharsetCod;
end;
function FoundryAndFamilyFilter(const FaceName: string): string;
var
foundry,family: string;
i: LongInt;
begin
if FaceName='' then begin
family := '*';
foundry := '*';
end else begin
family := FaceName;
// look for foundry encoded in family name
i := pos(FOUNDRYCHAR_OPEN, family);
if i<>0 then begin
Foundry := copy(Family, i+1, Length(Family));
family := trim(copy(family, 1, i-1));
i := pos(FOUNDRYCHAR_CLOSE, Foundry);
if i<>0 then
Delete(Foundry, i, Length(Foundry))
else
; // ill formed but it's ok.
end else
Foundry := '*';
end;
result := Foundry+'-'+Family;
end;
function XLFDFamilyFace: string;
begin
with xlfd do
if (Length(Foundry)>0) and (Length(Family) + length(Foundry) + 3 < 31) then
result := Family + ' '+ FOUNDRYCHAR_OPEN + Foundry + FOUNDRYCHAR_CLOSE
else
result := Family;
end;
function XLFDToFontType: integer;
begin
if ((xlfd.PointSize=0) and (xlfd.PixelSize=0))
or ((xlfd.PointSize=120) and (xlfd.PixelSize=17)) // see bug 16298
then
result := TRUETYPE_FONTTYPE
else
result := RASTER_FONTTYPE or DEVICE_FONTTYPE;
end;
// process the current xlfd font, if user returns 0 from callback finish
function ProcessXFont(const index: integer; const font: string;
FontList: TStringList): boolean;
var
FontType: Integer;
tmp: string;
FullSearch: boolean;
begin
FullSearch := ( lpLogFont^.lfFaceName = '');
result := false;
with xlfd, EnumLogFont do
if FullSearch then begin
//
// quick enumeration of fonts, make sure this is
// documented because only some fields are filled !!!
//
Foundry := ExtractXLFDItem(Font, XLFD_FOUNDRY);
Family := ExtractXLFDItem(Font, XLFD_FAMILY);
tmp := XLFDFamilyFace();
if FontList.IndexOf(tmp) < 0 then begin
PixelSize := StrToIntDef(ExtractXLFDItem(Font, XLFD_PIXELSIZE), 0);
PointSize := StrToIntDef(ExtractXLFDItem(Font, XLFD_POINTSIZE), 0);
CharsetReg := ExtractXLFDItem(Font, XLFD_CHARSET_REG);
CharsetCod := ExtractXLFDItem(Font, XLFD_CHARSET_COD);
FontType := XLFDToFontType();
elfLogFont.lfCharSet := XLFDToCharset();
elfLogFont.lfFaceName := tmp;
result := Callback(EnumLogFont, Metric, FontType, LParam)=0;
FontList.Append(tmp);
end;
end else
if ParseXLFDFont(Font) then begin
//
// slow enumeration of fonts, only if face is present
//
// family
tmp := XLFDFamilyFace();
{$ifdef verboseEnumFonts}
DebugLn(dbgs(index),' face=', tmp, ' Font=', Font);
{$endif}
//if FontList.IndexOf(tmp) < 0 then begin
// Fonttype
FontType := XLFDToFontType();
// LogFont
elfLogFont := XLFDNameToLogFont(Font);
elfLogFont.lfFaceName := tmp;
elfLogFont.lfCharSet := XLFDToCharset();
// from logfont
elfStyle := XLFDToFontStyle();
elfScript := XLFDCharsetToScript();
// tempted to feed here full xlfd, but 63 chars might be to small
if Foundry = '' then
elfFullName := Family
else
elfFullName := Foundry + ' ' + Family ;
// Metric
//
fillchar(metric.ntmeFontSignature,
sizeOf(metric.ntmeFontSignature), 0);
with metric.ntmentm do begin
tmheight := elfLogFont.lfHeight;
tmAveCharWidth := elfLogFont.lfWidth;
tmWeight := elfLogFont.lfWeight;
tmDigitizedAspectX := ResX;
tmDigitizedAspectY := ResY;
tmItalic := elfLogFont.lfItalic;
tmUnderlined := elfLogFont.lfUnderline;
tmStruckOut := elfLogFont.lfStrikeOut;
tmPitchAndFamily := elfLogFont.lfPitchAndFamily;
tmCharSet := elfLogFont.lfCharSet;
// todo fields
tmMaxCharWidth := elfLogFont.lfWidth; // todo
tmAscent := 0; // todo
tmDescent := 0; // todo
tmInternalLeading := 0; // todo
tmExternalLeading := 0; // todo
tmOverhang := 0; // todo;
tmFirstChar := ' '; // todo, atm ascii
tmLastChar := #255; // todo, atm ascii
tmDefaultChar := '.'; // todo, atm dot
tmBreakChar := ' '; // todo, atm space
ntmFlags := 0; // todo combination of NTM_XXXX constants
ntmSizeEM := tmHeight; // todo
ntmCellHeight := ntmSizeEM; // todo
ntmAvgWidth := ntmSizeEM; // todo
end; // with metric.ntmentm do ...
// do callback
result := Callback(EnumLogFont, Metric, FontType, LParam) = 0;
FontList.Append(tmp);
//end; // if not FullSearch or (FontList.IndexOf(tmp) < 0 then ...
end; // with xlfd, EnumLogFont do ...
end;
var
xFonts: PPChar;
FontList: TStringList;
I,J,K,N: Integer;
Tmp,FandF: String;
begin
result := 0;
// initial checks
if not Assigned(Callback) then begin
result := 2;
DebugLn('EnumFontFamiliesEx: EnumFontFamProcEx Callback not set');
// todo: raise exception?
exit;
end;
if not Assigned(lpLogFont) then begin
result := 3;
DebugLn('EnumFontFamiliesEx: lpLogFont not set');
// todo: enumerate all fonts?
exit;
end;
// foundry and family filter
FandF := FoundryAndFamilyFilter(lpLogFont^.lfFaceName);
FontList := TStringlist.Create;
CharSetFilter := TStringList.Create;
PitchFilter := TStringList.Create;
PitchFilter.Duplicates := dupIgnore;
try
QueueCharSetFilter(lpLogFont^.lfCharSet);
QueuePitchFilter(lpLogFont^.lfPitchAndFamily);
{$ifdef verboseEnumFonts}
for j:=0 to CharSetFilter.Count-1 do begin
// pitch filter is guaranteed to have at least one element
for k:=0 to PitchFilter.Count-1 do begin
tmp := '-'+FAndF+'-*-*-*-*-*-*-*-*-'+PitchFilter[k]+'-*-'+CharSetFilter[j];
DebugLn('EnumFontFamiliesEx: will enumerate fonts matching: ', tmp);
end;
end;
{$endif}
for j:=0 to CharSetFilter.Count-1 do begin
for k:=0 to PitchFilter.Count-1 do begin
tmp := '-'+FAndF+'-*-*-*-*-*-*-*-*-'+PitchFilter[k]+'-*-'+CharSetFilter[j];
{$ifdef HasX}
XFonts := XListFonts(gdk_display, pchar(Tmp), 10000, @N);
{$else}
{$IFDEF VerboseGtkToDos}{$warning implement getting XFonts for this OS}{$ENDIF}
XFonts := nil;
N:=0;
{$endif}
try
{$ifdef VerboseEnumFonts}
DebugLn('EnumFontFamiliesEx: found ',dbgs(N),' fonts matching: ', tmp);
{$endif}
for i:=0 to N-1 do
if XFonts[i]<>nil then
if ProcessXFont(i, XFonts[i], FontList) then
break;
finally
{$ifdef HasX}
XFreeFontNames(XFonts);
{$endif}
end;
end;
end;
finally
PitchFilter.Free;
Fontlist.Free;
CharSetFilter.Free;
end;
end;
{$ELSE} // pure pango font families
function TGtk2WidgetSet.EnumFontFamiliesEx(DC: HDC; lpLogFont: PLogFont;
Callback: FontEnumExProc; Lparam:LParam; Flags: dword): longint;
type
TPangoFontFaces = packed record
FamilyName: String;
Faces: Array of String;
end;
PPangoFontFaces = Array of TPangoFontFaces;
var
i: Integer;
FontType: Integer;
EnumLogFont: TEnumLogFontEx;
Metric: TNewTextMetricEx;
FontList: TStringList;
Faces: PPangoFontFaces;
AStyle: String;
StylesCount: Integer;
StylesList: TStringList;
y: Integer;
CharsetList: TByteList;
CS: Byte;
function Gtk2GetFontFamiliesDefault(var AList: TStringList): Integer;
var
i, j: Integer;
AFamilies: PPPangoFontFamily;
AFaces: PPPangoFontFace;
ANumFaces: Integer;
PContext: PPangoContext;
begin
AList.Clear;
SetLength(Faces, 0);
Result := -1;
AFamilies := nil;
PContext := gdk_pango_context_get;
pango_context_list_families(PContext, @AFamilies, @Result);
SetLength(Faces, Result);
for i := 0 to Result - 1 do
begin
j := AList.Add(StrPas(pango_font_family_get_name(AFamilies[i])));
AList.Objects[j] := TObject(PtrUInt(pango_font_family_is_monospace(AFamilies[i])));
Faces[i].FamilyName := AList[j];
AFaces := nil;
pango_font_family_list_faces(AFamilies[i], @AFaces, @ANumFaces);
SetLength(Faces[i].Faces, ANumFaces);
for j := 0 to ANumFaces - 1 do
Faces[i].Faces[j] := StrPas(pango_font_face_get_face_name(AFaces[j]));
g_free(AFaces);
end;
g_free(AFamilies);
g_object_unref(PContext);
end;
function Gtk2GetFontFamilies(var List: TStringList;
const APitch: Byte;
const AFamilyName: String;
const {%H-}AWritingSystem: Byte): Integer;
var
StrLst: TStringList;
NewList: TStringList;
S: String;
j: integer;
begin
Result := -1;
StrLst := TStringList.Create;
NewList := TStringList.Create;
try
Gtk2GetFontFamiliesDefault(StrLst);
for j := 0 to StrLst.Count - 1 do
begin
S := StrLst[j];
if APitch <> DEFAULT_PITCH then
begin
case APitch of
FIXED_PITCH, MONO_FONT:
begin
if StrLst.Objects[j] <> nil then
NewList.Add(S);
end;
VARIABLE_PITCH:
begin
if StrLst.Objects[j] = nil then
NewList.Add(S);
end;
end;
end else
NewList.Add(S);
end;
if AFamilyName <> '' then
begin
for j := NewList.Count - 1 downto 0 do
begin
S := NewList[j];;
if S <> AFamilyName then
NewList.Delete(J);
end;
end;
for j := 0 to NewList.Count - 1 do
begin
S := NewList[j];
List.Add(S);
end;
Result := List.Count;
finally
StrLst.Free;
NewList.Free;
end;
end;
function GetStyleAt(AIndex: Integer): String;
var
S: String;
begin
Result := '';
if (AIndex >= 0) and (AIndex < StylesList.Count) then
begin
S := StylesList[AIndex];
Result := S;
end;
end;
function FillLogFontA(const AIndex: Integer; var ALogFontA: TLogFontA;
var {%H-}AMetric: TNewTextMetricEx; var {%H-}AFontType: Integer;
out AStyle: String): Integer;
var
Font: PPangoFontDescription;
FontStyle: TPangoStyle;
FontWeight: TPangoWeight;
S: String;
i: Integer;
begin
S := FontList[AIndex];
Font := pango_font_description_from_string(PChar(S));
FontStyle := pango_font_description_get_style(Font);
FontWeight := pango_font_description_get_weight(Font);
ALogFontA.lfItalic := Byte(FontStyle = PANGO_STYLE_ITALIC);
// keep newer pango compat to LCL
if FontWeight = 380 {PANGO_WEIGHT_BOOK as of pango 1.24} then
FontWeight := PANGO_WEIGHT_NORMAL
else
if FontWeight = 1000 {PANGO_WEIGHT_ULTRAHEAVY as of pango 1.24} then
FontWeight := PANGO_WEIGHT_HEAVY;
ALogFontA.lfWeight := FontWeight;
ALogFontA.lfHeight := pango_font_description_get_size(Font);
if not pango_font_description_get_size_is_absolute(Font) then
ALogFontA.lfHeight := PANGO_PIXELS(ALogFontA.lfHeight);
// pango does not have underline and strikeout params for font
// ALogFontA.lfUnderline := ;
// ALogFontA.lfStrikeOut := ;
StylesList.Clear;
for i := High(Faces[AIndex].Faces) downto 0 do
StylesList.Add(Faces[AIndex].Faces[i]);
AStyle := '';
Result := StylesList.Count;
if StylesList.Count > 0 then
AStyle := GetStyleAt(0);
// current pango support in fpc is really poor, we cannot
// get PangoScript since it's in pango >= 1.4
// FillCharsetListForFont()
end;
begin
Result := 0;
{$ifdef VerboseEnumFonts}
WriteLn('[TGtk2WidgetSet.EnumFontFamiliesEx] Charset=',lpLogFont^.lfCharSet,
' face ',lpLogFont^.lfFaceName,' pitchAndFamily=',lpLogFont^.lfPitchAndFamily);
{$endif}
Result := 0;
Metric.ntmentm.ntmAvgWidth := 0; // just to shutup compiler
if (lpLogFont^.lfCharSet = DEFAULT_CHARSET) and
(lpLogFont^.lfFaceName= '') and
(lpLogFont^.lfPitchAndFamily = 0) then
begin
FontType := 0;
FontList := TStringList.create;
try
if Gtk2GetFontFamiliesDefault(FontList) > 0 then
begin
for i := 0 to FontList.Count - 1 do
begin
EnumLogFont.elfLogFont.lfFaceName := FontList[i];
Result := Callback(EnumLogFont, Metric, FontType, LParam);
end;
end;
finally
FontList.free;
end;
end else
begin
Result := 0;
FontType := TRUETYPE_FONTTYPE;
FontList := TStringList.Create;
StylesList := TStringList.Create;
CharsetList := TByteList.Create;
for i := 0 to CharsetEncodingList.Count - 1 do
begin
CS := TCharSetEncodingRec(CharsetEncodingList.Items[i]^).CharSet;
if CharsetList.IndexOf(CS) = -1 then
CharsetList.Add(CS);
end;
try
if Gtk2GetFontFamilies(FontList, lpLogFont^.lfPitchAndFamily,
lpLogFont^.lfFaceName, lpLogFont^.lfCharSet) > 0 then
begin
for i := 0 to FontList.Count - 1 do
begin
EnumLogFont.elfLogFont.lfFaceName := FontList[i];
EnumLogFont.elfLogFont.lfPitchAndFamily := lpLogFont^.lfPitchAndFamily;
EnumLogFont.elfFullName := FontList[i];
StylesCount := FillLogFontA(i, EnumLogFont.elfLogFont, Metric, FontType,
AStyle);
EnumLogFont.elfStyle := AStyle;
if CharSetList.Count > 0 then
EnumLogFont.elfLogFont.lfCharSet := CharsetList.Items[0];
Result := Callback(EnumLogFont, Metric, FontType, LParam);
for y := 1 to StylesCount - 1 do
begin
AStyle := GetStyleAt(y);
EnumLogFont.elfStyle := AStyle;
Result := Callback(EnumLogFont, Metric, FontType, LParam);
end;
for y := 1 to CharSetList.Count - 1 do
begin
EnumLogFont.elfLogFont.lfCharSet := CharsetList.Items[y];
Result := Callback(EnumLogFont, Metric, FontType, LParam);
end;
end;
end;
finally
CharSetList.Free;
StylesList.Free;
FontList.Free;
end;
end;
end;
{$ENDIF}
{------------------------------------------------------------------------------
Method: Ellipse
Params: X1, Y1, X2, Y2
Returns: Nothing
Use Ellipse to draw a filled circle or ellipse.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.Ellipse(DC: HDC; x1, y1, x2, y2: Integer): Boolean;
var
DevCtx: TGtkDeviceContext absolute DC;
Left, Top, Width, Height: Integer;
DCOrigin: TPoint;
begin
Result := IsValidDC(DC);
if not Result then Exit;
if DevCtx.HasTransf then
DevCtx.TransfRect(X1, Y1, X2, Y2);
CalculateLeftTopWidthHeight(X1, Y1, X2, Y2, Left, Top, Width, Height);
if (Width = 0) or (Height = 0) then Exit(True);
// X2, Y2 is not part of the rectangle
dec(Width);
dec(Height);
// first draw interior in brush color
DCOrigin := DevCtx.Offset;
{$IFDEF DebugGDKTraps}
BeginGDKErrorTrap;
{$ENDIF}
if not DevCtx.IsNullBrush then
begin
DevCtx.SelectBrushProps;
DevCtx.RemovePixbuf;
gdk_draw_arc(DevCtx.Drawable, DevCtx.GC, 1,
Left+DCOrigin.X, Top+DCOrigin.Y, Width, Height, 0, 360 shl 6);
end;
// Draw outline
DevCtx.SelectPenProps;
if (dcfPenSelected in DevCtx.Flags) then
begin
Result := True;
if not DevCtx.IsNullPen then
begin
DevCtx.RemovePixbuf;
gdk_draw_arc(DevCtx.Drawable, DevCtx.GC, 0,
Left+DCOrigin.X, Top+DCOrigin.Y, Width, Height, 0, 360 shl 6);
end;
end
else
Result := False;
{$IFDEF DebugGDKTraps}
EndGDKErrorTrap;
{$ENDIF}
end;
{------------------------------------------------------------------------------
Method: EqualRgn
Params: Rgn1: HRGN; Rgn2: HRGN
Returns: True if the two regions are equal
Checks the two specified regions to determine whether they are identical. The
function considers two regions identical if they are equal in size and shape.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.EqualRgn(Rgn1: HRGN; Rgn2: HRGN): Boolean;
var
AGdiObject: PGdiObject absolute Rgn1;
BGdiObject: PGdiObject absolute Rgn2;
begin
Result := IsValidGDIObject(Rgn1) and IsValidGDIObject(Rgn2);
if Result then
Result := gdk_region_equal(AGdiObject^.GDIRegionObject,
BGdiObject^.GDIRegionObject);
end;
{------------------------------------------------------------------------------
Function: ExcludeClipRect
Params: dc: hdc; Left, Top, Right, Bottom : Integer
Returns: integer
Subtracts all intersecting points of the passed bounding rectangle
(Left, Top, Right, Bottom) from the Current clipping region in the
device context (dc).
The result can be one of the following constants
Error
NullRegion
SimpleRegion
ComplexRegion
------------------------------------------------------------------------------}
function TGtk2WidgetSet.ExcludeClipRect(dc: hdc;
Left, Top, Right, Bottom : Integer) : Integer;
begin
Result := Inherited ExcludeClipRect(DC, Left, Top, Right, Bottom);
end;
function TGtk2WidgetSet.ExtCreatePen(dwPenStyle, dwWidth: DWord;
const lplb: TLogBrush; dwStyleCount: DWord; lpStyle: PDWord): HPEN;
var
GObject: PGdiObject;
i: integer;
begin
GObject := NewGDIObject(gdiPen);
GObject^.UnTransfPenWidth := 0;
GObject^.IsExtPen := True;
GObject^.GDIPenStyle := dwPenStyle;
GObject^.GDIPenWidth := dwWidth;
SetGDIColorRef(GObject^.GDIPenColor, lplb.lbColor);
GObject^.GDIPenDashesCount := dwStyleCount;
if dwStyleCount > 0 then
begin
GetMem(GObject^.GDIPenDashes, dwStyleCount * SizeOf(gint8));
for i := 0 to dwStyleCount - 1 do
GObject^.GDIPenDashes[i] := lpStyle[i];
end;
Result := HPEN({%H-}PtrUInt(GObject));
end;
{------------------------------------------------------------------------------
Function: ExtSelectClipRGN
Params: dc, RGN, Mode
Returns: integer
Combines the passed Region with the current clipping region in the device
context (dc), using the specified mode.
The Combine Mode can be one of the following:
RGN_AND : all points which are in both regions
RGN_COPY : an exact copy of the source region, same as SelectClipRGN
RGN_DIFF : all points which are in the Clipping Region but
not in the Source.(Clip - RGN)
RGN_OR : all points which are in either the Clip Region or
in the Source.(Clip + RGN)
RGN_XOR : all points which are in either the Clip Region
or in the Source, but not in both.
The result can be one of the following constants
Error
NullRegion
SimpleRegion
ComplexRegion
------------------------------------------------------------------------------}
function TGtk2WidgetSet.ExtSelectClipRGN(dc: hdc; rgn : hrgn;
Mode : Longint) : Integer;
var
Clip,
Tmp : hRGN;
X, Y : Longint;
begin
Result := SIMPLEREGION;
if not IsValidDC(DC) then
Result := ERROR
else with TGtkDeviceContext(DC) do
begin
//DebugLn('TGtk2WidgetSet.ExtSelectClipRGN A ClipRegValid=',dbgs(DCClipRegionValid(DC)),
// ' Mode=',dbgs(Mode),' RGN=',GDKRegionAsString(PGdiObject(RGN)^.GDIRegionObject));
if ClipRegion = nil then
begin
// there is no clipping region in the DC
case Mode of
RGN_COPY:
begin
Result := RegionType({%H-}PGdiObject(RGN)^.GDIRegionObject);
If Result <> ERROR then
Result := SelectClipRGN(DC, RGN);
end;
RGN_OR,
RGN_XOR,
RGN_AND,
RGN_DIFF:
begin
// get existing clip
if Drawable=nil then
Clip:=CreateEmptyRegion
else begin
GDK_Window_Get_Size(Drawable, @X, @Y);
Clip := CreateRectRGN(-Offset.X, -Offset.Y, X - Offset.X, Y - Offset.Y);
end;
// create target clip
Tmp := CreateEmptyRegion;
// combine
Result := CombineRGN(Tmp, Clip, RGN, Mode);
// commit
//DebugLn('TGtk2WidgetSet.ExtSelectClipRGN B ClipRegValid=',dbgs(ClipRegion),' TmpRGN=',GDKRegionAsString(PGdiObject(Tmp)^.GDIRegionObject));
SelectClipRGN(DC, Tmp);
// clean up
DeleteObject(Clip);
DeleteObject(Tmp);
end;
end;
end
else
Result := inherited ExtSelectClipRGN(dc, rgn, mode);
end;
end;
{------------------------------------------------------------------------------
Function: ExtTextOut
Params: none
Returns: Nothing
gdk_drawable_get_size(pixmap, @Width, @Height);
------------------------------------------------------------------------------}
function TGtk2WidgetSet.ExtTextOut(DC: HDC; X, Y: Integer; Options: Longint;
Rect: PRect; Str: PChar; Count: Longint; Dx: PInteger): Boolean;
var
DevCtx: TGtkDeviceContext absolute DC;
LineStart, LineEnd, StrEnd: PChar;
Width, Height: Integer;
TopY, LineLen, LineHeight, SavedDC: Integer;
TxtPt: TPoint;
DCOrigin: TPoint;
Foreground, BackgroundColor: PGDKColor;
CurDx: PInteger;
CurStr: PChar;
R: TRect;
procedure DoTextOut(X,Y : Integer; Str: Pchar; CurCount: Integer);
var
CurScreenX: LongInt;
CharLen: LongInt;
begin
if (Dx <> nil) then
begin
CurScreenX := X;
while CurCount > 0 do
begin
CharLen := UTF8CodepointSize(CurStr);
DevCtx.DrawTextWithColors(CurStr, CharLen, CurScreenX, Y, Foreground, BackgroundColor);
inc(CurScreenX, CurDx^);
inc(CurDx);
inc(CurStr, CharLen);
dec(CurCount, CharLen);
end;
end
else
DevCtx.DrawTextWithColors(Str, Count, X, Y, Foreground, BackgroundColor);
end;
begin
//DebugLn(['TGtk2WidgetSet.ExtTextOut X=',X,' Y=',Y,' Str="',copy(Str,1,Count),'" Count=',Count,' DX=',dbgs(DX)]);
//DebugLn(Format('trace:> [TGtk2WidgetSet.ExtTextOut] DC:0x%x, X:%d, Y:%d, Options:%d, Str:''%s'', Count: %d', [DC, X, Y, Options, Str, Count]));
Result := IsValidDC(DC);
if not Result then Exit;
if DevCtx.GC <> nil then; // create GC
if ((Options and (ETO_OPAQUE + ETO_CLIPPED)) <> 0) and (Rect = nil) then
begin
R := RectFromGdkRect(DevCtx.ClipRect);
Types.OffsetRect(R, -R.Left, -R.Top);
Types.OffsetRect(R, X, Y);
DrawText(DC, Str, Count, R, DT_SINGLELINE or DT_CALCRECT);
Rect := @R;
end;
BackgroundColor := nil;
// to reduce flickering calculate first and then paint
DCOrigin := DevCtx.Offset;
if (Options and ETO_CLIPPED) <> 0 then
begin
SavedDC := SaveDC(DC);
IntersectClipRect(DC, Rect^.Left, Rect^.Top, Rect^.Right, Rect^.Bottom);
end;
if DevCtx.HasTransf then
begin
if Assigned(Rect) then
Rect^ := DevCtx.TransfRectIndirect(Rect^);
DevCtx.TransfPoint(X, Y);
end;
LineLen := FindLineLen(Str,Count);
TopY := Y;
UpdateDCTextMetric(DevCtx);
TxtPt.X := X + DCOrigin.X;
LineHeight := DevCtx.DCTextMetric.TextMetric.tmHeight;
TxtPt.Y := TopY + DCOrigin.Y;
DevCtx.SelectedColors := dcscCustom;
if ((Options and ETO_OPAQUE) <> 0) then
begin
Width := Rect^.Right - Rect^.Left;
Height := Rect^.Bottom - Rect^.Top;
EnsureGCColor(DC, dccCurrentBackColor, True, False);
DevCtx.RemovePixbuf;
gdk_draw_rectangle(DevCtx.Drawable, DevCtx.GC, 1,
Rect^.Left+DCOrigin.X, Rect^.Top+DCOrigin.Y,
Width, Height);
end;
if (DevCtx.BkMode = OPAQUE) then
begin
AllocGDIColor(DC, @DevCtx.CurrentBackColor);
BackGroundColor := @DevCtx.CurrentBackColor.Color;
end;
EnsureGCColor(DC, dccCurrentTextColor, True, False);
Foreground := nil;//StyleForegroundColor(CurrentTextColor.ColorRef, nil);
CurDx:=Dx;
CurStr:=Str;
LineStart:=Str;
if LineLen < 0 then
begin
LineLen:=Count;
if Count> 0 then
DoTextOut(TxtPt.X, TxtPt.Y, LineStart, LineLen);
end else
begin //write multiple lines
StrEnd := Str + Count;
while LineStart < StrEnd do
begin
LineEnd := LineStart + LineLen;
if LineLen>0 then
DoTextOut(TxtPt.X, TxtPt.Y, LineStart, LineLen);
inc(TxtPt.Y, LineHeight);
//writeln('TGtk2WidgetSet.ExtTextOut ',LineHeight,' ',DevCtx.DCTextMetric.TextMetric.tmAscent,' ',DevCtx.DCTextMetric.TextMetric.tmDescent);
LineStart := LineEnd + 1; // skip #13
if (LineStart<StrEnd) and (LineStart^ in [#10,#13])
and (LineStart^ <> LineEnd^) then
inc(LineStart); // skip #10
Count := StrEnd - LineStart;
LineLen := FindLineLen(LineStart, Count);
if LineLen < 0 then
LineLen := Count;
end;
end;
if (Options and ETO_CLIPPED) <> 0 then
RestoreDC(DC, SavedDC);
Result := True;
//DebugLn(Format('trace:< [TGtk2WidgetSet.ExtTextOut] DC:0x%x, X:%d, Y:%d, Options:%d, Str:''%s'', Count: %d', [DC, X, Y, Options, Str, Count]));
end;
{------------------------------------------------------------------------------
Function: FillRect
Params: none
Returns: Nothing
The FillRect function fills a rectangle by using the specified brush.
This function includes the left and top borders, but excludes the right and
bottom borders of the rectangle.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.FillRect(DC: HDC; const Rect: TRect; Brush: HBRUSH): Boolean;
var
TempBr: HBrush;
begin
Result := IsValidDC(DC) and IsValidGDIObject(Brush);
if not Result or IsRectEmpty(Rect) then
Exit;
if ({%H-}PGdiObject(Brush)^.GDIBrushFill = GDK_TILED) and (TGtkDeviceContext(DC).BkMode = OPAQUE) then
begin
// fill a rectangle with a solid back color first
TempBr := CreateSolidBrush(TGtkDeviceContext(DC).CurrentBackColor.ColorRef);
TGtkDeviceContext(DC).FillRect(Rect, TempBr, True);
DeleteObject(TempBr);
end;
Result := TGtkDeviceContext(DC).FillRect(Rect, Brush, True);
//DebugLn(Format('trace:< [TGtk2WidgetSet.FillRect] DC:0x%x; Rect: ((%d,%d)(%d,%d)); brush: %x', [Integer(DC), Rect.left, rect.top, rect.right, rect.bottom, brush]));
end;
{------------------------------------------------------------------------------
Function: FillRgn
Params: DC: HDC; RegionHnd: HRGN; hbr: HBRUSH
Returns: True if the function succeeds
Fills a region by using the specified brush
------------------------------------------------------------------------------}
function TGtk2WidgetSet.FillRgn(DC: HDC; RegionHnd: HRGN; hbr: HBRUSH): Bool;
var
GtkDC: Integer;
OldRgn: PGdkRegion;
DevCtx: TGtkDeviceContext absolute DC;
ARect: TRect;
CRect : TGDKRectangle;
hasClipping: Boolean;
begin
Result := IsValidDC(DC) and IsValidGDIObject(hbr) and IsValidGDIObject(RegionHnd);
if not Result then Exit;
GtkDC := SaveDC(DC);
if (DevCtx.ClipRegion <> nil) and (DevCtx.ClipRegion^.GDIRegionObject <> nil) then
OldRgn := gdk_region_copy(DevCtx.ClipRegion^.GDIRegionObject)
else
OldRgn := nil;
hasClipping := Assigned(OldRgn);
try
if SelectClipRGN(DC, RegionHnd) <> ERROR then
begin
gdk_region_get_clipbox({%H-}PGDIObject(RegionHnd)^.GDIRegionObject, @CRect);
ARect := RectFromGdkRect(CRect);
DevCtx.FillRect(ARect, hbr, True);
// revert clip (whatever it is - null or valid region)
SelectClipRGN(DC, {%H-}HRGN(OldRgn));
Result := True;
end;
finally
if hasClipping then
gdk_region_destroy(OldRgn);
RestoreDC(DC, GtkDC);
end;
end;
{------------------------------------------------------------------------------
Function: Frame3d
Params: -
Returns: Nothing
Draws a 3d border in GTK native style.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.Frame3d(DC: HDC; var ARect: TRect;
const FrameWidth: integer; const Style: TBevelCut): Boolean;
var
DevCtx: TGtkDeviceContext absolute DC;
TheStyle: PGtkStyle;
i, AWidth: integer;
P: TPoint;
gc1, gc2: PGdkGC;
OldGC1Values, OldGC2Values: TGdkGCValues;
begin
Result := IsValidDC(DC);
if not Result or (FrameWidth = 0) then Exit;
TheStyle := gtk_widget_get_style(GetStyleWidget(lgsButton));
if TheStyle = nil then exit;
if DevCtx.HasTransf then
begin
ARect := DevCtx.TransfRectIndirect(ARect);
DevCtx.TransfNormalize(ARect.Left, ARect.Right);
DevCtx.TransfNormalize(ARect.Top, ARect.Bottom);
P.X := FrameWidth;
P.Y := FrameWidth;
P := DevCtx.TransfExtentIndirect(P);
AWidth := Abs(Min(P.X, P.Y));
end else
AWidth := FrameWidth;
case Style of
bvNone:
begin
InflateRect(ARect, -AWidth, -AWidth);
Exit;
end;
bvLowered:
begin
gc1 := TheStyle^.dark_gc[GTK_STATE_NORMAL];
gc2 := TheStyle^.light_gc[GTK_STATE_NORMAL];
end;
bvRaised:
begin
gc1 := TheStyle^.light_gc[GTK_STATE_NORMAL];
gc2 := TheStyle^.dark_gc[GTK_STATE_NORMAL];
end;
bvSpace:
begin
InflateRect(ARect, -AWidth, -AWidth);
Exit;
end;
end;
with DevCtx do
begin
if WithChildWindows then
begin
gdk_gc_get_values(gc1, @OldGC1Values);
gdk_gc_get_values(gc2, @OldGC2Values);
gdk_gc_set_subwindow(gc1, GDK_INCLUDE_INFERIORS);
gdk_gc_set_subwindow(gc2, GDK_INCLUDE_INFERIORS);
end;
DevCtx.RemovePixbuf;
for i := 1 to AWidth do
begin
gdk_draw_line(Drawable, gc1, ARect.Left + Offset.x, ARect.Top + Offset.y,
ARect.Right + Offset.x - 2, ARect.Top + Offset.y);
gdk_draw_line(Drawable, gc1, ARect.Left + Offset.x, ARect.Top + Offset.y,
ARect.Left + Offset.x, ARect.Bottom + Offset.y - 2);
gdk_draw_line(Drawable, gc2, ARect.Left + Offset.x, ARect.Bottom + Offset.y - 1,
ARect.Right + Offset.x - 1, ARect.Bottom + Offset.y - 1);
gdk_draw_line(Drawable, gc2, ARect.Right + Offset.x - 1, ARect.Top + Offset.y,
ARect.Right + Offset.x - 1, ARect.Bottom + Offset.y - 1);
// inflate the rectangle (! ARect will be returned to the user with this)
InflateRect(ARect, -1, -1);
end;
if WithChildWindows then
begin
gdk_gc_set_subwindow(gc1, OldGC1Values.subwindow_mode);
gdk_gc_set_subwindow(gc2, OldGC2Values.subwindow_mode);
end;
end;
end;
{------------------------------------------------------------------------------
function TGtk2WidgetSet.FrameRect(DC: HDC; const ARect: TRect;
hBr: HBRUSH): Integer;
------------------------------------------------------------------------------}
function TGtk2WidgetSet.FrameRect(DC: HDC; const ARect: TRect;
hBr: HBRUSH): Integer;
var
DevCtx: TGtkDeviceContext absolute DC;
DCOrigin: TPoint;
R: TRect;
OldBrush: HBrush;
begin
Result:=0;
if not IsValidDC(DC) then Exit;
if not IsValidGDIObject(hBr) then Exit;
// Draw outline
Result := 1;
if {%H-}PGdiObject(hBr)^.IsNullBrush then Exit;
OldBrush := SelectObject(DC, hBr);
DevCtx.SelectedColors := dcscCustom;
EnsureGCColor(DC, dccGDIBrushColor, True, False);//Brush Color
R := ARect;
LPtoDP(DC, R, 2);
DCOrigin := DevCtx.Offset;
DevCtx.RemovePixbuf;
gdk_draw_rectangle(DevCtx.Drawable, DevCtx.GC, 0,
R.Left + DCOrigin.X, R.Top + DCOrigin.Y,
R.Right-R.Left-1, R.Bottom-R.Top-1);
SelectObject(DC, OldBrush);
end;
{------------------------------------------------------------------------------
Function: GetActiveWindow
Params: none
Returns:
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetActiveWindow : HWND;
var
TopList, List: PGList;
Widget: PGTKWidget;
Window: PGTKWindow;
begin
// Default to 0
Result := 0;
TopList := gdk_window_get_toplevels;
List := TopList;
while List <> nil do
begin
if (List^.Data <> nil) then
begin
gdk_window_get_user_data(PGDKWindow(List^.Data), Pgpointer(@Window));
if GDK_IS_WINDOW(PGDKWindow(List^.Data)) and
gdk_window_is_visible(PGDKWindow(List^.Data)) and
gtk_is_window(Window) then
begin
Widget := Window^.focus_widget;
if Widget=nil then Widget:=PGtkWidget(Window);
//DebugLn('TGtk2WidgetSet.GetActiveWindow Window=',GetWidgetDebugReport(PgtkWidget(Window)),' Window^.focus_widget= ',GetWidgetDebugReport(Window^.focus_widget));
if (Widget <> nil) and gtk_widget_has_focus(Widget) then
begin
// return the window
Result := HWND({%H-}PtrUInt(GetMainWidget(PGtkWidget(Window))));
//DebugLn('TGtk2WidgetSet.GetActiveWindow Result=',GetWidgetDebugReport(PgtkWidget(Result)));
Break;
end;
end;
end;
list := g_list_next(list);
end;
if TopList <> nil
then g_list_free(TopList);
end;
function TGtk2WidgetSet.GetForegroundWindow: HWND;
begin
Result:=0;
{$IFDEF HASX}
Result:=X11GetActiveWindow;
{$ENDIF}
end;
{------------------------------------------------------------------------------
Function: GetDIBits
Params:
Returns:
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetDIBits(DC: HDC; Bitmap: HBitmap; StartScan, NumScans: UINT;
Bits: Pointer; var BitInfo: BitmapInfo; Usage: UINT): Integer;
begin
Result := 0;
if IsValidGDIObject(Bitmap)
then begin
case {%H-}PGDIObject(Bitmap)^.GDIType of
gdiBitmap:
Result := InternalGetDIBits(DC, Bitmap, StartScan, NumScans, -1, Bits,
BitInfo, Usage, True);
else
DebugLn('WARNING: [TGtk2WidgetSet.GetDIBits] not a Bitmap!');
end;
end
else
DebugLn('WARNING: [TGtk2WidgetSet.GetDIBits] invalid Bitmap!');
end;
{------------------------------------------------------------------------------
Function: GetBitmapBits
Params:
Returns:
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetBitmapBits(Bitmap: HBITMAP; Count: Longint; Bits: Pointer): Longint;
var
BitInfo : tagBitmapInfo;
begin
Result := 0;
if IsValidGDIObject(Bitmap)
then begin
case {%H-}PGDIObject(Bitmap)^.GDIType of
gdiBitmap:
Result := InternalGetDIBits(0, Bitmap, 0, 0, Count, Bits, BitInfo, 0, False);
else
DebugLn('WARNING: [TGtk2WidgetSet.GetBitmapBits] not a Bitmap!');
end;
end
else
DebugLn('WARNING: [TGtk2WidgetSet.GetBitmapBits] invalid Bitmap!');
end;
function TGtk2WidgetSet.GetBkColor(DC: HDC): TColorRef;
var
DevCtx: TGtkDeviceContext absolute DC;
begin
Result := CLR_INVALID;
if IsValidDC(DC) then
Result := DevCtx.CurrentBackColor.ColorRef;
end;
{------------------------------------------------------------------------------
Function: GetCapture
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetCapture: HWND;
var
Widget: PGtkWidget;
AWindow: PGtkWindow;
IsModal: gboolean;
begin
Widget:=gtk_grab_get_current;
// for the LCL a modal window is not capturing
if Widget<>nil then begin
if GtkWidgetIsA(Widget,GTK_TYPE_WINDOW) then begin
AWindow:=PGtkWindow(Widget);
IsModal:=gtk_window_get_modal(AWindow);
if IsModal then
Widget:=nil;
end;
end;
Result := HWnd({%H-}PtrUInt(Widget));
end;
{------------------------------------------------------------------------------
Function: GetCaretPos
Params: lpPoint: The caretposition
Returns: True if succesful
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetCaretPos(var lpPoint: TPoint): Boolean;
var
//FocusObject: PGTKObject;
modmask : TGDKModifierType;
begin
{$IFDEF DebugGDKTraps}
BeginGDKErrorTrap;
{$ENDIF}
gdk_window_get_pointer(nil,@lpPoint.X,@lpPoint.y,@modmask);
{$IFDEF DebugGDKTraps}
EndGDKErrorTrap;
{$ENDIF}
Result := True;
end;
{------------------------------------------------------------------------------
function TGtk2WidgetSet.GetCaretRespondToFocus(handle: HWND;
var ShowHideOnFocus: boolean): Boolean;
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetCaretRespondToFocus(handle: HWND;
var ShowHideOnFocus: boolean): Boolean;
begin
if handle<>0 then begin
if gtk_type_is_a({%H-}g_object_type({%H-}PGTKObject(handle)), GTKAPIWidget_GetType)
then begin
GTKAPIWidget_GetCaretRespondToFocus({%H-}PGTKAPIWidget(handle),
ShowHideOnFocus);
Result:=true;
end
else begin
Result := False;
end;
end else
Result:=false;
end;
{------------------------------------------------------------------------------
Function: GetCharABCWidths pbd
Params: Don't care yet
Returns: False so that the font cache in the newest mwEdit will use
TextMetrics info which is working already
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetCharABCWidths(DC: HDC; p2, p3: UINT;
const ABCStructs): Boolean;
begin
Result := False;
end;
{------------------------------------------------------------------------------
Function: GetClientBounds
Params: handle:
Result:
Returns: true on success
Returns the client bounds of a control. The client bounds is the rectangle of
the inner area of a control, where the child controls are visible. The
coordinates are relative to the control's left and top.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetClientBounds(handle : HWND; var ARect : TRect) : Boolean;
var
Widget, ClientWidget: PGtkWidget;
CurGDKWindow: PGdkWindow;
ClientOrigin: TPoint;
ClientWindow, MainWindow: PGdkWindow;
begin
Result := False;
if Handle = 0 then Exit;
Widget := {%H-}pgtkwidget(Handle);
ClientWidget := GetFixedWidget(Widget);
if (ClientWidget <> Widget) then begin
ClientWindow:=GetControlWindow(ClientWidget);
MainWindow:=GetControlWindow(Widget);
if MainWindow<>ClientWindow then begin
// widget and client are on different gdk windows
if (GTK_WIDGET_NO_WINDOW(ClientWidget)) then begin
// ClientWidget is a sub widget
ARect.Left:=ClientWidget^.allocation.x;
ARect.Top:=ClientWidget^.allocation.y;
end else begin
// ClientWidget owns the gdkwindow
ARect.Left:=0;
ARect.Top:=0;
end;
CurGDKWindow:=ClientWindow;
while (CurGDKWindow<>MainWindow) do
begin
if not GDK_IS_WINDOW(CurGDKWindow) then
break;
gdk_window_get_position(CurGDKWindow,@ClientOrigin.x,@ClientOrigin.y);
inc(ARect.Left,ClientOrigin.x);
inc(ARect.Top,ClientOrigin.y);
CurGDKWindow:=gdk_window_get_parent(CurGDKWindow);
end;
if GTK_WIDGET_NO_WINDOW(Widget) then begin
// Widget is a sub widget
dec(ARect.Left,Widget^.allocation.x);
dec(ARect.Top,Widget^.allocation.y);
end;
ARect.Right:=ARect.Left+ClientWidget^.Allocation.Width;
ARect.Bottom:=ARect.Top+ClientWidget^.Allocation.Height;
Result:=true;
end else if MainWindow<>nil then begin
// both are on the same gdkwindow
ARect.Left:=ClientWidget^.allocation.X-Widget^.allocation.X;
ARect.Top:=ClientWidget^.allocation.Y-Widget^.allocation.Y;
ARect.Right:=ARect.Left+ClientWidget^.allocation.Width;
ARect.Bottom:=ARect.Top+ClientWidget^.allocation.Height;
Result:=true;
end;
end;
if not Result then begin
with Widget^.Allocation do
ARect := Rect(0,0,Width,Height);
end;
Result:=true;
end;
{------------------------------------------------------------------------------
Function: GetClientRect
Params: handle:
Result:
Returns: true on success
Returns the client rectangle of a control. Left and Top are always 0.
The client rectangle is the size of the inner area of a control, where the
child controls are visible.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetClientRect(handle : HWND; var ARect : TRect) : Boolean;
begin
Result := false;
if Handle = 0 then Exit;
ARect := GetWidgetClientRect({%H-}PGtkWidget(Handle));
Result := True;
end;
{------------------------------------------------------------------------------
Function: GetClipBox
Params: dc, lprect
Returns: Integer
Returns the smallest rectangle which includes the entire current
Clipping Region, or if no Clipping Region is set, the current
dimensions of the Drawable.
The result can be one of the following constants
Error
NullRegion
SimpleRegion
ComplexRegion
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetClipBox(DC : hDC; lpRect : PRect) : Longint;
var
DevCtx: TGtkDeviceContext absolute DC;
CRect : TGDKRectangle;
X, Y : Longint;
DCOrigin: Tpoint;
begin
// set default values
Result := SIMPLEREGION;
if lpRect <> nil then
lpRect^ := Rect(0,0,0,0);
if not IsValidDC(DC)
then begin
Result := ERROR;
Exit;
end;
DCOrigin := DevCtx.Offset;
if DevCtx.ClipRegion = nil then
begin
if (DevCtx.PaintRectangle.Left<>0)
or (DevCtx.PaintRectangle.Top<>0)
or (DevCtx.PaintRectangle.Right<>0)
or (DevCtx.PaintRectangle.Bottom<>0) then
lpRect^ := DevCtx.PaintRectangle
else
begin
gdk_window_get_size(DevCtx.Drawable, @X, @Y);
lpRect^ := Rect(0,0,X,Y);
end;
Result := SIMPLEREGION;
end
else
begin
Result := RegionType(DevCtx.ClipRegion^.GDIRegionObject);
gdk_region_get_clipbox(DevCtx.ClipRegion^.GDIRegionObject, @CRect);
lpRect^.Left := CRect.X;
lpRect^.Top := CRect.Y;
lpRect^.Right := lpRect^.Left + CRect.Width;
lpRect^.Bottom := lpRect^.Top + CRect.Height;
end;
DPtoLP(DC, lpRect^, 2);
Types.OffsetRect(lpRect^, -DCOrigin.X, -DCOrigin.Y);
end;
{------------------------------------------------------------------------------
Function: GetRGNBox
Params: rgn, lprect
Returns: Integer
Returns the smallest rectangle which includes the entire passed
Region, if lprect is null then just returns RegionType.
The result can be one of the following constants
Error
NullRegion
SimpleRegion
ComplexRegion
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetRgnBox(RGN : HRGN; lpRect : PRect) : Longint;
var
ClipR : TGDKRectangle;
begin
Result := SIMPLEREGION;
If lpRect <> nil then
lpRect^ := Rect(0,0,0,0);
If Not IsValidGDIObject(RGN) then
Result := ERROR
else begin
Result := RegionType({%H-}PGDIObject(RGN)^.GDIRegionObject);
If lpRect <> nil then begin
gdk_region_get_clipbox({%H-}PGDIObject(RGN)^.GDIRegionObject,
@ClipR);
With lpRect^ do begin
Left := ClipR.X;
Top := ClipR.Y;
Right := ClipR.X + ClipR.Width;
Bottom := ClipR.Y + ClipR.Height;
end;
end;
end;
end;
function TGtk2WidgetSet.GetROP2(DC: HDC): Integer;
begin
if IsValidDC(DC)
then Result := TGtkDeviceContext(DC).ROP2
else Result := 0;
end;
{------------------------------------------------------------------------------
Function: GetClipRGN
Params: dc, rgn
Returns: Integer
Returns a copy of the current Clipping Region.
The result can be one of the following constants
0 = no clipping set
1 = ok
-1 = error
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetClipRGN(DC: hDC; RGN: hRGN): Longint;
var
DCOrigin: TPoint;
ClipRegionWithDCOffset: PGdkRegion;
CurRegionObject: PGdkRegion;
ARect: TRect;
begin
Result := SIMPLEREGION;
If (not IsValidDC(DC)) then
Result := ERROR
else
if Not IsValidGDIObject(RGN) then
begin
Result := ERROR;
DebugLn('WARNING: [TGtk2WidgetSet.GetClipRGN] Invalid HRGN');
end
else
if Assigned(TGtkDeviceContext(DC).ClipRegion) and
not IsValidGDIObject(HGDIOBJ({%H-}PtrUInt(TGtkDeviceContext(DC).ClipRegion))) then
Result := ERROR
else with TGtkDeviceContext(DC) do
begin
CurRegionObject := nil;
if Assigned(ClipRegion) then
CurRegionObject := ClipRegion^.GDIRegionObject;
ARect := Rect(0, 0, 0, 0);
//debugln(['TGtk2WidgetSet.GetClipRGN ',GetWidgetDebugReport(Widget),' CurRegionObject=',Assigned(CurRegionObject),' DC=',dbgs(DC)]);
if Assigned(CurRegionObject) then begin
// create a copy of the current clipregion
ClipRegionWithDCOffset := gdk_region_copy(CurRegionObject);
// move it to the DC offset
// Example: if the ClipRegion is at 10,10 and the DCOrigin is at 10,10,
// then the ClipRegion must be moved to 0,0
DCOrigin := Offset;
gdk_region_offset(ClipRegionWithDCOffset, -DCOrigin.x, -DCOrigin.Y);
end
else
begin
// create a default clipregion
GetClipBox(DC, @ARect);
LPtoDP(DC, ARect, 2);
ClipRegionWithDCOffset := CreateRectGDKRegion(ARect);
end;
// free the old region in RGN
if Assigned({%H-}PGdiObject(RGN)^.GDIRegionObject) then
gdk_region_destroy({%H-}PGdiObject(RGN)^.GDIRegionObject);
// set the new region in RGN
{%H-}PGdiObject(RGN)^.GDIRegionObject := ClipRegionWithDCOffset;
Result := RegionType(ClipRegionWithDCOffset);
//DebugLn('TGtk2WidgetSet.GetClipRGN B DC=',DbgS(DC),
// ' DCOrigin=',dbgs(DCOrigin),' RGN=',GDKRegionAsString(ClipRegionWithDCOffset),' Result=',dbgs(Result));
If Result = NULLREGION then
Result := 0
else If Result <> ERROR then
Result := 1;
end;
If Result = ERROR then
Result := -1;
end;
{------------------------------------------------------------------------------
Function: GetCmdLineParamDescForInterface
Params: none
Returns: ansistring
Returns a description of the command line parameters, that are understood by
the interface.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetCmdLineParamDescForInterface: TStringList;
begin
result := TStringList.Create;
AddCmdLineParamDesc(result, ['--lcl-no-transient'], rsgtkOptionNoTransient);
AddCmdLineParamDesc(result, ['--gtk-module <module>'], rsgtkOptionModule);
AddCmdLineParamDesc(result, ['--g-fatal-warnings'], rsgOptionFatalWarnings);
AddCmdLineParamDesc(result, ['--gtk-debug <flags>'], rsgtkOptionDebug);
AddCmdLineParamDesc(result, ['--gtk-no-debug <flags>'], rsgtkOptionNoDebug);
AddCmdLineParamDesc(result, ['--gdk-debug <flags>'], rsgdkOptionDebug);
AddCmdLineParamDesc(result, ['--gdk-no-debug <flags>'], rsgdkOptionNoDebug);
AddCmdLineParamDesc(result, ['--display <h:s:d>'], rsgtkOptionDisplay);
AddCmdLineParamDesc(result, ['--sync'], rsgtkOptionSync);
AddCmdLineParamDesc(result, ['--no-xshm'], rsgtkOptionNoXshm);
AddCmdLineParamDesc(result, ['--name <progname>'], rsgtkOptionName);
AddCmdLineParamDesc(result, ['--class <classname>'], rsgtkOptionClass);
AddCmdLineParamDesc(result, ['--disableaccurateframe'], rsqtOptionDisableAccurateFrame);
end;
{------------------------------------------------------------------------------
Method: GetCurrentObject
Params:
DC - A handle to the DC
uObjectType - The object type to be queried
Returns: If the function succeeds, the return value is a handle to the specified object.
If the function fails, the return value is NULL.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetCurrentObject(DC: HDC; uObjectType: UINT): HGDIOBJ;
var
Gtk2DC: TGtkDeviceContext absolute DC;
begin
Result := 0;
if not GTK2WidgetSet.IsValidDC(DC) then
Exit;
case uObjectType of
OBJ_BITMAP: Result := {%H-}HGDIOBJ(Gtk2DC.CurrentBitmap);
OBJ_BRUSH: Result := {%H-}HGDIOBJ(Gtk2DC.CurrentBrush);
OBJ_FONT: Result := {%H-}HGDIOBJ(Gtk2DC.CurrentFont);
OBJ_PEN: Result := {%H-}HGDIOBJ(Gtk2DC.CurrentPen);
end;
end;
{------------------------------------------------------------------------------
Function: GetCursorPos
Params: lpPoint: The cursorposition
Returns: True if succesful
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetCursorPos(var lpPoint: TPoint ): Boolean;
begin
gdk_display_get_pointer(gdk_display_get_default(), nil, @lpPoint.X, @lpPoint.Y, nil);
Result := True;
end;
{------------------------------------------------------------------------------
Function: GetDC
Params: none
Returns: Nothing
hWnd is any widget.
The DC will be created for the client area and without the child areas
(they are clipped away). Child areas are all child gdkwindows
(e.g. not TControls).
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetDC(hWnd: HWND): HDC;
begin
Result:=CreateDCForWidget({%H-}PGtkWidget(hWnd),nil,false);
end;
{------------------------------------------------------------------------------
function TGtk2WidgetSet.GetDeviceCaps(DC: HDC; Index: Integer): Integer;
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetDeviceCaps(DC: HDC; Index: Integer): Integer;
var
Visual: PGdkVisual;
function GetVisual: boolean;
begin
Visual:=nil;
with TGtkDeviceContext(DC) do begin
If Drawable <> nil then
Visual:=gdk_window_get_visual(PGdkWindow(Drawable));
if Visual = nil then
Visual := GDK_Visual_Get_System;
end;
Result:=Visual<>nil;
end;
begin
Result := -1;
If DC = 0 then begin
DC := GetDC(0);
If DC = 0 then
exit;
Result := GetDeviceCaps(DC, Index);
ReleaseDC(0, DC);
exit;
end;
if not IsValidDC(DC) then exit;
with TGtkDeviceContext(DC) do
Case Index of
HORZRES : { Horizontal width in pixels }
If Drawable = nil then
Result := GetSystemMetrics(SM_CXSCREEN)
else
gdk_drawable_get_size(Drawable, @Result, nil);
VERTRES : { Vertical height in pixels }
If Drawable = nil then
Result := GetSystemMetrics(SM_CYSCREEN)
else
gdk_drawable_get_size(Drawable, nil, @Result);
BITSPIXEL : { Number of used bits per pixel = depth }
If Drawable = nil then
Result := GDK_Visual_Get_System^.Depth
else
Result := gdk_drawable_get_depth(Drawable);
PLANES : { Number of planes }
// ToDo
Result := 1;
//For Size in MM, MM = (Pixels*100)/(PPI*25.4)
HORZSIZE : { Horizontal size in millimeters }
Result := RoundToInt((GetDeviceCaps(DC, HORZRES) * 100) /
(GetDeviceCaps(DC, LOGPIXELSX) * 25.4));
VERTSIZE : { Vertical size in millimeters }
Result := RoundToInt((GetDeviceCaps(DC, VERTRES) * 100) /
(GetDeviceCaps(DC, LOGPIXELSY) * 25.4));
//So long as gdk_screen_width_mm is acurate, these should be
//acurate for Screen GDKDrawables. Once we get Metafiles
//we will also have to add internal support for Papersizes etc..
LOGPIXELSX : { Logical pixels per inch in X }
Result := ScreenInfo.PixelsPerInchX;
LOGPIXELSY : { Logical pixels per inch in Y }
Result := ScreenInfo.PixelsPerInchY;
SIZEPALETTE: { number of entries in color palette }
if GetVisual then
Result:=Visual^.colormap_size
else
Result:=0;
NUMRESERVED: { number of reserverd colors in color palette }
Result:=0;
else
DebugLn('TGtk2WidgetSet.GetDeviceCaps not supported: Type=',dbgs(Index));
end;
end;
{------------------------------------------------------------------------------
function GetDeviceSize(DC: HDC; var p: TPoint): boolean;
Retrieves the width and height of the device context in pixels.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetDeviceSize(DC: HDC; var p: TPoint): boolean;
var
DevCtx: TGtkDeviceContext absolute DC;
begin
if not IsValidDC(DC) then Exit(False);
if DevCtx.Drawable <> nil
then begin
P := Point(0,0);
gdk_window_get_size(PGdkWindow(DevCtx.Drawable), @P.X, @P.Y);
Exit(True);
end;
{$IFDEF RaiseExceptionOnNilPointers}
RaiseGDBException('TGtk2WidgetSet.GetDeviceSize Window=nil');
{$ENDIF}
DebugLn('TGtk2WidgetSet.GetDeviceSize:', ' WARNING: DC ',DbgS(DC),' without gdkwindow.',
' Widget=',DbgS(DevCtx.Widget));
Result := False;
end;
{------------------------------------------------------------------------------
function TGtk2WidgetSet.GetDCOriginRelativeToWindow(PaintDC: HDC;
WindowHandle: HWND; var OriginDiff: TPoint): boolean;
Returns the origin of PaintDC relative to the window handle.
Example:
A PaintDC of a TButton at 20,10 with a DC Offset of 0,0 on a form and the
WindowHandle is the form.
Then OriginDiff is the difference between the Forms client origin
and the PaintDC: 20,10.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetDCOriginRelativeToWindow(PaintDC: HDC;
WindowHandle: HWND; var OriginDiff: TPoint): boolean;
var
DevCtx: TGtkDeviceContext absolute PaintDC;
DCOrigin: TPoint;
DCScreenOrigin: TPoint;
WindowScreenOrigin: TPoint;
Widget: PGtkWidget;
DCWindow: PGdkWindow;
begin
Result := false;
OriginDiff := Point(0, 0);
if not IsValidDC(PaintDC) then exit;
DCOrigin := DevCtx.Offset;
DCWindow := PGdkWindow(DevCtx.Drawable);
gdk_window_get_origin(DCWindow, @(DCScreenOrigin.X), @(DCScreenOrigin.Y));
inc(DCScreenOrigin.X, DCOrigin.X);
inc(DCScreenOrigin.Y, DCOrigin.Y);
Widget := GetFixedWidget({%H-}PGtkWidget(WindowHandle));
if Widget = nil then
Widget := {%H-}PGtkWidget(WindowHandle);
gdk_window_get_origin(PGdkWindow(Widget^.window), @(WindowScreenOrigin.X), @(WindowScreenOrigin.Y));
OriginDiff.X := DCScreenOrigin.X - WindowScreenOrigin.X;
OriginDiff.Y := DCScreenOrigin.Y - WindowScreenOrigin.Y;
Result := True;
//DebugLn(['TGtk2WidgetSet.GetDCOriginRelativeToWindow DCScreenOrigin=',dbgs(DCScreenOrigin),' WindowScreenOrigin=',dbgs(WindowScreenOrigin),' OriginDiff=',dbgs(OriginDiff)]);
end;
{------------------------------------------------------------------------------
Function: GetDesignerDC
Params: none
Returns: Nothing
WindowHandle is any widget.
The DC will be created for the client area including the child areas.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetDesignerDC(WindowHandle: HWND): HDC;
begin
//DebugLn('TGtk2WidgetSet.GetDesignerDC A');
Result:=CreateDCForWidget({%H-}PGtkWidget(WindowHandle),nil,true);
end;
{------------------------------------------------------------------------------
Function: GetFocus
Params: none
Returns: The handle of the window with focus
The GetFocus function retrieves the handle of the window that has the focus.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetFocus: HWND;
var
TopList, List: PGList;
Widget: PGTKWidget;
Window: PGTKWindow;
Info: PWidgetInfo;
begin
// Default to 0
Result := 0;
{$IFDEF DebugGDKTraps}
BeginGDKErrorTrap;
{$ENDIF}
TopList := gdk_window_get_toplevels;
List := TopList;
while List <> nil do
begin
if (List^.Data <> nil)
then begin
gdk_window_get_user_data(PGDKWindow(List^.Data), Pgpointer(@Window));
if gtk_is_window(Window)
then begin
Widget := Window^.focus_widget;
{$IFDEF DebugLCLComponents}
if DebugGtkWidgets.IsDestroyed(Widget) then begin
DebugLn(['TGtk2WidgetSet.GetFocus Window^.focus_widget was already destroyed:']);
DebugLn(DebugGtkWidgets.GetInfo(Widget,true));
end;
{$ENDIF}
if (Widget <> nil) and gtk_widget_has_focus(Widget)
then begin
Info:=GetWidgetInfo(PGtkWidget(Window));
if (Info=nil) or (not (wwiDeactivating in Info^.Flags)) then
Result := HWND({%H-}PtrUInt(GetMainWidget(Widget)));
Break;
end;
end;
end;
list := g_list_next(list);
end;
if TopList <> nil
then g_list_free(TopList);
{$IFDEF VerboseFocus}
DebugLn('TGtk2WidgetSet.GetFocus: Result=',dbgHex(Result));
{$ENDIF}
{$IFDEF DebugGDKTraps}EndGDKErrorTrap;{$ENDIF}
end;
{------------------------------------------------------------------------------
function GetFontLanguageInfo(DC: HDC): DWord; override;
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetFontLanguageInfo(DC: HDC): DWord;
begin
Result := 0;
If IsValidDC(DC) then
with TGtkDeviceContext(DC) do begin
UpdateDCTextMetric(TGtkDeviceContext(DC));
if TGtkDeviceContext(DC).DCTextMetric.IsDoubleByteChar then
inc(Result,GCP_DBCS);
end;
end;
{------------------------------------------------------------------------------
Function: GetKeyState
Params: nVirtKey: The requested key
Returns: If the function succeeds, the return value specifies the status of
the given virtual key. If the high-order bit is 1, the key is down;
otherwise, it is up. If the low-order bit is 1, the key is toggled.
The GetKeyState function retrieves the status of the specified virtual key.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetKeyState(nVirtKey: Integer): Smallint;
const
StateDown = -128; // $FF80
StateToggled = 1;
KEYSTATE: array[Boolean] of Smallint = (0, StateDown);
TOGGLESTATE: array[Boolean] of Smallint = (0, StateToggled);
GDK_BUTTON_MASKS: array[VK_LBUTTON..VK_XBUTTON2] of guint32 =
(
{ VK_LBUTTON } GDK_BUTTON1_MASK,
{ VK_RBUTTON } GDK_BUTTON3_MASK,
{ VK_CANCEL } 0,
{ VK_MBUTTON } GDK_BUTTON2_MASK,
{ VK_XBUTTON1 } GDK_BUTTON4_MASK,
{ VK_XBUTTON2 } GDK_BUTTON5_MASK
);
var
GdkModMask: TGdkModifierType;
x, y: gint;
begin
case nVirtKey of
// remap
VK_LSHIFT: nVirtKey := VK_SHIFT;
VK_LCONTROL: nVirtKey := VK_CONTROL;
VK_LMENU: nVirtKey := VK_MENU;
end;
{$IFDEF Use_KeyStateList}
Result := KEYSTATE[FKeyStateList_.IndexOf({%H-}Pointer(PtrUInt(nVirtKey))) >=0];
{$ELSE}
Implement this
{$ENDIF}
// try extended keys
if Result = 0
then begin
{$IFDEF Use_KeyStateList}
Result := KEYSTATE[FKeyStateList_.IndexOf({%H-}Pointer(PtrUInt(nVirtKey or KEYMAP_EXTENDED))) >=0];
{$ELSE}
Implement this
{$ENDIF}
end;
{$IFDEF Use_KeyStateList}
// add toggle
Result := Result or TOGGLESTATE[FKeyStateList_.IndexOf({%H-}Pointer(
PtrUInt(nVirtKey or KEYMAP_TOGGLE))) >=0];
// If there are tons of new keyboard errors this is probably the cause
GdkModMask := gtk_accelerator_get_default_mod_mask;
if (Result and StateDown) <> 0 then
begin
if (nVirtKey = VK_CONTROL) and (GdkModMask and GDK_CONTROL_MASK = 0) then
Result := Result and not StateDown;
//if (nVirtKey = VK_SHIFT) and (GtkModMask and GDK_SHIFT_MASK = 0 then
// Result := Result and not StateDown;
end;
{$ENDIF}
// Mouse buttons. Toggle state is not tracked
if nVirtKey in [VK_LBUTTON, VK_RBUTTON, VK_MBUTTON..VK_XBUTTON2] then
begin
gdk_display_get_pointer(gdk_display_get_default, nil,
@x, @y, @GdkModMask);
Result := Result or KEYSTATE[GdkModMask and GDK_BUTTON_MASKS[nVirtKey] <> 0]
end;
end;
function TGtk2WidgetSet.GetMapMode(DC: HDC): Integer;
var
DevCtx: TGtkDeviceContext absolute DC;
begin
if IsValidDC(DC) then
Result := DevCtx.MapMode
else
Result := 0;
end;
function TGtk2WidgetSet.GetMonitorInfo(Monitor: HMONITOR; lpmi: PMonitorInfo): Boolean;
var
MonitorRect: TGdkRectangle;
{$IFDEF HasX}
x, y, w, h: gint;
{$ENDIF}
begin
Result := (lpmi <> nil) and (lpmi^.cbSize >= SizeOf(TMonitorInfo)) or (Monitor = 0);
if not Result then Exit;
Dec(Monitor);
gdk_screen_get_monitor_geometry(gdk_screen_get_default, Monitor, @MonitorRect);
with MonitorRect do
lpmi^.rcMonitor := Bounds(x, y, width, height);
// there is no way to determine workarea in gtk
{$IFDEF HasX}
if XGetWorkarea(x, y, w, h) <> -1 then
lpmi^.rcWork := Bounds(Max(MonitorRect.x, x), Max(MonitorRect.y, y),
Min(MonitorRect.Width, w), Min(MonitorRect.Height, h))
else
{$ENDIF}
lpmi^.rcWork := lpmi^.rcMonitor;
// since gtk-2.20 we have correct api to get primary monitor. issue #32464
if Assigned(gdk_screen_get_primary_monitor) then
begin
if (Monitor = gdk_screen_get_primary_monitor(gdk_screen_get_default)) then
lpmi^.dwFlags := MONITORINFOF_PRIMARY
else
lpmi^.dwFlags := 0;
end else
begin
// gtk2 below 2.20
if Monitor = 0 then
lpmi^.dwFlags := MONITORINFOF_PRIMARY
else
lpmi^.dwFlags := 0;
end;
end;
{------------------------------------------------------------------------------
Function: GetObject
Params: GDIObj - handle, BufSize - size of Buf argument, Buf - buffer
Returns: Size of buffer
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetObject(GDIObj: HGDIOBJ; BufSize: Integer; Buf: Pointer): Integer;
function GetObject_Bitmap: Integer;
var
NumColors, ImageDepth: Longint;
BitmapSection : TDIBSECTION;
begin
if Buf = nil
then begin
Result := SizeOf(TDIBSECTION);
Exit;
end;
Result := 0;
FillChar(BitmapSection{%H-}, SizeOf(TDIBSECTION), 0);
with {%H-}PGDIObject(GDIObj)^, BitmapSection,
BitmapSection.dsBm, BitmapSection.dsBmih
do begin
{dsBM - BITMAP}
bmType := LeToN($4D42);
bmWidth := 0 ;
bmHeight := 0;
{bmWidthBytes: Longint;}
bmPlanes := 1;//Does Bitmap Format support more?
bmBitsPixel := 1;
bmBits := nil;
{dsBmih - BITMAPINFOHEADER}
biSize := 40;
biWidth := 0;
biHeight := 0;
biPlanes := bmPlanes;
biBitCount := 1;
biCompression := 0;
biSizeImage := 0;
biXPelsPerMeter := 0;
biYPelsPerMeter := 0;
biClrUsed := 0;
biClrImportant := 0;
{dsBitfields: array[0..2] of DWORD;
dshSection: THandle;
dsOffset: DWORD;}
{$ifdef DebugGDKTraps}BeginGDKErrorTrap;{$endif}
case GDIBitmapType of
gbBitmap:
if GDIBitmapObject <> nil
then begin
gdk_window_get_size(GDIBitmapObject, @biWidth, @biHeight);
NumColors := 2;
biBitCount := 1;
end;
gbPixmap:
if GDIPixmapObject.Image <> nil
then begin
gdk_drawable_get_size(GDIPixmapObject.Image, @biWidth, @biHeight);
ImageDepth := gdk_drawable_get_depth(GDIPixmapObject.Image);
biBitCount := ImageDepth;
end;
gbPixbuf:
if GDIPixbufObject <> nil
then begin
biWidth := gdk_pixbuf_get_width(GDIPixbufObject);
biHeight := gdk_pixbuf_get_height(GDIPixbufObject);
biBitCount := gdk_pixbuf_get_bits_per_sample(GDIPixbufObject) * gdk_pixbuf_get_n_channels(GDIPixbufObject);
end;
end;
if Visual = nil
then begin
Visual := gdk_visual_get_best_with_depth(biBitCount);
if Visual = nil
then { Depth not supported }
Visual := gdk_visual_get_system;
SystemVisual := True; { This visual should not be referenced }
if Colormap <> nil then
gdk_colormap_unref(Colormap);
ColorMap := gdk_colormap_new(Visual, GdkTrue);
end
else
biBitCount := Visual^.Depth;
{$ifdef DebugGDKTraps}EndGDKErrorTrap;{$enDIF}
if biBitCount < 16 then
NumColors := Colormap^.Size;
biSizeImage := (((biBitCount*biWidth+31) shr 5) shl 2)*biHeight;
if GetSystemMetrics(SM_CXSCREEN) >= biWidth then
biXPelsPerMeter := GetDeviceCaps(0, LOGPIXELSX)
else
biXPelsPerMeter :=
RoundToInt((single(biWidth) / GetSystemMetrics(SM_CXSCREEN)) *
GetDeviceCaps(0, LOGPIXELSX));
if GetSystemMetrics(SM_CYSCREEN) >= biHeight then
biYPelsPerMeter := GetDeviceCaps(0, LOGPIXELSY)
else
biYPelsPerMeter :=
RoundToInt((Single(biHeight) / GetSystemMetrics(SM_CYSCREEN))*
GetDeviceCaps(0, LOGPIXELSY));
bmWidth := biWidth;
bmHeight := biHeight;
bmBitsPixel := biBitCount;
//Need to retrieve actual Number of Colors if Indexed Image
if bmBitsPixel < 16
then begin
biClrUsed := NumColors;
biClrImportant := biClrUsed;
end;
end;
if BufSize >= SizeOf(BitmapSection)
then begin
PDIBSECTION(Buf)^ := BitmapSection;
Result := SizeOf(TDIBSECTION);
end
else if BufSize>0
then begin
Move(BitmapSection,Buf^,BufSize);
Result := BufSize;
end;
end;
var
GDIObject: PGDIObject absolute GDIObj;
ALogPen: PLogPen absolute Buf;
AExtLogPen: PExtLogPen absolute Buf;
AFont: PPangoLayout;
AFontName: String;
PangoDesc: PPangoFontDescription;
i, RequiredSize: Integer;
AFontSize: gint;
begin
Result := 0;
if not IsValidGDIObject(GDIObj) then Exit;
case GDIObject^.GDIType of
gdiBitmap:
Result := GetObject_Bitmap;
gdiBrush:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetObject] gdiBrush');
end;
gdiFont:
begin
if Buf = nil
then begin
Result := SizeOf(GDIObject^.LogFont);
Exit;
end;
if BufSize >= SizeOf(GDIObject^.LogFont) then
begin
PLogfont(Buf)^ := GDIObject^.LogFont;
Result:= SizeOf(TLogFont);
if IsFontNameDefault(GDIObject^.LogFont.lfFaceName) then
begin
AFontName := GetDefaultFontName;
if (AFontName = '') or IsFontNameDefault(AFontName) then
begin
AFont := GetDefaultGtkFont(False);
if PANGO_IS_LAYOUT(AFont) then
begin
PangoDesc := pango_layout_get_font_description(AFont);
if PangoDesc = nil then
PangoDesc := pango_context_get_font_description(pango_layout_get_context(AFont));
AFontName := StrPas(pango_font_description_get_family(PangoDesc));
end;
end;
if AFontName <> '' then
PLogfont(Buf)^.lfFaceName := AFontName;
end;
if (GDIObject^.GDIFontObject <> nil) then
begin
AFont := GDIObject^.GDIFontObject;
if PANGO_IS_LAYOUT(AFont) then
begin
PangoDesc := pango_layout_get_font_description(GDIObject^.GDIFontObject);
if PangoDesc = nil then
PangoDesc := pango_context_get_font_description(pango_layout_get_context(AFont));
AFontSize := pango_font_description_get_size(PangoDesc);
if not pango_font_description_get_size_is_absolute(PangoDesc) then
AFontSize := MulDiv(AFontSize, Screen.PixelsPerInch, 72 * PANGO_SCALE)
else
AFontSize := PANGO_PIXELS(AFontSize);
PLogfont(Buf)^.lfHeight := AFontSize;
end;
end;
end else
if BufSize > 0 then
begin
Move(GDIObject^.LogFont,Buf^,BufSize);
Result:=BufSize;
end;
end;
gdiPen:
begin
if GDIObject^.IsExtPen then
begin
RequiredSize := SizeOf(TExtLogPen);
if GDIObject^.GDIPenDashesCount > 1 then
RequiredSize := RequiredSize + (GDIObject^.GDIPenDashesCount - 1) * SizeOf(DWord);
if Buf = nil then
Result := RequiredSize
else
if BufSize >= RequiredSize then
begin
Result := RequiredSize;
AExtLogPen^.elpPenStyle := GDIObject^.GDIPenStyle;
AExtLogPen^.elpWidth := GDIObject^.GDIPenWidth;
AExtLogPen^.elpBrushStyle := BS_SOLID;
AExtLogPen^.elpColor := GDIObject^.GDIPenColor.ColorRef;
AExtLogPen^.elpHatch := 0;
AExtLogPen^.elpNumEntries := GDIObject^.GDIPenDashesCount;
if GDIObject^.GDIPenDashesCount > 0 then
begin
for i := 0 to GDIObject^.GDIPenDashesCount - 1 do
PDWord(@AExtLogPen^.elpStyleEntry)[i] := GDIObject^.GDIPenDashes[i];
end
else
AExtLogPen^.elpStyleEntry[0] := 0;
end;
end
else
begin
if Buf = nil then
Result := SizeOf(TLogPen)
else
if BufSize >= SizeOf(TLogPen) then
begin
Result := SizeOf(TLogPen);
ALogPen^.lopnColor := GDIObject^.GDIPenColor.ColorRef;
ALogPen^.lopnWidth := Point(GDIObject^.GDIPenWidth, 0);
ALogPen^.lopnStyle := GDIObject^.GDIPenStyle;
end;
end;
end;
gdiRegion:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetObject] gdiRegion');
end;
else
DebugLn('WARNING: [TGtk2WidgetSet.GetObject] Unknown type %d', [Integer(GDIObject^.GDIType)]);
end;
end;
{------------------------------------------------------------------------------
Function: GetParent
Params: Handle:
Returns:
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetParent(Handle : HWND): HWND;
begin
if Handle <> 0 then
Result := {%H-}HWnd({%H-}PGtkWidget(Handle)^.Parent)
else
Result := 0;
end;
{------------------------------------------------------------------------------
Function: GetProp
Params: Handle: Str
Returns: Pointer
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetProp(Handle : hwnd; Str : PChar): Pointer;
Begin
Result := g_object_get_data({%H-}PGObject(Handle),Str);
end;
{------------------------------------------------------------------------------
function TGtk2WidgetSet.GetScrollBarSize(Handle: HWND; BarKind: Integer): integer;
Returns the current width of the scrollbar of the widget.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetScrollBarSize(Handle: HWND; BarKind: Integer): integer;
var
Widget, ScrollWidget, BarWidget: PGtkWidget;
begin
Result:=0;
Widget:={%H-}PGtkWidget(Handle);
if GtkWidgetIsA(Widget,GTK_TYPE_SCROLLED_WINDOW) then begin
ScrollWidget:=Widget;
end else begin
ScrollWidget:=PGtkWidget(g_object_get_data(PGObject(Widget),odnScrollArea));
end;
if ScrollWidget=nil then exit;
if BarKind=SM_CYVSCROLL then begin
BarWidget:=PGtkScrolledWindow(ScrollWidget)^.vscrollbar;
if BarWidget<>nil then
Result:=BarWidget^.Requisition.Width;
end else begin
BarWidget:=PGtkScrolledWindow(ScrollWidget)^.hscrollbar;
if BarWidget<>nil then
Result:=BarWidget^.Requisition.Height;
end;
end;
{------------------------------------------------------------------------------
function TGtk2WidgetSet.GetScrollbarVisible(Handle: HWND;
SBStyle: Integer): boolean;
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetScrollbarVisible(Handle: HWND; SBStyle: Integer): boolean;
var
Widget, ScrollWidget, BarWidget: PGtkWidget;
begin
Result:=false;
if Handle=0 then exit;
Widget:={%H-}PGtkWidget(Handle);
if GtkWidgetIsA(Widget,GTK_TYPE_SCROLLED_WINDOW) then begin
ScrollWidget:=Widget;
end else begin
ScrollWidget:=PGtkWidget(g_object_get_data(PGObject(Widget),odnScrollArea));
end;
if ScrollWidget=nil then exit;
if SBStyle=SB_VERT then begin
BarWidget:=PGtkScrolledWindow(ScrollWidget)^.vscrollbar;
end else begin
BarWidget:=PGtkScrolledWindow(ScrollWidget)^.hscrollbar;
end;
if BarWidget<>nil then
Result:=GTK_WIDGET_VISIBLE(BarWidget);
end;
{------------------------------------------------------------------------------
Function: GetScrollInfo
Params: Handle, BarFlag, ScrollInfo
Returns: Nothing
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetScrollInfo(Handle: HWND; SBStyle: Integer;
var ScrollInfo: TScrollInfo): Boolean;
var
Adjustment: PGtkAdjustment;
Scroll : PGTKWidget;
IsScrollWindow: Boolean;
begin
Result := false;
if (Handle = 0) then exit;
Scroll := g_object_get_data({%H-}PGObject(Handle), odnScrollArea);
if GtkWidgetIsA(Scroll, gtk_scrolled_window_get_type)
then begin
IsScrollWindow := True;
end
else begin
Scroll := {%H-}PGTKWidget(Handle);
IsScrollWindow := GtkWidgetIsA(Scroll, gtk_scrolled_window_get_type);
end;
Adjustment := nil;
case SBStyle of
SB_HORZ:
if IsScrollWindow
then begin
Adjustment := gtk_scrolled_window_get_hadjustment(
PGTKScrolledWindow(Scroll));
end
else if GtkWidgetIsA(PGtkWidget(Scroll),gtk_clist_get_type)
then begin
//clist
{TODO check is this is needed for listviews}
DebugLn('[GetScrollInfo] Possible obsolete get use of CList (Listview ?)');
Adjustment := gtk_clist_get_hadjustment(PgtkCList(Scroll));
end
// obsolete stuff
else if GtkWidgetIsA(PGtkWidget(Scroll),gtk_hscrollbar_get_type)
then begin
// this one shouldn't be possible, scrolbar messages are sent to the CTL
DebugLN('!!! direct SB_HORZ get call to scrollbar');
Adjustment := PgtkhScrollBar(Scroll)^.Scrollbar.Range.Adjustment;
end;
SB_VERT:
if GtkWidgetIsA(PGtkWidget(Scroll),gtk_scrolled_window_get_type)
then begin
Adjustment := gtk_scrolled_window_get_vadjustment(
PGTKScrolledWindow(Scroll));
end
else if GtkWidgetIsA(PGtkWidget(Scroll), gtk_clist_get_type)
then begin
//clist
//TODO: check is this is needed for listviews
DebugLn('[GetScrollInfo] Possible obsolete get use of CList (Listview ?)');
Adjustment := gtk_clist_get_vadjustment(PgtkCList(Scroll));
end
// obsolete stuff
else if GtkWidgetIsA(PGtkWidget(Scroll),gtk_vscrollbar_get_type)
then begin
// this one shouldn't be possible, scrolbar messages are sent to the CTL
DebugLN('!!! direct SB_HORZ get call to scrollbar');
Adjustment := PgtkvScrollBar(Scroll)^.Scrollbar.Range.Adjustment;
end;
SB_CTL:
if GtkWidgetIsA(PGtkWidget(Scroll),gtk_vscrollbar_get_type) then
Adjustment := PgtkvScrollBar(Scroll)^.Scrollbar.Range.Adjustment
else
if GtkWidgetIsA(PGtkWidget(Scroll),gtk_hscrollbar_get_type) then
Adjustment := PgtkhScrollBar(Scroll)^.Scrollbar.Range.Adjustment
else
if GtkWidgetIsA(PGtkWidget(Scroll), gtk_range_get_type) then
Adjustment := gtk_range_get_adjustment(PGTKRange(Scroll));
SB_BOTH:
DebugLn('[GetScrollInfo] Got SB_BOTH ???');
end;
if Adjustment = nil then Exit;
// POS
if (ScrollInfo.fMask and SIF_POS) <> 0
then begin
ScrollInfo.nPos := Round(Adjustment^.Value);
end;
// RANGE
if (ScrollInfo.fMask and SIF_RANGE) <> 0
then begin
ScrollInfo.nMin:= Round(Adjustment^.Lower);
ScrollInfo.nMax:= Round(Adjustment^.Upper);
end;
// PAGE
if (ScrollInfo.fMask and SIF_PAGE) <> 0
then begin
ScrollInfo.nPage := Round(Adjustment^.Page_Size);
end;
// TRACKPOS
if (ScrollInfo.fMask and SIF_TRACKPOS) <> 0
then begin
ScrollInfo.nTrackPos := Round(Adjustment^.Value);
end;
Result := true;
end;
{------------------------------------------------------------------------------
Function: GetStockObject
Params:
Returns: Nothing
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetStockObject(Value: Integer): TLCLHandle;
begin
Result := 0;
case Value of
BLACK_BRUSH: // Black brush.
Result := FStockBlackBrush;
DKGRAY_BRUSH: // Dark gray brush.
Result := FStockDKGrayBrush;
GRAY_BRUSH: // Gray brush.
Result := FStockGrayBrush;
LTGRAY_BRUSH: // Light gray brush.
Result := FStockLtGrayBrush;
NULL_BRUSH: // Null brush (equivalent to HOLLOW_BRUSH).
Result := FStockNullBrush;
WHITE_BRUSH: // White brush.
Result := FStockWhiteBrush;
BLACK_PEN: // Black pen.
Result := FStockBlackPen;
NULL_PEN: // Null pen.
Result := FStockNullPen;
WHITE_PEN: // White pen.
Result := FStockWhitePen;
(* ANSI_FIXED_FONT: // Fixed-pitch (monospace) system font.
begin
{If FStockFixedFont = 0 then
FStockFixedFont := GetStockFixedFont;
Result := FStockFixedFont;}
end;
ANSI_VAR_FONT: // Variable-pitch (proportional space) system font.
begin
end;
DEVICE_DEFAULT_FONT: // Device-dependent font.
begin
end; *)
(* OEM_FIXED_FONT: // Original equipment manufacturer (OEM) dependent fixed-pitch (monospace) font.
begin
end;
*)
DEFAULT_GUI_FONT, SYSTEM_FONT: // System font. By default, Windows uses the system font to draw menus, dialog box controls, and text. In Windows versions 3.0 and later, the system font is a proportionally spaced font; earlier versions of Windows used a monospace system font.
begin
// MG: this should only be done, when theme changed:
{If FStockSystemFont <> 0 then begin //This is a Temporary Hack!!! This
DeleteObject(FStockSystemFont); //should really only be done on
FStockSystemFont := 0; //theme change.
end;}
If FStockSystemFont = 0 then
FStockSystemFont := HFont({%H-}PtrUInt(CreateDefaultFont));
Result := FStockSystemFont;
end;
(* SYSTEM_FIXED_FONT: // Fixed-pitch (monospace) system font used in Windows versions earlier than 3.0. This stock object is provided for compatibility with earlier versions of Windows.
begin
Result := GetStockObject(ANSI_FIXED_FONT);
end;
DEFAULT_PALETTE: // Default palette. This palette consists of the static colors in the system palette.
begin
end;
*)
end;
end;
{------------------------------------------------------------------------------
Function: GetSysColor
Params: index to the syscolors array
Returns: RGB value
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetSysColor(nIndex: Integer): DWORD;
begin
if (nIndex < 0) or (nIndex > MAX_SYS_COLORS)
then begin
Result := 0;
DumpStack;
DebugLn(Format('ERROR: [TGtk2WidgetSet.GetSysColor] Bad Value: %d. Valid Range between 0 and %d', [nIndex, MAX_SYS_COLORS]));
end
else
Result := SysColorMap[nIndex];
end;
function TGtk2WidgetSet.GetSysColorBrush(nIndex: Integer): HBrush;
begin
if (nIndex < 0) or (nIndex > MAX_SYS_COLORS)
then begin
Result := 0;
DumpStack;
DebugLn(Format('ERROR: [TGtk2WidgetSet.GetSysColorBrush] Bad Value: %d. Valid Range between 0 and %d', [nIndex, MAX_SYS_COLORS]));
end
else
Result := FSysColorBrushes[nIndex];
end;
{------------------------------------------------------------------------------
Function: GetSystemMetrics
Params:
Returns: Nothing
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetSystemMetrics(nIndex: Integer): Integer;
var
P: Pointer;
{$ifdef HasX}
ax,ay,ah,aw: gint;
{$endif}
{$IFDEF Win32}
auw, auh: guint;
{$ENDIF}
screen: PGdkScreen;
ARect: TGdkRectangle;
AValue: TGValue;
begin
Result := 0;
case nIndex of
SM_ARRANGE:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_ARRANGE ');
end;
SM_CLEANBOOT:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CLEANBOOT ');
end;
SM_CMOUSEBUTTONS:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CMOUSEBUTTONS ');
end;
SM_CXBORDER:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CXBORDER ');
Result := Max(FCachedBorderSize, 0);
end;
SM_CYBORDER:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CYBORDER ');
Result := Max(FCachedBorderSize, 0);
end;
SM_CXCURSOR,
SM_CYCURSOR:
begin
{$IFDEF Win32}
// Width and height of a cursor, in pixels. For win32 system cannot create cursors of other sizes.
// For gtk this should be maximal cursor sizes
gdk_display_get_maximal_cursor_size(gdk_display_get_default, @auw, @auh);
if nIndex = SM_CXCURSOR
then Result := auw // return width
else Result := auh; // return height
{$ELSE}
// At least on Linux, the default size should be taken: Issue #32385
Result := gdk_display_get_default_cursor_size(gdk_display_get_default);
{$ENDIF}
end;
SM_CXDOUBLECLK:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CXDOUBLECLK ');
end;
SM_CYDOUBLECLK:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CYDOUBLECLK ');
end;
SM_CXDRAG:
begin
Result := 2;
end;
SM_CYDRAG:
begin
Result := 2;
end;
SM_CXEDGE:
begin
Result := 2;
end;
SM_CYEDGE:
begin
Result := 2;
end;
SM_CXFIXEDFRAME:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CXFIXEDFRAME ');
end;
SM_CYFIXEDFRAME:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CYFIXEDFRAME ');
end;
SM_CXHSCROLL:
begin
P := GetStyleWidget(lgsVerticalScrollbar);
if P <> nil then
Result := GTK_Widget(P)^.requisition.Width;
end;
SM_CYHSCROLL:
begin
P := GetStyleWidget(lgsHorizontalScrollbar);
if P <> nil then
Result := GTK_Widget(P)^.requisition.Height;
end;
SM_CXHTHUMB,
SM_CYVTHUMB:
begin
P := GetStyleWidget(lgsHorizontalScrollbar);
if P <> nil then
begin
FillChar(AValue{%H-}, SizeOf(AValue), 0);
g_value_init(@AValue, G_TYPE_INT);
gtk_widget_style_get_property(P, 'slider-width', @AValue);
Result := AValue.data[0].v_int;
end;
end;
SM_CXICON,
SM_CYICON:
// big icon size
// gtk recommends sizes 16,32,48. optional: 64 and 128
Result := 128;
SM_CXICONSPACING:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CXICONSPACING ');
end;
SM_CYICONSPACING:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CYICONSPACING ');
end;
SM_CXMAXIMIZED:
begin
{$IFDEF HasX}
if XGetWorkarea(ax,ay,aw,ah)>=0 then
Result := aw
else
Result := getSystemMetrics(SM_CXSCREEN);
{$ENDIF}
end;
SM_CYMAXIMIZED:
begin
{$IFDEF HasX}
if XGetWorkarea(ax,ay,aw,ah)>=0 then
Result := ah
else
Result := getSystemMetrics(SM_CYSCREEN);
{$ENDIF}
end;
SM_CXMAXTRACK:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CXMAXTRACK ');
end;
SM_CYMAXTRACK:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CYMAXTRACK ');
end;
SM_CXMENUCHECK:
begin
Result := 19;
P := GetStyleWidget(lgsCheckbox);
if P <> nil then
Result := GTK_Widget(P)^.requisition.Width;
end;
SM_CYMENUCHECK:
begin
Result := 19;
P := GetStyleWidget(lgsCheckbox);
if P <> nil then
Result := GTK_Widget(P)^.requisition.Height;
end;
SM_CXMENUSIZE,
SM_CYMENUSIZE:
begin
Result := GetTitleBarHeight - (FCachedBorderSize * 2);
end;
SM_CXMIN:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CXMIN ');
end;
SM_CYMIN:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CYMIN ');
end;
SM_CXMINIMIZED:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CXMINIMIZED ');
end;
SM_CYMINIMIZED:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CYMINIMIZED ');
end;
SM_CXMINSPACING:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CXMINSPACING ');
end;
SM_CYMINSPACING:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CYMINSPACING ');
end;
SM_CXMINTRACK:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CXMINTRACK ');
end;
SM_CYMINTRACK:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CYMINTRACK ');
end;
SM_CXFULLSCREEN,
SM_CXSCREEN:
begin
screen := gdk_screen_get_default();
gdk_screen_get_monitor_geometry(screen, 0, @ARect);
Result := ARect.width;
end;
SM_CXVIRTUALSCREEN:
begin
Result := gdk_Screen_Width;
end;
SM_CYFULLSCREEN,
SM_CYSCREEN:
begin
screen := gdk_screen_get_default();
gdk_screen_get_monitor_geometry(screen, 0, @ARect);
Result := ARect.height;
end;
SM_CYVIRTUALSCREEN:
begin
result := gdk_Screen_Height;
end;
SM_CXSIZE:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CXSIZE ');
end;
SM_CYSIZE:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CYSIZE ');
end;
SM_CXSIZEFRAME, // same as SM_CXFRAME
SM_CYSIZEFRAME: // same as SM_CYFRAME
begin
Result := Max(FCachedBorderSize, 0);
end;
SM_CXSMICON,
SM_CYSMICON:
// small icon size
// gtk recommends sizes 16,32,48. optional: 64 and 128
Result := 16;
SM_CXSMSIZE:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CXSMSIZE ');
end;
SM_CYSMSIZE:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CYSMSIZE ');
end;
SM_CXVSCROLL:
begin
P := GetStyleWidget(lgsVerticalScrollbar);
if P <> nil then
Result := GTK_Widget(P)^.requisition.Width;
end;
SM_CYVSCROLL:
begin
P := GetStyleWidget(lgsHorizontalScrollbar);
if P <> nil then
Result := GTK_Widget(P)^.requisition.Height;
end;
SM_CYCAPTION:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CYCAPTION ');
Result := GetTitleBarHeight;
end;
SM_CYKANJIWINDOW:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CYKANJIWINDOW ');
end;
SM_CYMENU:
begin
Result := 24; // default gtk2 menusize inside menubar.
P := GetStyleWidget(lgsMenu);
if P <> nil then
Result := GTK_Widget(P)^.requisition.Height;
end;
SM_CYSMCAPTION:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_CYSMCAPTION ');
end;
SM_DBCSENABLED:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_DBCSENABLED ');
end;
SM_DEBUG:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_DEBUG ');
end;
SM_MENUDROPALIGNMENT:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_MENUDROPALIGNMENT');
end;
SM_MIDEASTENABLED:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_MIDEASTENABLED ');
end;
SM_MOUSEPRESENT:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_MOUSEPRESENT ');
end;
SM_MOUSEWHEELPRESENT:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_MOUSEWHEELPRESENT');
end;
SM_NETWORK:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_NETWORK ');
end;
SM_PENWINDOWS:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_PENWINDOWS ');
end;
SM_SECURE:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_SECURE ');
end;
SM_SHOWSOUNDS:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_SHOWSOUNDS ');
end;
SM_SLOWMACHINE:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_SLOWMACHINE ');
end;
SM_SWAPBUTTON:
begin
//DebugLn('Trace:TODO: [TGtk2WidgetSet.GetSystemMetrics] --> SM_SWAPBUTTON ');
end;
SM_SWSCROLLBARSPACING:
begin
P := GetStyleWidget(lgsScrolledWindow);
if P <> nil then begin
result := GTK_SCROLLED_WINDOW_CLASS(gtk_widget_get_class(P))^.scrollbar_spacing;
if result<0 then
gtk_widget_style_get(P, 'scrollbar-spacing', @result, nil);
end;
end;
SM_LCLMAXIMIZEDWIDTH:
begin
Result := GetSystemMetrics(SM_CXMAXIMIZED);
end;
SM_LCLMAXIMIZEDHEIGHT:
begin
Result := GetSystemMetrics(SM_CYMAXIMIZED) - 1 -
(GetSystemMetrics(SM_CYCAPTION) - (GetSystemMetrics(SM_CYSIZEFRAME) * 2));
end;
SM_LCLHasFormAlphaBlend:
begin
Result:=1;
end;
end;
end;
{------------------------------------------------------------------------------
Function: GetTextColor
Params: DC
Returns: TColorRef
Gets the Font Color currently assigned to the Device Context
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetTextColor(DC: HDC) : TColorRef;
begin
Result := 0;
if IsValidDC(DC) then
with TGtkDeviceContext(DC) do
begin
Result := CurrentTextColor.ColorRef;
end;
end;
{------------------------------------------------------------------------------
Function: GetTextExtentExPoint
Params:
Returns:
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetTextExtentExPoint(DC: HDC; Str: PChar;
Count, MaxWidth: Integer; MaxCount, PartialWidths: PInteger;
var Size: TSize): Boolean;
var
DevCtx: TGtkDeviceContext absolute DC;
UseFont : TGtkIntfFont;
Utf8Len, Accu, I: PtrInt;
Iter: PPangoLayoutIter;
CharRect: TPangoRectangle;
begin
if not IsValidDC(DC) then
Exit(False);
Size.cx := 0;
Size.cy := 0;
if MaxCount <> nil then
MaxCount^ := 0;
if Count = 0 then
Exit(True);
if (Count < -1) or (Str = nil) then
Exit(False);
if Count = -1 then
Count := Length(Str);
Utf8Len := UTF8Length(Str, Count);
if Utf8Len = 0 then
Exit(True);
UseFont := GetGtkFont(DevCtx);
UpdateDCTextMetric(DevCtx);
SetLayoutText(UseFont, Str, Count);
pango_layout_get_pixel_size(UseFont, @Size.cx, @Size.cy);
if DevCtx.HasTransf then
begin
DevCtx.InvTransfExtent(Size.cx, Size.cy);
Size.cx := Abs(Size.cx);
Size.cy := Abs(Size.cy);
end;
if PartialWidths = nil then
begin
if MaxCount = nil then
Exit(True);
if Size.cx <= MaxWidth then
begin
MaxCount^ := Utf8Len;
Exit(True);
end;
end;
I := 1;
Accu := 0;
Iter := pango_layout_get_iter(UseFont);
repeat
pango_layout_iter_get_char_extents(Iter, @CharRect);
Inc(Accu, CharRect.Width);
CharRect.Width := Accu;
pango_extents_to_pixels(nil, @CharRect);
if DevCtx.HasTransf then
begin
DevCtx.InvTransfExtent(CharRect.Width, CharRect.Height);
CharRect.Width := Abs(CharRect.Width);
end;
if MaxCount <> nil then
begin
if CharRect.Width > MaxWidth then
Break;
MaxCount^ := I;
end;
if PartialWidths <> nil then
PartialWidths[I - 1] := CharRect.Width;
Inc(I);
until not pango_layout_iter_next_char(Iter);
pango_layout_iter_free(Iter);
Exit(True);
end;
{------------------------------------------------------------------------------
Function: GetTextExtentPoint
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetTextExtentPoint(DC: HDC; Str: PChar; Count: Integer;
var Size: TSize): Boolean;
begin
Result := GetTextExtentExPoint(DC, Str, Count, 0, nil, nil, Size);
end;
{------------------------------------------------------------------------------
Function: GetTextMetrics
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetTextMetrics(DC: HDC; var TM: TTextMetric): Boolean;
var
DevCtx: TGtkDeviceContext absolute DC;
begin
Result := IsValidDC(DC);
if Result then
begin
UpdateDCTextMetric(DevCtx);
TM := DevCtx.DCTextMetric.TextMetric;
end;
end;
function TGtk2WidgetSet.GetViewPortExtEx(DC: HDC; Size: PSize): Integer;
var
DevCtx: TGtkDeviceContext absolute DC;
begin
if IsValidDC(DC) and (Size <> nil) then
begin
Size^.cx := DevCtx.ViewPortExt.x;
Size^.cy := DevCtx.ViewPortExt.y;
Result := Integer(True);
end else
Result := Integer(False);
end;
function TGtk2WidgetSet.GetViewPortOrgEx(DC: HDC; P: PPoint): Integer;
var
DevCtx: TGtkDeviceContext absolute DC;
begin
if IsValidDC(DC) and (P <> nil) then
begin
P^.x := DevCtx.ViewPortOrg.x;
P^.y := DevCtx.ViewPortOrg.y;
Result := Integer(True);
end else
Result := Integer(False);
end;
function TGtk2WidgetSet.GetWindowExtEx(DC: HDC; Size: PSize): Integer;
var
DevCtx: TGtkDeviceContext absolute DC;
begin
if IsValidDC(DC) and (Size <> nil) then
begin
Size^.cx := DevCtx.WindowExt.x;
Size^.cy := DevCtx.WindowExt.y;
Result := Integer(True);
end else
Result := Integer(False);
end;
{------------------------------------------------------------------------------
Function: GetWindowLong
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetWindowLong(Handle: HWND; int: Integer): PtrInt;
function GetObjectData(Name: PChar): PtrInt;
begin
Result := PtrInt({%H-}PtrUInt({%H-}g_object_get_data({%H-}PGObject(Handle),Name)));
end;
var
WidgetInfo: PWidgetInfo;
begin
//TODO:Started but not finished
case int of
GWL_WNDPROC :
begin
WidgetInfo := GetWidgetInfo({%H-}Pointer(Handle));
if WidgetInfo <> nil then
Result := WidgetInfo^.WndProc
else
Result := 0;
end;
GWL_HINSTANCE :
begin
Result := GetObjectData('HINSTANCE');
end;
GWL_HWNDPARENT :
begin
Result := GetObjectData('HWNDPARENT');
end;
{ GWL_WNDPROC :
begin
Data := GetLCLObject(Pointer(Handle));
if Data is TControl
then Result := PtrInt(@(TControl(Data).WindowProc));
// TODO fix this, a method pointer (2 pointers) can not be casted to a longint
end;
}
{ GWL_HWNDPARENT :
begin
Data := GetLCLObject(Pointer(Handle));
if (Data is TWinControl)
then Result := PtrInt(TWincontrol(Data).Handle)
else Result := 0;
end;
}
GWL_STYLE :
begin
WidgetInfo := GetWidgetInfo({%H-}Pointer(Handle));
if WidgetInfo <> nil then
Result := WidgetInfo^.Style
else
Result := 0;
end;
GWL_EXSTYLE :
begin
WidgetInfo := GetWidgetInfo({%H-}Pointer(Handle));
if WidgetInfo <> nil then
Result := WidgetInfo^.ExStyle
else
Result := 0;
end;
GWL_USERDATA :
begin
Result := GetObjectData('Userdata');
end;
GWL_ID :
begin
Result := GetObjectData('ID');
end;
else Result := 0;
end; //case
end;
{------------------------------------------------------------------------------
Function: GetWindowOrgEx
Params: none
Returns: Nothing
Returns the current offset of the DC.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetWindowOrgEx(dc: hdc; P: PPoint): Integer;
var
DevCtx: TGtkDeviceContext absolute DC;
begin
if P = nil then Exit(0);
P^ := Point(0,0);
if not IsValidDC(DC) then exit(0);
P^ := DevCtx.WindowOrg;
Result := 1;
end;
{------------------------------------------------------------------------------
Function: GetWindowRect
Params: none
Returns: 0
After the call, ARect will be the control area in screen coordinates.
That means, Left and Top will be the screen coordinate of the TopLeft pixel
of the Handle object and Right and Bottom will be the screen coordinate of
the BottomRight pixel.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetWindowRect(Handle: hwnd; var ARect: TRect): Integer;
var
Widget: PGTKWidget;
GRect: TGdkRectangle;
P: TPoint;
AInfo: PWidgetInfo;
AForm: TCustomForm;
R, AFrame: TRect;
begin
Result := 0; // error
if Handle = 0 then
Exit;
Widget := {%H-}PGtkWidget(Handle);
if GTK_IS_WINDOW(Widget) and Assigned(Widget^.window)
and GTK_WIDGET_VISIBLE(Widget) // Gtk2 returns invalid origin/frame for invisible widgets
then
begin
P := GetWidgetOrigin(Widget);
gdk_window_get_frame_extents(Widget^.window, @GRect);
ARect := Bounds(P.X,P.Y,GRect.width,GRect.height);
// writeln('Frame extents are: ',dbgs(R),' ARECT=',dbgs(ARect));
Result := 1; // success
end else
begin
{$IFDEF HASX}
AInfo := GetWidgetInfo(Widget);
if (AInfo^.LCLObject is TCustomForm) and not AInfo^.FirstPaint then
begin
AForm := TCustomForm(AInfo^.LCLObject);
if not IsFormDesign(AForm) and (AForm.BorderStyle <> bsNone) and
not (AForm.FormStyle in [fsMDIChild, fsSplash])
and (Gtk2WidgetSet.GetDummyWidgetFrame <> Rect(0, 0, 0, 0)) then
begin
R := AForm.BoundsRect;
AFrame := Gtk2WidgetSet.GetDummyWidgetFrame;
// apply frame size to lcl form.
R.Right += AFrame.Left + AFrame.Right;
R.Bottom += AFrame.Top + AFrame.Bottom;
ARect := R; //this is now real size under x11 even on unmapped window :)
exit(-1);
end;
end;
{$ENDIF}
ARect.TopLeft := GetWidgetOrigin(Widget);
if (ARect.Top <> -1) or (ARect.Left <> -1)
or (Widget^.allocation.width <> 1) or (Widget^.allocation.height <> 1) then
begin
ARect.BottomRight := Point(
ARect.Left + Widget^.allocation.width,
ARect.Top + Widget^.allocation.height);
Result := 1; // success
end;
end;
end;
{------------------------------------------------------------------------------
Function: GetWindowRelativePosition
Params: Handle : hwnd;
Returns: true on success
Returns the Left, Top, relative to the client origin of its parent
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetWindowRelativePosition(Handle : hwnd;
var Left, Top: integer): boolean;
var
aWidget: PGtkWidget;
begin
aWidget := {%H-}PGtkWidget(Handle);
if GtkWidgetIsA(aWidget, GTK_TYPE_WIDGET) then
begin
Result := true;
GetWidgetRelativePosition(aWidget, Left, Top);
end else
Result := false;
end;
{------------------------------------------------------------------------------
Function: GetWindowSize
Params: Handle : hwnd;
Returns: true on success
Returns the current widget Width and Height
------------------------------------------------------------------------------}
function TGtk2WidgetSet.GetWindowSize(Handle : hwnd;
var Width, Height: integer): boolean;
begin
if GtkWidgetIsA({%H-}PGtkWidget(Handle),GTK_TYPE_WIDGET) then begin
Result:=true;
Width:=Max(0,{%H-}PGtkWidget(Handle)^.Allocation.Width);
Height:=Max(0,{%H-}PGtkWidget(Handle)^.Allocation.Height);
//DebugLn(['TGtk2WidgetSet.GetWindowSize ',DbgSName(GetLCLOwnerObject(Handle)),' Allocation=',Width,'x',Height]);
end else
Result:=false;
end;
{------------------------------------------------------------------------------
Function: HideCaret
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtk2WidgetSet.HideCaret(hWnd: HWND): Boolean;
var
GTKObject: PGTKObject;
WasVisible: boolean;
begin
GTKObject := {%H-}PGTKObject(HWND);
Result := GTKObject <> nil;
if Result
then begin
if gtk_type_is_a(g_object_type(GTKObject), GTKAPIWidget_GetType)
then begin
WasVisible:=false;
GTKAPIWidget_HideCaret(PGTKAPIWidget(GTKObject),WasVisible);
end
// else if // TODO: other widgettypes
else begin
Result := False;
end;
end
else DebugLn('WARNING: [TGtk2WidgetSet.HideCaret] Got null HWND');
end;
{------------------------------------------------------------------------------
Function: InvalidateRect
Params: aHandle:
Rect:
bErase:
Returns:
------------------------------------------------------------------------------}
function TGtk2WidgetSet.InvalidateRect(aHandle : HWND; Rect : pRect;
bErase : Boolean) : Boolean;
var
gdkRect : TGDKRectangle;
Widget, PaintWidget: PGtkWidget;
LCLObject: TObject;
WidgetInfo: PWidgetInfo;
r: TRect;
Adjustment: PGtkAdjustment;
Pt: TPoint;
begin
// DebugLn(format('Rect = %d,%d,%d,%d',[rect^.left,rect^.top,rect^.Right,rect^.Bottom]));
Widget:={%H-}PGtkWidget(aHandle);
LCLObject:=GetLCLObject(Widget);
if (LCLObject<>nil) then
begin
if (LCLObject=CurrentSentPaintMessageTarget) then
begin
DebugLn('WARNING: TGtk2WidgetSet.InvalidateRect refused invalidating during paint message: ',
LCLObject.ClassName);
exit(False);
end;
{$IFDEF VerboseDsgnPaintMsg}
if (LCLObject is TComponent)
and (csDesigning in TComponent(LCLObject).ComponentState) then begin
write('TGtk2WidgetSet.InvalidateRect A ');
write(TComponent(LCLObject).Name,':');
write(LCLObject.ClassName);
with Rect^ do
write(' Rect=',Left,',',Top,',',Right,',',Bottom);
DebugLn(' Erase=',bErase);
end;
{$ENDIF}
end;
Result := True;
PaintWidget:=GetFixedWidget(Widget);
if PaintWidget=nil then PaintWidget:=Widget;
if Rect = nil then
begin
Rect := @r;
Rect^.Left := 0;//PaintWidget^.Allocation.X;
Rect^.Top := 0;//PaintWidget^.Allocation.Y;
Rect^.Right := PaintWidget^.Allocation.Width;
Rect^.Bottom := PaintWidget^.Allocation.Height;
end else
begin
// normalize rect
r := Rect^;
if r.Left>r.Right then
begin
r.Left := r.Right;
r.Right := Rect^.Left;
end;
if r.Top>r.Bottom then
begin
r.Top := r.Bottom;
r.Bottom := Rect^.Top;
end;
Rect := @r;
end;
gdkRect.X := Rect^.Left;
gdkRect.Y := Rect^.Top;
gdkRect.Width := (Rect^.Right - Rect^.Left);
gdkRect.Height := (Rect^.Bottom - Rect^.Top);
if (PaintWidget<>nil) and GTK_WIDGET_NO_WINDOW(PaintWidget) and (Rect<>nil) and
(not GtkWidgetIsA(PGTKWidget(PaintWidget),GTKAPIWidget_GetType)) then
begin
Inc(gdkRect.X, PaintWidget^.Allocation.x);
Inc(gdkRect.Y, PaintWidget^.Allocation.y);
// issue #25572
if GTK_IS_FIXED(PaintWidget) and GTK_IS_EVENT_BOX(PaintWidget^.parent) then
begin
Inc(gdkRect.Width, PaintWidget^.Allocation.x);
Inc(gdkRect.Height, PaintWidget^.Allocation.y);
// DebugLn('#25572 PATCH FOR ',dbgsName(LCLObject),' GdkRect=',dbgs(gdkRect),' Alloc=',dbgs(TGdkRectangle(PaintWidget^.allocation)));
{GtkWidget isn't yet allocated to LCL size, do not call invalid area update - update complete gtkwidget}
if (gdkRect.Width > PaintWidget^.allocation.width) or (gdkRect.Height > PaintWidget^.allocation.Height) then
begin
// DebugLn('*** WARNING: Rect to paint is bigger than widget Width diff=',dbgs(gdkRect.Width - PaintWidget^.allocation.width),
// ' Height diff=',dbgs(gdkRect.Height - PaintWidget^.allocation.height));
if bErase then
gtk_widget_queue_clear(PaintWidget);
gtk_widget_queue_draw(PaintWidget);
exit;
end;
end;
end;
if (LCLObject is TScrollingWinControl) and GTK_IS_SCROLLED_WINDOW(Widget) then
begin
Pt := Point(0, 0);
Adjustment := gtk_scrolled_window_get_vadjustment(PGtkScrolledWindow(Widget));
if Adjustment <> nil then
Pt.Y := Round(Adjustment^.value);
Adjustment := gtk_scrolled_window_get_hadjustment(PGtkScrolledWindow(Widget));
if Adjustment <> nil then
Pt.X := Round(Adjustment^.value);
dec(gdkRect.x, Pt.X);
dec(gdkRect.y, Pt.Y);
Types.OffsetRect(Rect^, -Pt.X, -Pt.Y);
end;
WidgetInfo := GetWidgetInfo(Widget); // GetOrCreateWidgetInfo() ??
if WidgetInfo <> nil then
UnionRect(WidgetInfo^.UpdateRect, WidgetInfo^.UpdateRect, Rect^);
if bErase then
gtk_widget_queue_clear_area(PaintWidget,
gdkRect.X,gdkRect.Y,gdkRect.Width,gdkRect.Height);
gtk_widget_queue_draw_area(PaintWidget,
gdkRect.X,gdkRect.Y,gdkRect.Width,gdkRect.Height);
//DebugLn(['TGtk2WidgetSet.InvalidateRect ',GetWidgetDebugReport(Widget),' IsAPI=',GtkWidgetIsA(PGTKWidget(Widget),GTKAPIWidget_GetType)]);
if GtkWidgetIsA(PGTKWidget(Widget),GTKAPIWidget_GetType) then
GTKAPIWidget_InvalidateCaret(PGTKAPIWidget(Widget));
end;
function TGtk2WidgetSet.InvalidateRgn(Handle: HWND; Rgn: HRGN; Erase: Boolean
): Boolean;
var
R: TRect;
begin
// TODO: use gdk_window_invalidate_region to implement this function
Result:=GetRgnBox(Rgn, @R)=0;
InvalidateRect(Handle, @R, Erase);
end;
function TGtk2WidgetSet.IsIconic(handle: HWND): boolean;
var
GtkWindow: PGtkWindow absolute handle;
begin
Result := False;
if GtkWindow = nil then
Exit;
Result := (PGtkWidget(GtkWindow)^.Window<>nil) and GDK_IS_WINDOW(PGtkWidget(GtkWindow)^.Window)
and (gdk_window_get_state(PGtkWidget(GtkWindow)^.Window)
and GDK_WINDOW_STATE_ICONIFIED <> 0);
end;
function TGtk2WidgetSet.IsWindow(handle: HWND): boolean;
begin
if Handle = 0 then
Exit(False);
Result := GtkWidgetIsA({%H-}PGtkWidget(Handle), GTK_TYPE_WIDGET);
end;
{------------------------------------------------------------------------------
function TGtk2WidgetSet.IsWindowEnabled(handle: HWND): boolean;
------------------------------------------------------------------------------}
function TGtk2WidgetSet.IsWindowEnabled(handle: HWND): boolean;
var
LCLObject: TObject;
Widget: PGtkWidget;
AForm: TCustomForm;
//i: Integer;
begin
Widget:={%H-}PGtkWidget(handle);
Result:=(Widget<>nil) and GTK_WIDGET_SENSITIVE(Widget)
and GTK_WIDGET_PARENT_SENSITIVE(Widget) and GTK_WIDGET_VISIBLE(Widget);
LCLObject:=GetLCLObject({%H-}PGtkWidget(Handle));
//debugln('TGtk2WidgetSet.IsWindowEnabled A ',DbgSName(LCLObject),' Result=',dbgs(Result),
// ' SENSITIVE=',dbgs(GTK_WIDGET_SENSITIVE(Widget)),
// ' PARENT_SENSITIVE=',dbgs(GTK_WIDGET_PARENT_SENSITIVE(Widget)),
// ' TOPLEVEL=',dbgs(GTK_WIDGET_TOPLEVEL(Widget)),
// '');
if Result and GtkWidgetIsA(Widget,GTK_TYPE_WINDOW) then begin
LCLObject:=GetLCLObject(Widget);
if (LCLObject is TCustomForm) then begin
AForm:=TCustomForm(LCLObject);
if not Screen.CustomFormBelongsToActiveGroup(AForm) then
Result:=false;
//debugln('TGtk2WidgetSet.IsWindowEnabled B ',dbgs(Screen.CustomFormBelongsToActiveGroup(AForm)));
//for i:=0 to Screen.CustomFormCount-1 do begin
// debugln(' ',dbgs(i),' ',DbgSName(Screen.CustomFormsZOrdered[i]));
//end;
end;
end;
end;
{------------------------------------------------------------------------------
function TGtk2WidgetSet.IsWindowVisible(handle: HWND): boolean;
------------------------------------------------------------------------------}
function TGtk2WidgetSet.IsWindowVisible(handle: HWND): boolean;
begin
Result := (handle <> 0) and GTK_WIDGET_VISIBLE({%H-}PGtkWidget(handle));
end;
function TGtk2WidgetSet.IsZoomed(handle: HWND): boolean;
var
GtkWindow: PGtkWindow absolute handle;
begin
Result := False;
if GtkWindow = nil then
Exit;
Result := GDK_IS_WINDOW(PGtkWidget(GtkWindow)^.Window) and (gdk_window_get_state(PGtkWidget(GtkWindow)^.Window) and GDK_WINDOW_STATE_MAXIMIZED <> 0);
end;
{------------------------------------------------------------------------------
Function: LineTo
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtk2WidgetSet.LineTo(DC: HDC; X, Y: Integer): Boolean;
var
DevCtx: TGtkDeviceContext absolute DC;
FromPt: TPoint;
ToPt: TPoint;
begin
if not IsValidDC(DC) then Exit(False);
DevCtx.SelectPenProps;
if not (dcfPenSelected in DevCtx.Flags) then Exit(False);
if DevCtx.IsNullPen then Exit(True);
FromPt := Point(DevCtx.PenPos.X + DevCtx.Offset.X, DevCtx.PenPos.Y + DevCtx.Offset.Y);
LPtoDP(DC, FromPt, 1);
ToPt := Point(X+DevCtx.Offset.X, Y+DevCtx.Offset.Y);
LPToDP(DC, ToPt, 1);
{$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF}
DevCtx.RemovePixbuf;
gdk_draw_line(DevCtx.Drawable, DevCtx.GC, FromPt.X, FromPt.Y, ToPt.X, ToPt.Y);
{$IFDEF DebugGDK}EndGDKErrorTrap;{$ENDIF}
DevCtx.PenPos := Point(X, Y);
Result := True;
end;
function TGtk2WidgetSet.LPtoDP(DC: HDC; var Points; Count: Integer): BOOL;
var
DevCtx: TGtkDeviceContext absolute DC;
P: PPoint;
begin
Result := False;
if not IsValidDC(DC) then Exit(False);
if not DevCtx.HasTransf then Exit(True);
P := @Points;
while Count > 0 do
begin
Dec(Count);
DevCtx.TransfPoint(P^.X, P^.Y);
Inc(P);
end;
Result := True;
end;
{------------------------------------------------------------------------------
Function: MessageBox
Params: hWnd: The handle of parent window
Returns: 0 if not successful (out of memory), otherwise one of the defined value :
IDABORT, IDCANCEL, IDIGNORE, IDNO, IDOK, IDRETRY, IDYES
The MessageBox function displays a modal dialog, with text and caption defined,
and includes buttons.
------------------------------------------------------------------------------}
function MessageButtonClicked(Widget : PGtkWidget; data: gPointer) : GBoolean; cdecl;
begin
//DebugLn('[MessageButtonClicked] ',dbgs(data),' ',dbgs(g_object_get_data(PGtkObject(Widget), 'modal_result')));
if PInteger(data)^ = 0 then
PInteger(data)^:={%H-}PtrUInt(g_object_get_data(PGObject(Widget), 'modal_result'));
Result:=false;
end;
function MessageBoxClosed(Widget : PGtkWidget; {%H-}Event : PGdkEvent;
data: gPointer) : GBoolean; cdecl;
var ModalResult : PtrUInt;
begin
{ We were requested by window manager to close }
if PInteger(data)^ = 0 then begin
ModalResult:= {%H-}PtrUInt(g_object_get_data(PGObject(Widget), 'modal_result'));
{ Don't allow to close if we don't have a default return value }
Result:= (ModalResult = 0);
if not Result then PInteger(data)^:= ModalResult
else DebugLn('Do not close !!!');
end else Result:= false;
end;
function TGtk2WidgetSet.MessageBox(hWnd: HWND; lpText, lpCaption: PChar;
uType : Cardinal): integer;
var Dialog, ALabel : PGtkWidget;
ButtonCount, DefButton, ADialogResult : Integer;
procedure CreateButton(const ALabel : PChar; const RetValue : integer);
var AButton : PGtkWidget;
begin
AButton:= gtk_button_new_with_mnemonic(Ampersands2Underscore(ALabel));
Inc(ButtonCount);
if ButtonCount = DefButton then begin
gtk_window_set_focus(PGtkWindow(Dialog), AButton);
end;
{ If there is the Cancel button, allow the dialog to close }
if RetValue = IDCANCEL then begin
g_object_set_data(PGObject(Dialog), 'modal_result', Pointer(IDCANCEL));
end;
g_object_set_data(PGObject(AButton), 'modal_result',
{%H-}Pointer(PtrInt(RetValue)));
g_signal_connect(PGtkObject(AButton), 'clicked',
TGtkSignalFunc(@MessageButtonClicked), @ADialogResult);
gtk_container_add (PGtkContainer(PGtkDialog(Dialog)^.action_area), AButton);
end;
begin
ButtonCount:= 0;
{ Determine which is the default button }
DefButton:= ((uType and $00000300) shr 8) + 1;
//DebugLn('Trace:Default button is ' + IntToStr(DefButton));
ADialogResult:= 0;
Dialog:= gtk_dialog_new;
{$IFDEF DebugLCLComponents}
DebugGtkWidgets.MarkCreated(Dialog,'TGtk2WidgetSet.MessageBox');
{$ENDIF}
g_signal_connect(PGtkObject(Dialog), 'delete-event', TGtkSignalFunc(@MessageBoxClosed), @ADialogResult);
gtk_window_set_default_size(PGtkWindow(Dialog), 100, 100);
ALabel:= gtk_label_new(lpText);
gtk_container_add (PGtkContainer(PGtkDialog(Dialog)^.vbox), ALabel);
case (uType and $0000000F) of
MB_OKCANCEL:
begin
CreateButton(PChar(rsMbOK), IDOK);
CreateButton(PChar(rsMbCancel), IDCANCEL);
end;
MB_ABORTRETRYIGNORE:
begin
CreateButton(PChar(rsMbAbort), IDABORT);
CreateButton(PChar(rsMbRetry), IDRETRY);
CreateButton(PChar(rsMbIgnore), IDIGNORE);
end;
MB_YESNOCANCEL:
begin
CreateButton(PChar(rsMbYes), IDYES);
CreateButton(PChar(rsMbNo), IDNO);
CreateButton(PChar(rsMbCancel), IDCANCEL);
end;
MB_YESNO:
begin
CreateButton(PChar(rsMbYes), IDYES);
CreateButton(PChar(rsMbNo), IDNO);
end;
MB_RETRYCANCEL:
begin
CreateButton(PChar(rsMbRetry), IDRETRY);
CreateButton(PChar(rsMbCancel), IDCANCEL);
end;
else
begin
{ We have no buttons to show. Create the default of OK button }
CreateButton(PChar(rsMbOK), IDOK);
end;
end;
gtk_window_set_title(PGtkWindow(Dialog), lpCaption);
gtk_window_set_position(PGtkWindow(Dialog), GTK_WIN_POS_CENTER);
gtk_window_set_modal(PGtkWindow(Dialog), true);
gtk_widget_show_all(Dialog);
while ADialogResult = 0 do begin
Application.HandleMessage;
end;
DestroyConnectedWidget(Dialog,true);
Result:= ADialogResult;
end;
{------------------------------------------------------------------------------
Function: MoveToEx
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtk2WidgetSet.MoveToEx(DC: HDC; X, Y: Integer; OldPoint: PPoint): Boolean;
var
DevCtx: TGtkDeviceContext absolute DC;
begin
Result := IsValidDC(DC);
if Result then
with DevCtx do
begin
if Assigned(OldPoint) then
OldPoint^ := PenPos;
PenPos := Point(X, Y)
end;
end;
function TGtk2WidgetSet.OffsetRgn(RGN: HRGN; nXOffset, nYOffset: Integer): Integer;
var
GdkRGN: PGDKRegion;
begin
if not IsValidGDIObject(RGN) then
Exit(Error);
GdkRGN := {%H-}PGdiObject(RGN)^.GDIRegionObject;
gdk_region_offset(GdkRGN, nXOffset, nYOffset);
Result := RegionType(GdkRGN);
end;
{------------------------------------------------------------------------------
Method: PaintRgn
Params: DC: HDC; RGN: HRGN
Returns: if the function succeeds
Paints the specified region by using the brush currently selected into the
device context.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.PaintRgn(DC: HDC; RGN: HRGN): Boolean;
var
DevCtx: TGtkDeviceContext absolute DC;
CurGdiBrush: PGdiObject;
CurHBrush: HBRUSH absolute CurGdiBrush;
begin
CurGdiBrush := DevCtx.CurrentBrush;
Result := IsValidDC(DC) and IsValidGDIObject(RGN) and IsValidGDIObject(CurHBrush);
if Result then
Result := FillRgn(DC, RGN, CurHBrush);
end;
{------------------------------------------------------------------------------
Function: PeekMessage
Params: lpMsg - Where it should put the message
Handle - Handle of the window (thread)
wMsgFilterMin- Lowest MSG to grab
wMsgFilterMax- Highest MSG to grab
wRemoveMsg - Should message be pulled out of the queue
Returns: Boolean if an event was there
------------------------------------------------------------------------------}
function TGtk2WidgetSet.PeekMessage(var lpMsg: TMsg; Handle : HWND;
wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): Boolean;
var
vlItem : TGtkMessageQueueItem;
begin
fMessageQueue.Lock;
try
vlItem := fMessageQueue.FirstMessageItem;
// filtering
while (vlItem <> nil) and (
((Handle <> 0) and (vlItem.Msg^.hwnd <> Handle)) or // filter by handle
((wMsgFilterMin <> 0) and (wMsgFilterMax <> 0) and // filter by message-range
not InRange(vlItem.Msg^.message, wMsgFilterMin, wMsgFilterMax)))
do
vlItem := TGtkMessageQueueItem(vlItem.Next);
Result := vlItem <> nil;
if Result then begin
lpMsg := vlItem.Msg^;
if (wRemoveMsg and PM_REMOVE) = PM_REMOVE then
fMessageQueue.RemoveMessage(vlItem,FPMF_Internal,true);
end;
finally
fMessageQueue.UnLock;
end;
end;
{------------------------------------------------------------------------------
Method: PolyBezier
Params: DC, Points, NumPts, Filled, Continous
Returns: Boolean
Use Polybezier to draw cubic Bézier curves. The first curve is drawn from the
first point to the fourth point with the second and third points being the
control points. If the Continuous flag is TRUE then each subsequent curve
requires three more points, using the end-point of the previous Curve as its
starting point, the first and second points being used as its control points,
and the third point its end-point. If the continous flag is set to FALSE,
then each subsequent Curve requires 4 additional points, which are used
excatly as in the first curve. Any additonal points which do not add up to
a full bezier(4 for Continuous, 3 otherwise) are ingored. There must be at
least 4 points for an drawing to occur. If the Filled Flag is set to TRUE
then the resulting Poly-Bézier will be drawn as a Polygon.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.PolyBezier(DC: HDC; Points: PPoint; NumPts: Integer;
Filled, Continuous: boolean): boolean;
begin
Result := inherited PolyBezier(DC, Points, NumPts, Filled, Continuous);
end;
{------------------------------------------------------------------------------
Method: TGtk2WidgetSet.Polygon
Params: DC: HDC; Points: ^TPoint; NumPts: integer; Winding: Boolean;
Returns: Nothing
Use Polygon to draw a closed, many-sided shape on the canvas, using the value
of Pen. After drawing the complete shape, Polygon fills the shape using the
value of Brush.
The Points parameter is an array of points that give the vertices of the
polygon.
Winding determines how the polygon is filled. When Winding is True, Polygon
fills the shape using the Winding fill algorithm. When Winding is False,
Polygon uses the even-odd (alternative) fill algorithm.
NumPts indicates the number of points to use.
The first point is always connected to the last point.
To draw a polygon on the canvas, without filling it, use the Polyline method,
specifying the first point a second time at the end.
}
function TGtk2WidgetSet.Polygon(DC: HDC; Points: PPoint; NumPts: Integer;
Winding: boolean): boolean;
var
DevCtx: TGtkDeviceContext absolute DC;
i: integer;
PointArray: PGDKPoint;
Tmp, RGN : hRGN;
ClipRect : TRect;
DCOrigin: TPoint;
OldNumPts: integer;
ThePoints: array of types.TPoint;
PThePoints: PPoint;
begin
if not IsValidDC(DC) then Exit(False);
if NumPts <= 0 then Exit(True);
//Create a copy of the points so we can freely alter them
SetLength(ThePoints{%H-}, NumPts);
for i := 0 to NumPts - 1 do ThePoints[i] := Points[i];
PThePoints := @ThePoints[0];
DCOrigin := DevCtx.Offset;
OldNumPts := NumPts;
// create the PointsArray, which is a copy of Points moved by the DCOrigin
// only if needed
if DevCtx.IsNullPen and DevCtx.IsNullBrush then
PointArray := nil
else
begin
GetMem(PointArray, SizeOf(TGdkPoint) * (NumPts + 1)); // +1 for return line
for i := 0 to NumPts - 1 do
begin
if DevCtx.HasTransf then
ThePoints[I] := DevCtx.TransfPointIndirect(ThePoints[I]);
PointArray[i].x := ThePoints[I].x + DCOrigin.X;
PointArray[i].y := ThePoints[I].y + DCOrigin.Y;
end;
if (Points[NumPts-1].X <> Points[0].X) or
(Points[NumPts-1].Y <> Points[0].Y) then
begin
// add last point to return to first
PointArray[NumPts].x := PointArray[0].x;
PointArray[NumPts].y := PointArray[0].y;
Inc(NumPts);
end;
end;
// first draw interior in brush color
{$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF}
if not DevCtx.IsNullBrush then
begin
if Winding then
begin
// store old clipping
Tmp := CreateEmptyRegion;
GetClipRGN(DC, Tmp);
// apply new clipping
RGN := CreatePolygonRgn(PThePoints, OldNumPts, LCLType.Winding);
ExtSelectClipRGN(DC, RGN, RGN_AND);
DeleteObject(RGN);
GetClipBox(DC, @ClipRect);
// draw polygon area
DevCtx.FillRect(ClipRect, HBrush({%H-}PtrUInt(DevCtx.GetBrush)), False);
// restore old clipping
SelectClipRGN(DC, Tmp);
DeleteObject(Tmp);
end else
begin
DevCtx.SelectBrushProps;
DevCtx.RemovePixbuf;
gdk_draw_polygon(DevCtx.Drawable, DevCtx.GC, 1, PointArray, NumPts);
end;
end;
// draw outline
if not DevCtx.IsNullPen
then begin
DevCtx.SelectPenProps;
DevCtx.RemovePixbuf;
gdk_draw_polygon(DevCtx.Drawable, DevCtx.GC, 0, PointArray, NumPts);
end;
{$IFDEF DebugGDKTraps}EndGDKErrorTrap;{$ENDIF}
if PointArray <> nil then FreeMem(PointArray);
SetLength(ThePoints,0);
Result := True;
end;
function TGtk2WidgetSet.Polyline(DC: HDC; Points: PPoint; NumPts: Integer): boolean;
var
DevCtx: TGtkDeviceContext absolute DC;
i: integer;
PointArray: PGDKPoint;
DCOrigin, P: TPoint;
begin
if not IsValidDC(DC) then Exit(False);
if NumPts <= 0 then Exit(True);
if DevCtx.IsNullPen then Exit(True);
DCOrigin := DevCtx.Offset;
GetMem(PointArray, SizeOf(TGdkPoint)*NumPts);
for i:=0 to NumPts-1 do
begin
if DevCtx.HasTransf then
P := DevCtx.TransfPointIndirect(Points[I])
else
P := Points[i];
PointArray[i].x := P.x + DCOrigin.X;
PointArray[i].y := P.y + DCOrigin.Y;
end;
// draw line
DevCtx.SelectPenProps;
Result := dcfPenSelected in DevCtx.Flags;
if Result and not DevCtx.IsNullPen
then begin
{$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF}
DevCtx.RemovePixbuf;
gdk_draw_lines(DevCtx.Drawable, DevCtx.GC, PointArray, NumPts);
{$IFDEF DebugGDKTraps}EndGDKErrorTrap;{$ENDIF}
end;
FreeMem(PointArray);
end;
{------------------------------------------------------------------------------
Function: PostMessage
Params: Handle:
Msg:
wParam:
lParam:
Returns: True if succesful
The PostMessage function places (posts) a message in the message queue and
then returns without waiting.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.PostMessage(Handle: HWND; Msg: Cardinal; wParam: WParam;
lParam: LParam): Boolean;
function ParentPaintMessageInQueue: boolean;
var
Target: TControl;
Parent: TWinControl;
ParentHandle: hWnd;
begin
Result:=false;
Target:=TControl(GetLCLObject({%H-}Pointer(Handle)));
if not (Target is TControl) then exit;
Parent:=Target.Parent;
if (Target is TControl) then begin
Parent:=Target.Parent;
while Parent<>nil do begin
ParentHandle:=Parent.Handle;
if fMessageQueue.FindPaintMessage(ParentHandle)<>nil then begin
Result:=true;
end;
Parent:=Parent.Parent;
end;
end;
end;
procedure CombinePaintMessages(NewMsg:PMsg);
// combine NewMsg and OldMsg paint message into NewMsg and free OldMsg
var
vlItem : TGtkMessageQueueItem;
NewData: TLMGtkPaintData;
OldData: TLMGtkPaintData;
OldMsg : PMsg;
begin
vlItem := fMessageQueue.FindPaintMessage(NewMsg^.Hwnd);
if vlItem = nil then exit;
OldMsg := vlItem.Msg;
if OldMsg = nil then exit;
if (NewMsg^.Message = LM_PAINT) or (OldMsg^.Message = LM_PAINT) then
begin
// LM_PAINT means: repaint all
// convert NewMsg into a LM_PAINT if not already done
if NewMsg^.Message <> LM_PAINT then
begin
FinalizePaintTagMsg(NewMsg);
NewMsg^.Message:=LM_PAINT;
end;
end
else
if (NewMsg^.Message <> LM_GTKPAINT) then
RaiseGDBException('CombinePaintMessages A unknown paint message')
else
if (OldMsg^.Message<>LM_GtkPAINT) then
RaiseGDBException('CombinePaintMessages B unknown paint message')
else
begin
// combine the two LM_GtkPAINT messages
NewData := TLMGtkPaintData(NewMsg^.WParam);
OldData := TLMGtkPaintData(OldMsg^.WParam);
NewData.RepaintAll := NewData.RepaintAll or OldData.RepaintAll;
if not NewData.RepaintAll then
begin
NewData.Rect.Left := Min(NewData.Rect.Left, OldData.Rect.Left);
NewData.Rect.Top := Min(NewData.Rect.Top, OldData.Rect.Top);
NewData.Rect.Right := Max(NewData.Rect.Right, OldData.Rect.Right);
NewData.Rect.Bottom := Max(NewData.Rect.Bottom, OldData.Rect.Bottom);
end;
end;
fMessageQueue.RemoveMessage(vlItem, FPMF_All, True);
end;
var
AMessage: PMsg;
begin
Result := True;
//debugln(['TGtk2WidgetSet.PostMessage ',dbgsname(GetLCLObject(Pointer(Handle)))]);
New(AMessage);
FillByte(AMessage^,SizeOf(TMsg),0);
AMessage^.HWnd := Handle; // this is normally the main gtk widget
AMessage^.Message := Msg;
AMessage^.WParam := WParam;
AMessage^.LParam := LParam;
FMessageQueue.Lock;
try
if (AMessage^.Message = LM_PAINT) or (AMessage^.Message = LM_GTKPAINT) then
begin
{ Obsolete, because InvalidateRectangle now works.
// paint messages are the most expensive messages in the LCL
// A paint message to a control will also repaint all child controls.
// -> check if there is already a paint message for one of its parents
// if yes, then skip this message
if ParentPaintMessageInQueue then begin
FinalizePaintTagMsg(AMessage^);
exit;
end;}
// delete old paint message to this widget,
// so that the widget repaints only once
CombinePaintMessages(AMessage);
end;
FMessageQueue.AddMessage(AMessage);
{$IFDEF USE_GTK_MAIN_OLD_ITERATION}
if GetCurrentThreadId <> MainThreadID then
begin
// awake gtk loop
// when the main thread is currently processing messages it will process
// fMessageQueue.
// But when the main thread is waiting for the next gtk message it will
// wait for the next external event before processing fMessageQueue.
// A g_idle_add can only be used if glib multithreading has been enabled
// ToDo: Find out what we loose when enabling multithreading
// or find another way to wake up the gtk loop
{$IFDEF EnabledGtkThreading}
gdk_flush();
g_main_context_wakeup(nil);
{$ELSE}
DebugLn(['TGtk2WidgetSet.PostMessage ToDo: wake up gtk']);
{$ENDIF}
end;
{$ENDIF}
finally
FMessageQueue.UnLock;
end;
{$IFNDEF USE_GTK_MAIN_OLD_ITERATION}
if GetCurrentThreadId <> MainThreadID then
begin
// old glib versions needs another way to wake up.
if (glib_major_version = 2) and
(glib_minor_version < 24) and (FMainPoll <> nil) then
FMainPoll^.revents := 1;
g_main_context_wakeup(g_main_context_default);
end;
{$ENDIF}
end;
{------------------------------------------------------------------------------
Function: PtInRegion
Params: RGN: HRGN; X, Y: Integer
Returns: True if the specified point is in the region.
Determines whether the specified point is inside the specified region.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.PtInRegion(RGN: HRGN; X, Y: Integer): Boolean;
begin
Result := False;
if not IsValidGDIObject(RGN) then
exit;
if ({%H-}PGdiObject(RGN)^.GDIBitmapObject <> nil) or
({%H-}PGdiObject(RGN)^.GDIPixbufObject <> nil) or
({%H-}PGdiObject(RGN)^.GDIPixmapObject.Image <> nil) then
begin
// issue #27080
Result := False;
end else
Result := gdk_region_point_in({%H-}PGdiObject(RGN)^.GDIRegionObject, X, Y);
end;
{------------------------------------------------------------------------------
Method: RadialArc
Params: DC, left, top, right, bottom, sx, sy, ex, ey
Returns: Nothing
Use RadialArc to draw an elliptically curved line with the current Pen. The
values sx,sy, and ex,ey represent the starting and ending radial-points
between which the Arc is drawn.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.RadialArc(DC: HDC; left, top, right, bottom,
sx, sy, ex, ey: Integer): Boolean;
begin
Result := inherited RadialArc(DC, left, top, right, bottom, sx, sy, ex, ey);
end;
{------------------------------------------------------------------------------
Method: RadialChord
Params: DC, x1, y1, x2, y2, sx, sy, ex, ey
Returns: Nothing
Use RadialChord to draw a filled Chord-shape on the canvas. The values sx,sy,
and ex,ey represent the starting and ending radial-points between which
the bounding-Arc is drawn.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.RadialChord(DC: HDC; x1, y1, x2, y2,
sx, sy, ex, ey: Integer): Boolean;
begin
Result := inherited RadialChord(DC, x1, y1, x2, y2, sx, sy, ex, ey);
end;
{------------------------------------------------------------------------------
Function: RealizePalette
Params: DC: HDC
Returns: Nothing
------------------------------------------------------------------------------}
function TGtk2WidgetSet.RealizePalette(DC: HDC): Cardinal;
begin
Result := 0;
if IsValidDC(DC)
then with TGtkDeviceContext(DC) do
begin
end;
end;
{------------------------------------------------------------------------------
Function: Rectangle
Params: DC: HDC; X1, Y1, X2, Y2: Integer
Returns: Nothing
------------------------------------------------------------------------------}
function TGtk2WidgetSet.Rectangle(DC: HDC; X1, Y1, X2, Y2: Integer): Boolean;
var
DevCtx: TGtkDeviceContext absolute DC;
Left, Top, Width, Height: Integer;
DCOrigin: TPoint;
Brush: PGdiObject;
ClipArea: TGdkRectangle;
begin
if not IsValidDC(DC) then Exit(False);
if DevCtx.HasTransf then
DevCtx.TransfRect(X1, Y1, X2, Y2);
CalculateLeftTopWidthHeight(X1, Y1, X2, Y2, Left, Top, Width, Height);
if (Width = 0) or (Height = 0) then Exit(True);
// X2, Y2 is not part of the rectangle
dec(Width);
dec(Height);
// first draw interior in brush color
DevCtx.SelectBrushProps;
DCOrigin := DevCtx.Offset;
{$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF}
if not DevCtx.IsNullBrush then
begin
ClipArea := DevCtx.ClipRect;
Brush := DevCtx.GetBrush;
DevCtx.RemovePixbuf;
if (Brush^.GDIBrushFill = GDK_SOLID) and
(IsBackgroundColor(TColor(Brush^.GDIBrushColor.ColorRef)))
then
StyleFillRectangle(DevCtx.Drawable, DevCtx.GC, Brush^.GDIBrushColor.ColorRef,
Left+DCOrigin.X, Top+DCOrigin.Y, Width, Height, @ClipArea)
else
gdk_draw_rectangle(DevCtx.Drawable, DevCtx.GC, 1,
Left+DCOrigin.X, Top+DCOrigin.Y, Width, Height);
end;
// Draw outline
DevCtx.SelectPenProps;
Result := dcfPenSelected in DevCtx.Flags;
if Result and not DevCtx.IsNullPen
then begin
DevCtx.RemovePixbuf;
gdk_draw_rectangle(DevCtx.Drawable, DevCtx.GC, 0,
Left+DCOrigin.X, Top+DCOrigin.Y, Width, Height);
end;
{$IFDEF DebugGDKTraps}EndGDKErrorTrap;{$ENDIF}
end;
{------------------------------------------------------------------------------
Function: RectInRegion
Params: RGN: HRGN; ARect: TRect
Returns: True if any part of the specified rectangle lies within the
boundaries of the region.
Determines whether any part of the specified rectangle is within the boundaries
of a region.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.RectInRegion(RGN: HRGN; ARect: TRect): Boolean;
var
AGdkRect: TGdkRectangle;
begin
//todo: sanity checks for valid handle etc.
AGdkRect := GdkRectFromRect(ARect);
Result := gdk_region_rect_in({%H-}PGdiObject(RGN)^.GDIRegionObject, @AGdkRect)
<> GDK_OVERLAP_RECTANGLE_OUT;
end;
{------------------------------------------------------------------------------
Function: RectVisible
Params: dc : hdc; ARect: TRect
Returns: True if ARect is not completely clipped away.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.RectVisible(dc: hdc; const ARect: TRect): Boolean;
begin
Result := inherited RectVisible(dc,ARect);
end;
{------------------------------------------------------------------------------
Function: RegroupMenuItem
Params: hndMenu: HMENU; GroupIndex: integer
Returns: Nothing
Move a menuitem into its group
This function is called by the LCL, after some menuitems were regrouped to
GroupIndex. The hndMenu is one of them.
Update all radio groups.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.RegroupMenuItem(hndMenu: HMENU; GroupIndex: integer
): Boolean;
const
GROUPIDX_DATANAME = 'GroupIndex';
function GetGroup: PGSList;
var
Item, orgList: PGList;
parent : PGTKWidget;
begin
Result := nil;
parent := gtk_widget_get_parent({%H-}Pointer(hndMenu));
if parent = nil then Exit;
Item := gtk_container_get_children(PGTKContainer(parent));
orgList := Item;
while Item <> nil do
begin
if (Item^.Data <> {%H-}Pointer(hndMenu)) // exclude ourself
and gtk_is_radio_menu_item(Item^.Data)
and (GroupIndex = Integer({%H-}PtrUInt(g_object_get_data(Item^.Data, GROUPIDX_DATANAME))))
then begin
Result := gtk_radio_menu_item_get_group (PGtkRadioMenuItem(Item^.Data));
Exit;
end;
Item := Item^.Next;
end;
if Assigned(orgList) then
g_list_free(orgList);
end;
var
RadioGroup: PGSList;
//CurrentGroupIndex: Integer;
begin
Result := False;
if not gtk_is_radio_menu_item({%H-}Pointer(hndMenu))
then begin
DebugLn('WARNING: TGtk2WidgetSet.RegroupMenuItem: handle is not a GTK_RADIO_MENU_ITEM');
Exit;
end;
//CurrentGroupIndex := integer({%H-}PtrUInt(g_object_get_data({%H-}Pointer(hndMenu), GROUPIDX_DATANAME)));
// Update needed ?
{ if GroupIndex = CurrentGroupIndex
then begin
Result := True;
Exit;
end;}
// Remove current group
gtk_radio_menu_item_set_group({%H-}PGtkRadioMenuItem(hndMenu), nil);
g_object_set_data({%H-}Pointer(hndMenu), GROUPIDX_DATANAME, nil);
// Check remove only
{ if GroupIndex = 0
then begin
Result := True;
Exit;
end; }
// Try to find new group
RadioGroup := GetGroup;
// Set new group
g_object_set_data({%H-}Pointer(hndMenu), GROUPIDX_DATANAME, {%H-}Pointer(PtrInt(GroupIndex)));
if RadioGroup = nil
then begin
// We're the only member, get a group
RadioGroup := gtk_radio_menu_item_group({%H-}PGtkRadioMenuItem(hndMenu))
end
else begin
gtk_radio_menu_item_set_group({%H-}PGtkRadioMenuItem(hndMenu), RadioGroup);
end;
//radiogroup^.data
//radiogroup^.next
// Refetch newgroup list
RadioGroup := gtk_radio_menu_item_group({%H-}PGtkRadioMenuItem(hndMenu));
// Update checks
UpdateRadioGroupChecks(RadioGroup);
Result := True;
end;
{------------------------------------------------------------------------------
Function: ReleaseCapture
Params: none
Returns: True if succesful
The ReleaseCapture function releases the mouse capture from a window
and restores normal mouse input processing.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.ReleaseCapture: Boolean;
begin
SetCapture(0);
Result := True;
end;
function TGtk2WidgetSet.ReleaseDC(hWnd: HWND; DC: HDC): Integer;
var
aDC, pSavedDC: TGtkDeviceContext;
g: TGDIType;
CurGDIObject: PGDIObject;
begin
//DebugLn(['[TGtk2WidgetSet.ReleaseDC] ',DC,' ',FDeviceContexts.Count]);
Result := 0;
if (DC <> 0)
then begin
if FDeviceContexts.Contains({%H-}Pointer(DC))
then begin
aDC := TGtkDeviceContext(DC);
// clear references to all GDI objects
for g:=Low(TGDIType) to high(TGDIType) do begin
{if aDC.GDIObjects[g]<>nil then
if FindDCWithGDIObject(aDC.GDIObjects[g])=nil then
RaiseGDBException('');}
aDC.GDIObjects[g]:=nil; // clear the reference, decrease DCCount
end;
// Release all saved device contexts (the owned GDI objects will be freed)
pSavedDC:=aDC.SavedContext;
if pSavedDC<>nil then begin
ReleaseDC(0,HDC(pSavedDC));
aDC.SavedContext:=nil;
end;
//DebugLn(['TGtk2WidgetSet.ReleaseDC DC=',dbgs(TGtkDeviceContext(aDC)),' ClipRegion=',dbgs(aDC.ClipRegion)]);
// free all owned GDI objects
for g:=Low(TGDIType) to high(TGDIType) do begin
CurGDIObject:=aDC.OwnedGDIObjects[g];
if CurGDIObject<>nil then begin
if CurGDIObject^.Owner<>aDC then
RaiseGDBException('');
DeleteObject(HGDIOBJ({%H-}PtrUInt(CurGDIObject)));
if aDC.OwnedGDIObjects[g]<>nil then
RaiseGDBException('');
end;
end;
//DebugLn(['TGtk2WidgetSet.ReleaseDC DC=',dbghex(PtrInt(DC)),' Font=',dbghex(PtrInt(aDC.CurrentFont))]);
{FreeGDIColor(aDC.CurrentTextColor);
FreeGDIColor(aDC.CurrentBackColor);}
try
{ On root window, we don't allocate a graphics context and so we do not free}
if aDC.HasGC then
begin
gdk_gc_unref(aDC.GC);
aDC.GC:=nil;
end;
except
on E:Exception do begin
// Nothing, just try to unref it
// (it segfaults if the window doesnt exist anymore :-)
DebugLn('TGtk2WidgetSet.ReleaseDC: ',E.Message);
end;
end;
DisposeDC(aDC);
Result := 1;
end;
end;
end;
{------------------------------------------------------------------------------
Function: RemoveProp
Params: Handle: Handle of the object
Str: Name of the property to remove
Returns: The handle of the property (0=failure)
------------------------------------------------------------------------------}
function TGtk2WidgetSet.RemoveProp(Handle: HWND; Str: PChar): TLCLHandle;
begin
g_object_set_data({%H-}PGObject(handle), Str, nil);
Result := 1;
end;
{------------------------------------------------------------------------------
Function: RestoreDC
Params: none
Returns: Nothing
-------------------------------------------------------------------------------}
function TGtk2WidgetSet.RestoreDC(DC: HDC; SavedDC: Integer): Boolean;
var
DevCtx: TGtkDeviceContext absolute DC;
SavedDevCtx: TGtkDeviceContext;
begin
if not IsValidDC(DC) then Exit(False);
if SavedDC <= 0 then Exit(False);
repeat
SavedDevCtx := DevCtx.SavedContext;
Dec(SavedDC);
// TODO copy bitmap too
// clear the GDIObjects in pSavedDC, so they are not freed by DeleteDC
Result := DevCtx.CopyDataFrom(SavedDevCtx, True, True, True);
DevCtx.SavedContext := SavedDevCtx.SavedContext;
SavedDevCtx.SavedContext := nil;
DevCtx.SelectRegion;
// free saved DC
DeleteDC(HDC(SavedDevCtx));
until SavedDC <= 0;
end;
{------------------------------------------------------------------------------
Method: RoundRect
Params: X1, Y1, X2, Y2, RX, RY
Returns: If succesfull
Draws a Rectangle with optional rounded corners. RY is the radial height
of the corner arcs, RX is the radial width. If either is less than or equal to
0, the routine simly calls to standard Rectangle.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.RoundRect(DC : hDC; X1, Y1, X2, Y2: Integer;
RX,RY : Integer): Boolean;
begin
Result := inherited RoundRect(DC, X1, Y1, X2, Y2, RX, RY);
end;
{------------------------------------------------------------------------------
Function: SaveDc
Params: DC: a DC to save
Returns: 0 if the functions fails otherwise a positive integer identifing
the saved DC
The SaveDC function saves the current state of the specified device
context (DC) by copying its elements to a context stack.
-------------------------------------------------------------------------------}
function TGtk2WidgetSet.SaveDC(DC: HDC): Integer;
var
DevCtx: TGtkDeviceContext absolute DC;
aSavedDC: TGtkDeviceContext;
begin
Result := 0;
if IsValidDC(DC) then
begin
aSavedDC := NewDC;
aSavedDC.CopyDataFrom(DevCtx, False, True, False);
aSavedDC.SavedContext := DevCtx.SavedContext;
DevCtx.SavedContext:= aSavedDC;
Result := 1;
end;
end;
{------------------------------------------------------------------------------
Function: ScreenToClient
Params: Handle:
P:
Returns:
------------------------------------------------------------------------------}
function TGtk2WidgetSet.ScreenToClient(Handle : HWND; var P : TPoint) : Integer;
var
X, Y: Integer;
Widget: PGTKWidget;
Window: PGdkWindow;
Begin
if Handle = 0 then
begin
X := 0;
Y := 0;
end else
begin
Widget := GetFixedWidget({%H-}pgtkwidget(Handle));
if Widget = nil then
Widget := {%H-}pgtkwidget(Handle);
if Widget = nil then
begin
X := 0;
Y := 0;
end else
begin
Window := GetControlWindow(Widget);
{$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF}
if Window <> nil then
begin
gdk_window_get_origin(Window, @X, @Y);
// set pos to client coords. issue #21366
if GTK_WIDGET_NO_WINDOW(Widget) and (gtk_widget_get_parent(Widget) <> nil) then
begin
P.X := P.X - X - Widget^.allocation.x;
P.Y := P.Y - Y - Widget^.allocation.y;
Result := -1;
exit;
end;
end else
begin
X:=0;
Y:=0;
end;
{$IFDEF DebugGDKTraps}EndGDKErrorTrap;{$ENDIF}
end;
end;
//DebugLn('[TGtk2WidgetSet.ScreenToClient] ',x,',',y,' P=',P.X,',',P.Y);
dec(P.X, X);
dec(P.Y, Y);
Result := -1;
end;
{------------------------------------------------------------------------------
Function: ScrollWindowEx
Params: hWnd: handle of window to scroll
dx: horizontal amount to scroll
dy: vertical amount to scroll
prcScroll: pointer to scroll rectangle
prcClip: pointer to clip rectangle
hrgnUpdate: handle of update region
prcUpdate: pointer to update rectangle
flags: scrolling flags
Returns: True if succesfull;
The ScrollWindowEx function scrolls the content of the specified window's
client area
------------------------------------------------------------------------------}
function TGtk2WidgetSet.ScrollWindowEx(hWnd: HWND; dx, dy: Integer; prcScroll, prcClip: PRect; hrgnUpdate: HRGN; prcUpdate: PRect; flags: UINT): Boolean;
var
Widget: PGtkWidget;
Window: PGdkWindow;
{$ifdef GTK_2_8}
Region: PGdkRegion;
RClient, RFullSource, RUsableSource, RTarget, RUsableTarget: TRect;
Rect1: TGdkRectangle;
Rect2: TRect; // area to invalidate
WidgetInfo: PWidgetInfo;
{$ENDIF}
begin
Result := False;
if (dy = 0) and (dx = 0) then exit;
{$IFDEF DisableGtk2ScrollWindow}
exit;
{$ENDIF}
// prcScroll, prcClip are not supported under gdk yet
if (hWnd = 0) then
exit;
// or (prcScroll <> nil) or (prcClip <> nil) then Exit;
Widget := {%H-}pgtkwidget(hWnd);
Widget := GetFixedWidget(Widget);
if Widget = nil then exit;
Window:=GetControlWindow(Widget);
if Window = nil then exit;
Result := true;
{$ifdef GTK_2_8}
RClient.Left := 0;//Widget^.Allocation.Left;
RClient.Top := 0; //Widget^.Allocation.Top;
RClient.Right := Widget^.Allocation.width;
RClient.Bottom := Widget^.Allocation.height;
RFullSource := RClient;
{$ifdef VerboseScrollWindowEx}
DebugLn(['ScrollWindowEx A RClient=', dbgs(RClient),' dy=',dy, ' scroll=',dbgs(prcScroll^), ' clip=',dbgs(prcClip^)]);
{$ENDIF}
// Any part of RFullSource, that is not targeted by the move must later be invalidated
if PrcScroll <> nil then
begin
RFullSource.Left := Max(RClient.Left, PrcScroll^.Left);
RFullSource.Top := Max(RClient.Top, PrcScroll^.Top);
RFullSource.Right := Min(RClient.Right, PrcScroll^.Right);
RFullSource.Bottom := Min(RClient.Bottom, PrcScroll^.Bottom);
end;
// Target is expected to be completly filled with valid content by move,
// any part that can not be filled must be invalidated
RTarget.Left := Max(RClient.Left, RFullSource.Left + dx);
RTarget.Top := Max(RClient.Top, RFullSource.Top + dy);
RTarget.Right := Min(RClient.Right, RFullSource.Right + dx);
RTarget.Bottom := Min(RClient.Bottom, RFullSource.Bottom + dy);
if (PrcClip <> nil) then begin
RTarget.Left := Max(RTarget.Left, prcClip^.Left);
RTarget.Top := Max(RTarget.Top, prcClip^.Top);
RTarget.Right := Min(RTarget.Right, prcClip^.Right);
RTarget.Bottom := Min(RTarget.Bottom, prcClip^.Bottom);
end;
// Only Source that will fit into target
RUsableSource.Left := Max(RTarget.Left - dx, RFullSource.Left);
RUsableSource.Top := Max(RTarget.Top - dy, RFullSource.Top);
RUsableSource.Right := Min(RTarget.Right - dx, RFullSource.Right);
RUsableSource.Bottom := Min(RTarget.Bottom - dy, RFullSource.Bottom);
{$ifdef VerboseScrollWindowEx}
DebugLn(['ScrollWindowEx B RFullSource=', dbgs(RFullSource), ' RUsableSource=', dbgs(RUsableSource)]);
{$ENDIF}
// And also, only Source that is valid
WidgetInfo := GetWidgetInfo(Widget);
if WidgetInfo <> nil then begin
{$ifdef VerboseScrollWindowEx}
DebugLn(['ScrollWindowEx C ', dbgs(WidgetInfo^.UpdateRect)]);
{$ENDIF}
// exclude allready invalidated area
// "UpdateRect.Bottom > 0" => there is an UpdateRect / Top is valid
if (dy < 0) and (WidgetInfo^.UpdateRect.Bottom > 0) then
RUsableSource.Bottom := Min(RUsableSource.Bottom, WidgetInfo^.UpdateRect.Top);
if (dy > 0) and (RUsableSource.Top < WidgetInfo^.UpdateRect.Bottom) then
RUsableSource.Top := WidgetInfo^.UpdateRect.Bottom;
if (dx < 0) and (WidgetInfo^.UpdateRect.Right > 0) then
RUsableSource.Right := Min(RUsableSource.Right, WidgetInfo^.UpdateRect.Left);
if (dx > 0) and (RUsableSource.Left < WidgetInfo^.UpdateRect.Right) then
RUsableSource.Left := WidgetInfo^.UpdateRect.Right;
end;
{$ifdef VerboseScrollWindowEx}
DebugLn(['ScrollWindowEx D RUsableSource=', dbgs(RUsableSource)]);
{$ENDIF}
// TODO: content moved into currently invalidated space, may reduce the inval rect
// All of RUsableTarget should be validated;
RUsableTarget.Left := Max(RTarget.Left, RUsableSource.Left + dx);
RUsableTarget.Top := Max(RTarget.Top, RUsableSource.Top + dy);
RUsableTarget.Right := Min(RTarget.Right, RUsableSource.Right + dx);
RUsableTarget.Bottom := Min(RTarget.Bottom, RUsableSource.Bottom + dy);
{$ifdef VerboseScrollWindowEx}
DebugLn(['ScrollWindowEx D RUsableTarget=', dbgs(RUsableTarget)]);
{$ENDIF}
Rect1 := GdkRectFromRect(RUsableSource);
if (Rect1.height > 0) and (Rect1.width > 0) then begin
Region := gdk_region_rectangle(@Rect1);
gdk_window_move_region(Window, Region, dx, dy);
gdk_region_destroy(Region);
if (flags and SW_INVALIDATE) <> 0 then begin
//invalidate
If RUsableTarget.Left > RFullSource.Left then begin
Rect2 := RFullSource;
Rect2.Right:= RUsableTarget.Left;
{$ifdef VerboseScrollWindowEx}DebugLn(['ScrollWindowEx Invalidate Src Left', dbgs(Rect2)]);{$ENDIF}
InvalidateRect(hWnd, @Rect2, false);
if (prcUpdate <> nil) and (dx > 0) then prcUpdate^ := Rect2;
end;
If RUsableTarget.Right < RFullSource.Right then begin
Rect2 := RFullSource;
Rect2.Left:= RUsableTarget.Right;
{$ifdef VerboseScrollWindowEx}DebugLn(['ScrollWindowEx Invalidate Src Right', dbgs(Rect2)]);{$ENDIF}
InvalidateRect(hWnd, @Rect2, false);
if (prcUpdate <> nil) and (dx < 0) then prcUpdate^ := Rect2;
end;
If RUsableTarget.Top > RFullSource.Top then begin
Rect2 := RFullSource;
Rect2.Bottom:= RUsableTarget.Top;
{$ifdef VerboseScrollWindowEx}DebugLn(['ScrollWindowEx Invalidate Src Top', dbgs(Rect2)]);{$ENDIF}
InvalidateRect(hWnd, @Rect2, false);
if (prcUpdate <> nil) and (dy > 0) then prcUpdate^ := Rect2;
end;
If RUsableTarget.Bottom < RFullSource.Bottom then begin
Rect2 := RFullSource;
Rect2.Top:= RUsableTarget.Bottom;
{$ifdef VerboseScrollWindowEx}DebugLn(['ScrollWindowEx Invalidate Src Bottom', dbgs(Rect2)]);{$ENDIF}
InvalidateRect(hWnd, @Rect2, false);
if (prcUpdate <> nil) and (dy < 0) then prcUpdate^ := Rect2;
end;
If RUsableTarget.Left > RTarget.Left then begin
Rect2 := RTarget;
Rect2.Right:= RUsableTarget.Left;
{$ifdef VerboseScrollWindowEx}DebugLn(['ScrollWindowEx Invalidate TARGET Left', dbgs(Rect2)]);{$ENDIF}
InvalidateRect(hWnd, @Rect2, false);
end;
If RUsableTarget.Right < RTarget.Right then begin
Rect2 := RTarget;
Rect2.Left:= RUsableTarget.Right;
{$ifdef VerboseScrollWindowEx}DebugLn(['ScrollWindowEx Invalidate TARGET Right', dbgs(Rect2)]);{$ENDIF}
InvalidateRect(hWnd, @Rect2, false);
end;
If RUsableTarget.Top > RTarget.Top then begin
Rect2 := RTarget;
Rect2.Bottom:= RUsableTarget.Top;
{$ifdef VerboseScrollWindowEx}DebugLn(['ScrollWindowEx Invalidate TARGET Top', dbgs(Rect2)]);{$ENDIF}
InvalidateRect(hWnd, @Rect2, false);
end;
If RUsableTarget.Bottom < RTarget.Bottom then begin
Rect2 := RTarget;
Rect2.Top:= RUsableTarget.Bottom;
{$ifdef VerboseScrollWindowEx}DebugLn(['ScrollWindowEx Invalidate TARGET Bottom', dbgs(Rect2)]);{$ENDIF}
InvalidateRect(hWnd, @Rect2, false);
end;
end;
end
else begin
if (flags and SW_INVALIDATE) <> 0 then begin
// invalidate, nothing to scroll
{$ifdef VerboseScrollWindowEx}DebugLn(['ScrollWindowEx Invalidate all', dbgs(RUsableSource)]);{$ENDIF}
InvalidateRect(hWnd, @RFullSource, false);
InvalidateRect(hWnd, @RTarget, false);
end
else
Result := False;
end;
{$ELSE}
gdk_window_scroll(Window, dx, dy);
Result := true;
{$ENDIF}
end;
{------------------------------------------------------------------------------
Function: SelectClipRGN
Params: DC, RGN
Returns: longint
Sets the DeviceContext's ClipRegion. The Return value
is the new clip regions type, or ERROR.
The result can be one of the following constants
Error
NullRegion
SimpleRegion
ComplexRegion
------------------------------------------------------------------------------}
function TGtk2WidgetSet.SelectClipRGN(DC: hDC; RGN: HRGN): Longint;
var
DevCtx: TGtkDeviceContext absolute DC;
RegObj: PGdkRegion;
DCOrigin: TPoint;
OldClipRegion: PGDIObject;
begin
if not IsValidDC(DC) then Exit(ERROR);
// clear old clipregion
if Assigned(DevCtx.ClipRegion) then
begin
OldClipRegion := DevCtx.ClipRegion;
DevCtx.ClipRegion := nil;// decrease DCCount
if OldClipRegion = DevCtx.OwnedGDIObjects[gdiRegion] then
DeleteObject(HGDIOBJ({%H-}PtrUInt(OldClipRegion)));
end;
if RGN = 0 then
begin
DevCtx.SelectRegion;
Exit(NULLREGION);
end;
if IsValidGDIObject(RGN) then
begin
DevCtx.ClipRegion := {%H-}PGdiObject(CreateRegionCopy(RGN));
DevCtx.OwnedGDIObjects[gdiRegion] := DevCtx.ClipRegion;
RegObj := DevCtx.ClipRegion^.GDIRegionObject;
DCOrigin := DevCtx.Offset;
gdk_region_offset(RegObj, DCOrigin.x, DCOrigin.Y);
DevCtx.SelectRegion;
Exit(RegionType(RegObj));
end;
// error handling
Result := ERROR;
DebugLn('WARNING: [TGtk2WidgetSet.SelectClipRGN] Invalid RGN');
{$ifdef TraceGdiCalls}
DebugLn();
DebugLn('TraceCall for invalid object: ');
DumpBackTrace(PgdiObject(RGN)^.StackAddrs);
DebugLn();
{$endif}
end;
{------------------------------------------------------------------------------
Function: SelectObject
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtk2WidgetSet.SelectObject(DC: HDC; GDIObj: HGDIOBJ): HGDIOBJ;
var
DevCtx: TGtkDeviceContext absolute DC;
GDIObject: PGdiObject absolute GDIObj;
ResultObj: PGdiObject absolute Result;
procedure RaiseInvalidGDIType;
begin
RaiseGDBException('TGtk2WidgetSet.SelectObject Invalid GDIType '+IntToStr(ord({%H-}PGdiObject(GDIObj)^.GDIType)));
end;
{$ifdef DebugLCLComponents}
procedure DebugInvalidDC;
begin
DebugLn(['TGtk2WidgetSet.SelectObject DC=',dbghex(DC),' IsValidDC(DC)=',IsValidDC(DC),' GDIObj=',dbghex(GDIObj)]);
DumpStack;
DebugLn(['DebugInvalidGDIObject DC:']);
Debugln(DebugDeviceContexts.GetInfo(Pointer(DC),true));
end;
procedure DebugInvalidGDIObject;
begin
DebugLn(['TGtk2WidgetSet.SelectObject DC=',dbghex(DC),' GDIObj=',dbghex(GDIObj),' IsValidGDIObject(GDIObj)=',IsValidGDIObject(GDIObj)]);
DumpStack;
DebugLn(['DebugInvalidGDIObject GDIObj:']);
Debugln(DebugGdiObjects.GetInfo(Pointer(GDIObj),true));
end;
{$endif}
begin
Result := 0;
if not IsValidDC(DC)
then begin
{$ifdef DebugLCLComponents}
DebugInvalidDC;
{$endif}
Exit;
end;
if not IsValidGDIObject(GDIObj)
then begin
{$ifdef DebugLCLComponents}
DebugInvalidGDIObject;
{$endif}
Exit;
end;
case GDIObject^.GDIType of
gdiPen,
gdiBitmap:
ResultObj := DevCtx.SelectObject(GDIObject);
gdiBrush: begin
ResultObj := DevCtx.GetBrush;// always create, because a valid GDIObject is needed to restore
if DevCtx.CurrentBrush = GDIObject then Exit;
DevCtx.CurrentBrush := GDIObject;
DevCtx.SelectedColors := dcscCustom;
end;
gdiFont: begin
ResultObj := DevCtx.GetFont;// always create, because a valid GDIObject is needed to restore
if (DevCtx.CurrentFont = GDIObject) and not DevCtx.HasTransf then Exit;
DevCtx.CurrentFont := GDIObject;
DevCtx.SetTextMetricsValid(False);
DevCtx.SelectedColors := dcscCustom;
end;
gdiRegion: begin
ResultObj := DevCtx.ClipRegion;
if DevCtx.GC <> nil
then SelectClipRGN(DC, GDIObj)
else DevCtx.ClipRegion := nil;
end;
else
RaiseInvalidGDIType;
end;
end;
{------------------------------------------------------------------------------
Function: SelectPalette
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtk2WidgetSet.SelectPalette(DC: HDC; Palette: HPALETTE; ForceBackground: Boolean): HPALETTE;
begin
//TODO: Implement this;
Result := 0;
end;
{------------------------------------------------------------------------------
Function: SendMessage
Params: hWnd:
Msg:
wParam:
lParam:
Returns:
The SendMessage function sends the specified message to a window or windows.
The function calls the window procedure for the specified window and does
not return until the window procedure has processed the message.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.SendMessage(HandleWnd: HWND; Msg: Cardinal; wParam: WParam;
lParam: LParam): LResult;
var
OldMsg: Cardinal;
procedure PreparePaintMessage({%H-}TargetObject: TObject; var AMessage: TLMessage);
var
GtkPaintData: TLMGtkPaintData;
OldGtkPaintMsg: TLMGtkPaint;
begin
(* MG: old trick. Not used anymore, but it might be, that someday there
will be component, that works better with this, so it is kept.
{ The LCL repaints controls in a top-down hierachy. But the gtk sends
gtkdraw events bottom-up. So, controls at the bottom are repainted
many times. To avoid this the queue is checked for LM_PAINT messages
for the parent control. If there is a parent LM_PAINT, this message
is ignored.}
if (Target is TControl) then begin
ParentControl:=TControl(Target).Parent;
while ParentControl<>nil do begin
ParentHandle:=TWinControl(ParentControl).Handle;
if FindPaintMessage(ParentHandle)<>nil then begin
{$IFDEF VerboseDsgnPaintMsg}
if (csDesigning in TComponent(Target).ComponentState) then begin
DebugLn('TGtk2WidgetSet.SendMessage A ',
TComponent(Target).Name,':',Target.ClassName,
' Parent Message found: ',ParentControl.Name,':',ParentControl.ClassName
);
end;
{$ENDIF}
if Msg=LM_PAINT then
ReleaseDC(0,AMessage.WParam);
//exit;
end;
ParentControl:=ParentControl.Parent;
end;
end; *)
{$IFDEF VerboseDsgnPaintMsg}
if (csDesigning in TComponent(TargetObject).ComponentState) then begin
write('TGtk2WidgetSet.SendMessage B ',
TComponent(TargetObject).Name,':',TargetObject.ClassName,
' GtkPaint=',AMessage.Msg=LM_GtkPAINT);
if AMessage.Msg=LM_GtkPAINT then begin
if AMessage.wParam<>0 then begin
with TLMGtkPaintData(AMessage.wParam) do begin
write(' GtkPaintData(',
' Widget=',DbgS(Widget),'=',GetWidgetClassName(Widget),
' State=',State,
' Rect=',Rect.Left,',',Rect.Top,',',Rect.Right,',',Rect.Bottom,
' RepaintAll=',RepaintAll,
')');
end;
end else begin
write(' GtkPaintData=nil');
end;
end;
DebugLn('');
end;
{$ENDIF}
if AMessage.Msg = LM_GTKPAINT
then begin
OldGtkPaintMsg := TLMGtkPaint(AMessage);
GtkPaintData := OldGtkPaintMsg.Data;
// convert LM_GTKPAINT to LM_PAINT
AMessage := TLMessage(GtkPaintMessageToPaintMessage(
TLMGtkPaint(AMessage), False));
GtkPaintData.Free;
end;
end;
procedure DisposePaintMessage({%H-}TargetObject: TObject; var AMessage: TLMessage);
begin
if OldMsg = LM_GTKPAINT then
begin
FinalizePaintMessage(@AMessage);
end
else
if (AMessage.Msg = LM_PAINT) and (AMessage.WParam <> 0) then
begin
// free DC
ReleaseDC(0, AMessage.WParam);
AMessage.WParam := 0;
end;
end;
var
AMessage: TLMessage;
Target: TObject;
begin
OldMsg := Msg;
AMessage.Msg := Msg;
AMessage.WParam := WParam;
AMessage.LParam := LParam;
AMessage.Result := 0;
Target := GetLCLObject({%H-}Pointer(HandleWnd));
if Target <> nil then
begin
if (Msg = LM_PAINT) or (Msg = LM_GTKPAINT) then
begin
PreparePaintMessage(Target,AMessage);
Result := DoDeliverPaintMessage(Target, TLMPaint(AMessage));
end
else
Result := DeliverMessage(Target, AMessage); // deliver it
if (Msg = LM_PAINT) or (Msg = LM_GTKPAINT) then
DisposePaintMessage(Target, AMessage);
end;
end;
{------------------------------------------------------------------------------
function SetActiveWindow(Handle: HWND): HWND;
------------------------------------------------------------------------------}
function TGtk2WidgetSet.SetActiveWindow(Handle: HWND): HWND;
begin
// ToDo
Result := GetActiveWindow;
if (Handle <> 0) and GtkWidgetIsA({%H-}PGtkWidget(Handle),GTK_TYPE_WINDOW) then
begin
if GTK_WIDGET_VISIBLE({%H-}PGtkWidget(Handle)) then
gtk_window_present({%H-}PGtkWindow(Handle));
end else
Result := 0; // if not active window return error
end;
{------------------------------------------------------------------------------
Function: SetBkColor pbd
Params: DC: Device context to change the text background color
Color: RGB Tuple
Returns: Old Background color
------------------------------------------------------------------------------}
function TGtk2WidgetSet.SetBkColor(DC: HDC; Color: TColorRef): TColorRef;
begin
Result := CLR_INVALID;
if IsValidDC(DC)
then begin
with TGtkDeviceContext(DC) do
begin
Result := CurrentBackColor.ColorRef;
SetGDIColorRef(CurrentBackColor,Color);
end;
end;
end;
{------------------------------------------------------------------------------
Function: SetBkMode
Params: DC:
bkMode:
Returns:
------------------------------------------------------------------------------}
function TGtk2WidgetSet.SetBkMode(DC: HDC; bkMode: Integer) : Integer;
var
DevCtx: TGtkDeviceContext absolute DC;
begin
// Your code here
Result := DevCtx.BkMode;
DevCtx.BkMode := bkMode;
end;
{------------------------------------------------------------------------------
Function: SetCapture
Params: Value: Handle of window to capture
Returns: Nothing
------------------------------------------------------------------------------}
function TGtk2WidgetSet.SetCapture(AHandle: HWND): HWND;
var
Widget: PGtkWidget;
CaptureWidget: PGtkWidget;
{$IfDef VerboseMouseCapture}
toplevel: PGtkWidget;
WndGroup: PGtkWindowGroup;
DefWndGroup: PGtkWindowGroup;
{$EndIf}
begin
Widget := {%H-}PGtkWidget(AHandle);
{$IfDef VerboseMouseCapture}
DebugLn('TGtk2WidgetSet.SetCapture Widget=[',GetWidgetDebugReport(Widget),'] gtk=[',GetWidgetDebugReport(gtk_grab_get_current),'] MouseCaptureWidget=[',GetWidgetDebugReport(MouseCaptureWidget),']');
{$EndIf}
// return old capture handle
Result := GetCapture;
if (Result <> 0) then begin
{$IfDef VerboseMouseCapture}
DebugLn('TGtk2WidgetSet.SetCapture gtk_grab_remove=[',GetWidgetDebugReport(gtk_grab_get_current),']');
{$EndIf}
gtk_grab_remove(gtk_grab_get_current);
end;
if (MouseCaptureWidget<>nil) and (gtk_grab_get_current=nil)
and (GTK_WIDGET_HAS_GRAB(MouseCaptureWidget))
then begin
{$IfDef VerboseMouseCapture}
DebugLn('TGtk2WidgetSet.SetCapture gtk_grab_get_current=nil, but GTK_WIDGET_HAS_GRAB(MouseCaptureWidget)=true => gtk_grab_remove=[',GetWidgetDebugReport(MouseCaptureWidget),']');
{$EndIf}
gtk_grab_remove(MouseCaptureWidget);
end;
MouseCaptureWidget := nil;
if Widget = nil then
exit;
CaptureWidget := GetDefaultMouseCaptureWidget(Widget);
if CaptureWidget = nil then begin
{$IfDef VerboseMouseCapture}
DebugLn('TGtk2WidgetSet.SetCapture GetDefaultMouseCaptureWidget failed for widget=[',GetWidgetDebugReport(Widget),']');
{$EndIf}
exit;
end;
{$IfDef VerboseMouseCapture}
// ubuntu liboverlay intercepts gtk_grab_add for LCLWinapiClient
// ToDo: find out how to grab LCLWinapiClient with ubuntu liboverlay
if GtkWidgetIsA(Widget,GTK_TYPE_SCROLLED_WINDOW) then
begin
debugln(['TGtk2WidgetSet.SetCapture is api widget ',
' widget=',GetWidgetClassName(Widget),
' container.container.focus_child=',GetWidgetClassName(PGtkScrolledWindow(Widget)^.container.container.focus_child),
' container.child=',GetWidgetClassName(PGtkScrolledWindow(Widget)^.container.child),
'']);
//CaptureWidget:=PGtkScrolledWindow(Widget)^.container;
end;
{$EndIf}
{$IfDef VerboseMouseCapture}
DebugLn(['TGtk2WidgetSet.SetCapture gtk_grab_add=[',GetWidgetDebugReport(CaptureWidget),'] has_grab=',gtk_widget_has_grab(CaptureWidget),' is_sensitive=',gtk_widget_is_sensitive(CaptureWidget)]);
toplevel := gtk_widget_get_toplevel(CaptureWidget);
if (toplevel<>nil)
and (ord(gdk_window_get_window_type (toplevel^.window)) = GDK_WINDOW_OFFSCREEN_lcl)
then begin
debugln(['WARNING: TGtk2WidgetSet.SetCapture capturewidget is offscreen']);
end;
WndGroup := GetGtkWindowGroup(CaptureWidget);
DefWndGroup:=GetGtkWindowGroup(CaptureWidget);
debugln(['TGtk2WidgetSet.SetCapture WndGroup=',dbgs(WndGroup),' DefWndGroup=',dbgs(DefWndGroup),' same=',WndGroup=DefWndGroup]);
// Note: liboverlay: gtk_grab_add sets gtk_widget_has_grab, but gtk_grab_get_current returns nil
// ToDo: check window group
{$EndIf}
MouseCaptureWidget := CaptureWidget;
gtk_grab_add(CaptureWidget);
if gtk_grab_get_current=CaptureWidget then
begin
{$IfDef VerboseMouseCapture}
DebugLn('TGtk2WidgetSet.SetCapture gtk_grab_add success: gtk_grab_get_current=[',GetWidgetDebugReport(gtk_grab_get_current),']')
{$EndIf}
end
else begin
{$IfDef VerboseMouseCapture}
if gtk_widget_has_grab(CaptureWidget) then
DebugLn('WARNING: TGtk2WidgetSet.SetCapture gtk_grab_add failed (partial success): gtk_grab_get_current=[',GetWidgetDebugReport(gtk_grab_get_current),'] has_grab=true')
else
DebugLn('WARNING: TGtk2WidgetSet.SetCapture gtk_grab_add failed (complete): gtk_grab_get_current=[',GetWidgetDebugReport(gtk_grab_get_current),'] has_grab=false');
{$EndIf}
end;
if MouseCaptureWidget<>nil then
SendMessage(HWnd({%H-}PtrUInt(MouseCaptureWidget)), LM_CAPTURECHANGED, 0, Result);
end;
{------------------------------------------------------------------------------
Function: SetCaretPos
Params: new position x, y
Returns: true on success
------------------------------------------------------------------------------}
function TGtk2WidgetSet.SetCaretPos(X, Y: Integer): Boolean;
var
FocusObject: PGTKObject;
begin
FocusObject := {%H-}PGTKObject(GetFocus);
Result:=SetCaretPosEx({%H-}PtrUInt(FocusObject),X,Y);
end;
{------------------------------------------------------------------------------
Function: SetCaretPos
Params: new position x, y
Returns: true on success
------------------------------------------------------------------------------}
function TGtk2WidgetSet.SetCaretPosEx(Handle: HWnd; X, Y: Integer): Boolean;
var
GtkObject: PGTKObject;
begin
GtkObject := {%H-}PGTKObject(Handle);
Result := GtkObject <> nil;
if Result then begin
if gtk_type_is_a(g_object_type(GtkObject), GTKAPIWidget_GetType)
then begin
GTKAPIWidget_SetCaretPos(PGTKAPIWidget(GtkObject), X, Y);
end
// else if // TODO: other widgettypes
else begin
Result := False;
end;
end;
end;
{------------------------------------------------------------------------------
Function: SetCaretRespondToFocus
Params: handle : Handle of a TWinControl
ShowHideOnFocus: true = caret is hidden on focus lost
Returns: true on success
------------------------------------------------------------------------------}
function TGtk2WidgetSet.SetCaretRespondToFocus(handle: HWND;
ShowHideOnFocus: boolean): Boolean;
begin
if handle<>0 then begin
if gtk_type_is_a(g_object_type({%H-}PGTKObject(handle)), GTKAPIWidget_GetType)
then begin
GTKAPIWidget_SetCaretRespondToFocus({%H-}PGTKAPIWidget(handle),
ShowHideOnFocus);
Result:=true;
end
else begin
Result := False;
end;
end else
Result:=false;
end;
{------------------------------------------------------------------------------
Function: SetCursor
Params : hCursor - cursor handle
Returns : current cursor
------------------------------------------------------------------------------}
function TGtk2WidgetSet.SetCursor(ACursor: HCURSOR): HCURSOR;
begin
// set global gtk cursor
Result := FGlobalCursor;
if ACursor = FGlobalCursor then Exit;
if ACursor = Screen.Cursors[crDefault]
then SetGlobalCursor(0)
else SetGlobalCursor(ACursor);
FGlobalCursor := ACursor;
end;
{------------------------------------------------------------------------------
Function: SetCursorPos
Params: X:
Y:
Returns:
------------------------------------------------------------------------------}
function TGtk2WidgetSet.SetCursorPos(X, Y: Integer): Boolean;
{$ifdef GTK_2_8}
begin
gdk_display_warp_pointer(gdk_display_get_default(), gdk_screen_get_default(), X, Y);
Result := True;
end;
{$else GTK_2_8}
{$IFDEF HasX}
var
dpy: PDisplay;
begin
Result := False;
{$IFDEF DebugGDKTraps}
BeginGDKErrorTrap;
{$ENDIF}
try
dpy := gdk_display;
XWarpPointer(dpy, 0, RootWindow(dpy, DefaultScreen(dpy)), 0, 0, 0, 0, X, Y);
Result := True;
XFlush(dpy);
finally
{$IFDEF DebugGDKTraps}EndGDKErrorTrap;{$ENDIF}
end;
end;
{$ELSE HasX}
begin
Result := False;
DebugLn('TGtk2WidgetSet.SetCursorPos not implemented for this platform');
// Can this call TWin32WidgetSet.SetCursorPos?
end;
{$ENDIF HasX}
{$endif GTK_2_8}
{------------------------------------------------------------------------------
Function: SetFocus
Params: hWnd: Handle of new focus window
Returns: The old focus window
The SetFocus function sets the keyboard focus to the specified window
------------------------------------------------------------------------------}
function TGtk2WidgetSet.SetFocus(hWnd: HWND): HWND;
{off $DEFINE VerboseFocus}
var
Widget, TopLevel, NewFocusWidget: PGtkWidget;
Info: PWidgetInfo;
{$IfDef VerboseFocus}
AWinControl: TWinControl;
{$EndIf}
NewTopLevelWidget: PGtkWidget;
NewTopLevelObject: TObject;
NewForm: TCustomForm;
begin
if hwnd = 0 then
begin
Result:=0;
exit;
end;
Widget:={%H-}PGtkWidget(hWnd);
{$IfDef VerboseFocus}
DebugLn('');
DebuglnEnter('TGtk2WidgetSet.SetFocus INIT');
DebugLn('A hWnd=',GetWidgetDebugReport(Widget));
//DebugLn(getStackTrace(true));
//if GtkWidgetIsA(Widget,GTK_TYPE_NOTEBOOK) then DumpStack;
{$EndIf}
// return the old focus handle
Result := GetFocus;
NewFocusWidget := nil;
TopLevel := gtk_widget_get_toplevel(Widget);
{$IfDef VerboseFocus}
Debugln('B TopLevel=',DbgS(TopLevel),' OldFocus=',GetWidgetDebugReport(PGtkWidget(Result)));
if not GTK_WIDGET_VISIBLE(Widget) then begin
DebugLnExit('TGtk2WidgetSet.SetFocus EXIT: Widget is not visible');
raise Exception.Create('TGtk2WidgetSet.SetFocus: Widget is not visible');
end;
{$EndIf}
if Result=hWnd then begin
{$IfDef VerboseFocus}
DebugLnExit('TGtk2WidgetSet.SetFocus EXIT: focusing same control');
{$EndIf}
exit;
end;
if GtkWidgetIsA(TopLevel, gtk_window_get_type) then
begin
// TopLevel is a gtkwindow
{$IfDef VerboseFocus}
AWinControl:=TWinControl(GetNearestLCLObject(PGtkWindow(TopLevel)^.focus_widget));
DbgOut('C TopLevel is a gtkwindow ');
DbgOut(' focus_widget=',DbgS(PGtkWindow(TopLevel)^.focus_widget));
DebugLn(' LCLParent=',dbgsName(AWinControl));
{$EndIf}
NewTopLevelObject:=GetNearestLCLObject(TopLevel);
if (NewTopLevelObject is TCustomForm) then
begin
NewForm := TCustomForm(NewTopLevelObject);
if Screen.GetCurrentModalFormZIndex > Screen.CustomFormZIndex(NewForm) then
begin
// there is a modal form above -> focus forbidden
{$IfDef VerboseFocus}
DebugLn(' there is a modal form above -> focus forbidden');
{$EndIf}
exit;
end;
end;
NewFocusWidget := FindFocusWidget(Widget);
{$IfDef VerboseFocus}
DbgOut('G NewFocusWidget=',DbgS(NewFocusWidget),' ',DbgSName(GetNearestLCLObject(NewFocusWidget)));
DbgOut([' WidVisible=',GTK_WIDGET_VISIBLE(PGtkWidget(NewFocusWidget))]);
DbgOut([' WidRealized=',GTK_WIDGET_REALIZED(PGtkWidget(NewFocusWidget))]);
DbgOut([' WidMapped=',GTK_WIDGET_MAPPED(PGtkWidget(NewFocusWidget))]);
DbgOut([' WidCanfocus=',GTK_WIDGET_CAN_FOCUS(PGtkWidget(NewFocusWidget))]);
DbgOut([' TopLvlVisible=',GTK_WIDGET_VISIBLE(PGtkWidget(TopLevel))]);
DebugLn('');
{$EndIf}
if (NewFocusWidget<>nil) and GTK_WIDGET_CAN_FOCUS(NewFocusWidget) then
begin
if (PGtkWindow(TopLevel)^.Focus_Widget<>NewFocusWidget) then
begin
{$IfDef VerboseFocus}
DebugLn('H SETTING NewFocusWidget=',dbgs(NewFocusWidget),' ',DbgSName(GetNearestLCLObject(NewFocusWidget)));
//DebugLn('TGtk2WidgetSet.SetFocus TopLevel[',DebugGtkWidgets.GetInfo(TopLevel,false),'] NewFocusWidget=[',DebugGtkWidgets.GetInfo(NewFocusWidget,false),']');
DebugLnEnter('Recursive focus INIT');
{$EndIf}
gtk_window_set_focus(PGtkWindow(TopLevel), NewFocusWidget);
{$IfDef VerboseFocus}
DebugLnExit('Recursive focus DONE');
DebugLn('I NewTopLevel FocusWidget=',DbgS(PGtkWindow(TopLevel)^.Focus_Widget),' Success=',dbgs(PGtkWindow(TopLevel)^.Focus_Widget=NewFocusWidget));
{$EndIf}
end;
end;
end
else begin
NewFocusWidget:=Widget;
end;
if (NewFocusWidget <> nil) and not gtk_widget_has_focus(NewFocusWidget) then
begin
// grab the focus to the parent window
NewTopLevelWidget := gtk_widget_get_toplevel(NewFocusWidget);
NewTopLevelObject := GetNearestLCLObject(NewTopLevelWidget);
if (Screen<>nil) and (Screen.GetCurrentModalForm<>nil) and (NewTopLevelObject <>Screen.GetCurrentModalForm) then
begin
{$IFDEF VerboseFocus}
DebugLn('There is a modal form -> not grabbing');
{$ENDIF}
end
else
begin
{$IfDef VerboseFocus}
DebugLn('J Grabbing focus ',GetWidgetDebugReport(NewFocusWidget));
{$EndIf}
if NewTopLevelObject is TCustomForm then
begin
Info := GetWidgetInfo(NewTopLevelWidget);
if (Info <> nil) and not (wwiActivating in Info^.Flags) then
SetForegroundWindow(TCustomForm(NewTopLevelObject).Handle);
end;
gtk_widget_grab_focus(NewFocusWidget);
end;
end;
{$IfDef VerboseFocus}
AWinControl:=TWinControl(GetNearestLCLObject(NewFocusWidget));
NewFocusWidget:=PGtkWidget(GetFocus);
DebugLnExit('TGtk2WidgetSet.SetFocus END hWnd=',DbgS(hWnd),
' NewFocus=',DbgS(NewFocusWidget),
' NewLCLParent=',dbgsName(AWinControl));
{$EndIf}
end;
{------------------------------------------------------------------------------
Function: SetForegroundWindow
Params: hWnd:
Returns:
------------------------------------------------------------------------------}
function TGtk2WidgetSet.SetForegroundWindow(hWnd : HWND): boolean;
var
{$IFDEF VerboseFocus}
LCLObject: TControl;
{$ENDIF}
GdkWindow: PGdkWindow;
AForm: TCustomForm;
begin
{$IFDEF VerboseFocus}
DbgOut('TGtk2WidgetSet.SetForegroundWindow hWnd=',DbgS(hWnd));
LCLObject:=TControl(GetLCLObject(Pointer(hWnd)));
if LCLObject<>nil then
DebugLn(' LCLObject=',LCLObject.Name,':',LCLObject.ClassName)
else
DebugLn(' LCLObject=nil');
{$ENDIF}
Result := GtkWidgetIsA({%H-}PGtkWidget(hWnd),GTK_TYPE_WINDOW);
if Result then
begin
GdkWindow := GetControlWindow({%H-}PgtkWidget(hwnd));
if GdkWindow <> nil then
begin
if not gdk_window_is_visible(GdkWindow) then
begin
Result := False;
Exit;
end;
AForm := TCustomForm(GetLCLObject({%H-}PgtkWidget(hwnd)));
if (AForm is TCustomForm) and (AForm.Parent=nil) then
begin
if Screen.CustomFormZIndex(AForm) < Screen.GetCurrentModalFormZIndex then
begin
debugln('TGtk2WidgetSet.SetForegroundWindow Form=',DbgSName(AForm),
' can not be raised, because ',
DbgSName(Screen.GetCurrentModalForm),
' is modal and above.');
Result := False;
exit;
end;
Screen.MoveFormToZFront(AForm);
end;
{$IFDEF DebugGDKTraps}
BeginGDKErrorTrap;
{$ENDIF}
gdk_window_show(GdkWindow);
gdk_window_raise(GdkWindow);
gdk_window_focus(GdkWindow, gtk_get_current_event_time);
{$IFDEF DebugGDKTraps}
EndGDKErrorTrap;
{$ENDIF}
// this currently will bring the window to the current desktop and focus it
gtk_window_present({%H-}PGtkWindow(hWnd));
end;
end;
end;
function TGtk2WidgetSet.SetMapMode(DC: HDC; fnMapMode : Integer): Integer;
var
DevCtx: TGtkDeviceContext absolute DC;
begin
Result := Integer(False);
if not IsValidDC(DC) then Exit(0);
DevCtx.MapMode := fnMapMode;
Result := Integer(True);
end;
function TGtk2WidgetSet.SetParent(hWndChild: HWND; hWndParent: HWND): HWND;
var
Fixed: PGtkWidget;
LCLObject: TObject;
begin
Result := GetParent(hWndChild);
if Result = hWndParent then
Exit;
// for window we need to move it content to HBox
if GTK_IS_WINDOW({%H-}PGtkWidget(hWndChild)) then
begin
LCLObject := GetLCLObject({%H-}PGtkWidget(hWndChild));
if LCLObject <> nil then
Controls.RecreateWnd(TWinControl(LCLObject));
Exit;
end;
if Result <> 0 then
begin
// unparent first
gtk_widget_ref({%H-}PGtkWidget(hWndChild));
if GTK_IS_CONTAINER({%H-}Pointer(Result)) then
gtk_container_remove({%H-}PGtkContainer(Result), {%H-}PGtkWidget(hWndChild))
else
gtk_widget_unparent({%H-}PGtkWidget(hWndChild));
end;
Fixed := GetFixedWidget({%H-}PGtkWidget(hWndParent));
if Fixed <> nil then
begin
FixedPutControl(Fixed, {%H-}PGtkWidget(hWndChild), {%H-}PGtkWidget(hWndChild)^.allocation.x, {%H-}PGtkWidget(hWndChild)^.allocation.y);
RegroupAccelerator({%H-}PGtkWidget(hWndChild));
end
else
gtk_widget_set_parent({%H-}PGtkWidget(hWndChild), {%H-}PGtkWidget(hWndParent));
if Result <> 0 then
gtk_widget_unref({%H-}PGtkWidget(hWndChild));
end;
{------------------------------------------------------------------------------
function TGtk2WidgetSet.SetProp(Handle: hwnd; Str : PChar;
Data : Pointer) : Boolean;
------------------------------------------------------------------------------}
function TGtk2WidgetSet.SetProp(Handle: hwnd; Str : PChar; Data : Pointer) : Boolean;
begin
g_object_set_data({%H-}pGObject(handle),Str,data);
Result:=true;
end;
{------------------------------------------------------------------------------
Method: SetRectRgn
Params: aRGN: HRGN; X1, Y1, X2, Y2 : Integer
Returns: True if the function succeeds
Converts a region into a rectangular region with the specified coordinates.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.SetRectRgn(aRGN: HRGN; X1, Y1, X2, Y2 : Integer): Boolean;
procedure Swap(var A, B: Integer);
var
Tmp: Integer;
begin
Tmp := A;
A := B;
B := Tmp;
end;
var
AGdiObject: PGdiObject absolute aRGN;
begin
Result := IsValidGDIObject(aRGN);
if Result then begin
if (X1 > X2) then swap(X1, X2);
if (Y1 > Y2) then swap(Y1, Y2);
AGdiObject^.GDIRegionObject := CreateRectGDKRegion(Rect(X1,Y1,X2,Y2));
Result := True;
end;
end;
{------------------------------------------------------------------------------
function TGtk2WidgetSet.SetROPMode(Handle: hwnd; Str : PChar;
Data : Pointer) : Boolean;
------------------------------------------------------------------------------}
function TGtk2WidgetSet.SetROP2(DC: HDC; Mode: Integer) : Integer;
var
DevCtx: TGtkDeviceContext absolute DC;
begin
if not IsValidDC(DC) then Exit(0);
Result := DevCtx.ROP2;
DevCtx.ROP2 := Mode;
end;
{------------------------------------------------------------------------------
Function: SetScrollInfo
Params: none
Returns: The new position value
nPage >= 0
nPage <= nMax-nMin+1
nPos >= nMin
nPos <= nMax - Max(nPage-1,0)
------------------------------------------------------------------------------}
function TGtk2WidgetSet.SetScrollInfo(Handle : HWND; SBStyle : Integer;
ScrollInfo: TScrollInfo; bRedraw : Boolean): Integer;
var
HasChanged: boolean;
procedure SetRangeUpdatePolicy(Range: PGtkRange);
var
UpdPolicy: TGTKUpdateType;
begin
case ScrollInfo.nTrackPos of
SB_POLICY_DISCONTINUOUS: UpdPolicy := GTK_UPDATE_DISCONTINUOUS;
SB_POLICY_DELAYED: UpdPolicy := GTK_UPDATE_DELAYED;
else UpdPolicy := GTK_UPDATE_CONTINUOUS;
end;
if gtk_range_get_update_policy(Range)=UpdPolicy then exit;
gtk_range_set_update_policy(Range, UpdPolicy);
HasChanged:=true;
end;
procedure SetScrolledWindowUpdatePolicy(ScrolledWindow:PGTKScrolledWindow);
var
Range: PGtkRange;
begin
case SBStyle of
SB_VERT: Range := PGtkRange(ScrolledWindow^.vscrollbar);
SB_HORZ: Range := PGtkRange(ScrolledWindow^.hscrollbar);
else exit;
end;
SetRangeUpdatePolicy(Range);
end;
procedure SetLayoutSize(layout:PGtkLayout; width:guint; height:guint);
var
OldWidth: guint;
OldHeight: guint;
begin
gtk_layout_get_size(layout,@OldWidth,@OldHeight);
if (OldWidth=width) and (OldHeight=height) then exit;
HasChanged:=true;
gtk_layout_set_size(layout,width,height);
end;
procedure SetGDouble(var v: gdouble; NewValue: gdouble);
begin
if v=NewValue then exit;
v:=NewValue;
HasChanged:=true;
end;
const
POLICY: array[BOOLEAN] of TGTKPolicyType = (GTK_POLICY_NEVER, GTK_POLICY_ALWAYS);
var
Layout: PgtkLayout;
Scroll: PGTKWidget;
IsScrollWindow: Boolean;
IsScrollbarVis: boolean;
Adjustment: PGtkAdjustment;
begin
Result := 0;
if (Handle = 0) then exit;
HasChanged:=false;
{DebugLn(['TGtk2WidgetSet.SetScrollInfo A Widget=',GetWidgetDebugReport(PGtkWidget(Handle)),' SBStyle=',SBStyle,
' ScrollInfo=[',
'cbSize=',ScrollInfo.cbSize,
',fMask=',ScrollInfo.fMask,
',nMin=',ScrollInfo.nMin,
',nMax=',ScrollInfo.nMax,
',nPage=',ScrollInfo.nPage,
',nPos=',ScrollInfo.nPos,
',nTrackPos=',ScrollInfo.nTrackPos,
']']);}
Scroll := g_object_get_data({%H-}PGObject(Handle), odnScrollArea);
if GtkWidgetIsA(Scroll, gtk_scrolled_window_get_type)
then begin
IsScrollWindow := True;
end
else begin
Scroll := {%H-}PGTKWidget(Handle);
IsScrollWindow := GtkWidgetIsA(Scroll, gtk_scrolled_window_get_type);
end;
if IsScrollWindow
then begin
Layout := GetFixedWidget({%H-}PGTKObject(Handle));
if not GtkWidgetIsA(PGtkWidget(Layout), gtk_layout_get_type)
then Layout := nil;
end
else begin
Layout := nil;
end;
// scrollbar update policy
if (Scrollinfo.fmask and SIF_UPDATEPOLICY <> 0) then begin
if IsScrollWindow then
SetScrolledWindowUpdatePolicy(PGTKScrolledWindow(Scroll))
else if GtkWidgetIsA(PgtkWidget(Scroll), gtk_clist_get_type) then
SetScrolledWindowUpdatePolicy(PGTKScrolledWindow(@PgtkCList(Scroll)^.container))
else if GtkWidgetIsA(PGtkWidget(Scroll),gtk_hscrollbar_get_type) then
SetRangeUpdatePolicy(PgtkRange(Scroll))
else if GtkWidgetIsA(PGtkWidget(Scroll),gtk_vscrollbar_get_type) then
SetRangeUpdatePolicy(PgtkRange(Scroll))
else if GtkWidgetIsA(PGtkWidget(Scroll), gtk_range_get_type) then
SetRangeUpdatePolicy(PGTKRange(Scroll));
end;
Adjustment:=nil;
case SBStyle of
SB_HORZ:
if IsScrollWindow
then begin
Adjustment := gtk_scrolled_window_get_hadjustment(PGTKScrolledWindow(Scroll));
if Layout <> nil
then begin
if (ScrollInfo.fMask and SIF_RANGE) <> 0 then
SetLayoutSize(Layout, ScrollInfo.nMax - ScrollInfo.nMin, Layout^.height);
Result := round(Layout^.hadjustment^.value);
end;
end
// obsolete stuff
else if GtkWidgetIsA(PGtkWidget(Scroll),gtk_hscrollbar_get_type)
then begin
// this one shouldn't be possible, scrollbar messages are sent to the CTL
DebugLN('!!! direct SB_HORZ set call to scrollbar');
Adjustment := PgtkhScrollBar(Scroll)^.Scrollbar.Range.Adjustment
end
else if GtkWidgetIsA(PGtkWidget(Scroll),gtk_clist_get_type)
then begin
//clist
//TODO: check if this is needed for listviews
DebugLn('[SetScrollInfo] Possible obsolete set use of CList (Listview ?)');
Adjustment := gtk_clist_get_hadjustment(PgtkCList(Scroll));
end;
SB_VERT:
if IsScrollWindow
then begin
Adjustment := gtk_scrolled_window_get_vadjustment(PGTKScrolledWindow(Scroll));
if Layout <> nil
then begin
if (ScrollInfo.fMask and SIF_RANGE) <> 0 then
SetLayoutSize(Layout, Layout^.Width, ScrollInfo.nMax - ScrollInfo.nMin);
Result := round(Layout^.vadjustment^.value);
end;
end
// obsolete stuff
else if GtkWidgetIsA(PGtkWidget(Scroll),gtk_vscrollbar_get_type)
then begin
// this one shouldn't be possible, scrollbar messages are sent to the CTL
DebugLN('!!! direct SB_VERT call to scrollbar');
Adjustment := PgtkvScrollBar(Scroll)^.Scrollbar.Range.Adjustment;
end
else if GtkWidgetIsA(PGtkWidget(Scroll), gtk_clist_get_type)
then begin
//TODO: check is this is needed for listviews
DebugLn('[SetScrollInfo] Possible obsolete set use of CList (Listview ?)');
Adjustment := gtk_clist_get_vadjustment(PgtkCList(Scroll));
end;
SB_CTL:
if GtkWidgetIsA(PGtkWidget(Scroll),gtk_vscrollbar_get_type) then
Adjustment := PgtkvScrollBar(Scroll)^.Scrollbar.Range.Adjustment
else
if GtkWidgetIsA(PGtkWidget(Scroll),gtk_hscrollbar_get_type) then
Adjustment := PgtkhScrollBar(Scroll)^.Scrollbar.Range.Adjustment
else
if GtkWidgetIsA(PGtkWidget(Scroll), gtk_range_get_type) then
Adjustment := gtk_range_get_adjustment(PGTKRange(Scroll));
SB_BOTH:
DebugLn('[SetScrollInfo] Got SB_BOTH ???');
end;
if Adjustment = nil then
exit;
if (ScrollInfo.fMask and SIF_RANGE) <> 0
then begin
SetGDouble(Adjustment^.lower,ScrollInfo.nMin);
SetGDouble(Adjustment^.upper,ScrollInfo.nMax);
end;
if (ScrollInfo.fMask and SIF_PAGE) <> 0
then begin
// 0 <= nPage <= nMax-nMin+1
SetGDouble(Adjustment^.page_size, ScrollInfo.nPage);
SetGDouble(Adjustment^.page_size, Min(Max(Adjustment^.page_size,0),
Adjustment^.upper-Adjustment^.lower+1));
SetGDouble(Adjustment^.page_increment, (Adjustment^.page_size/6)+1);
end;
if (ScrollInfo.fMask and SIF_POS) <> 0
then begin
// nMin <= nPos <= nMax - Max(nPage-1,0)
SetGDouble(Adjustment^.value, ScrollInfo.nPos);
SetGDouble(Adjustment^.value, Max(Adjustment^.value,Adjustment^.lower));
SetGDouble(Adjustment^.value, Min(Adjustment^.value,
Adjustment^.upper-Max(Adjustment^.page_size-1,0)));
end;
// check if scrollbar should be hidden
IsScrollbarVis := true;
if ((ScrollInfo.fMask and (SIF_RANGE or SIF_PAGE)) <> 0) and
((SBStyle=SB_HORZ) or (SBStyle=SB_VERT))
then begin
if (Adjustment^.lower >= (Adjustment^.upper-Max(adjustment^.page_size-1,0)))
then begin
if (ScrollInfo.fMask and SIF_DISABLENOSCROLL) = 0 then
IsScrollbarVis := false
else
;// scrollbar should look disabled (no thumbbar and grayed appearance)
// maybe not possible in gtk
end;
end;
Result := Round(Adjustment^.value);
if not HasChanged then exit;
{DebugLn('');
DebugLn('[TGtk2WidgetSet.SetScrollInfo] Result=',Result,
' Lower=',RoundToInt(Lower),
' Upper=',RoundToInt(Upper),
' Page_Size=',RoundToInt(Page_Size),
' Page_Increment=',RoundToInt(Page_Increment),
' bRedraw=',bRedraw,
' Handle=',DbgS(Handle));}
// do we have to set this always ?
// ??? what is this for code ????
// why not change adjustment if we don't do a redraw ???
if bRedraw then
begin
// immediate draw
if IsScrollWindow
then begin
case SBStyle of
SB_HORZ:
g_object_set(PGTKObject(Scroll),'hscrollbar_policy',[POLICY[IsScrollbarVis],nil]);
SB_VERT:
g_object_set(PGTKObject(Scroll),'vscrollbar_policy',[POLICY[IsScrollbarVis],nil]);
end;
end
else
gtk_widget_queue_draw(PGTKWidget(Scroll));
(*
DebugLn('TGtk2WidgetSet.SetScrollInfo:' +
' lower=%d/%d upper=%d/%d value=%d/%d' +
' step_increment=%d/1 page_increment=%d/%d page_size=%d/%d', [
Round(lower),nMin, Round(upper),nMax, Round(value),nPos,
Round(step_increment), Round(page_increment),nPage, Round(page_size),nPage]
);
*)
gtk_adjustment_changed(Adjustment);
end;
end;
{------------------------------------------------------------------------------
Function: SetSysColors
Params: cElements: the number of elements
lpaElements: array with element numbers
lpaRgbValues: array with colors
Returns: 0 if unsuccesful
The SetSysColors function sets the colors for one or more display elements.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.SetSysColors(cElements: Integer; const lpaElements;
const lpaRgbValues): Boolean;
var
n: Integer;
Element: LongInt;
begin
Result := False;
if cElements > MAX_SYS_COLORS then Exit;
for n := 0 to cElements - 1 do
begin
Element := PInteger(lpaElements)[n];
if (Element > MAX_SYS_COLORS) or (Element < 0) then
Exit;
SysColorMap[Element] := PDword(@lpaRgbValues)[n];
//DebugLn(Format('Trace:[TGtk2WidgetSet.SetSysColor] Index %d (%8x) --> %8x', [PLongArray(lpaElements)^[n], SysColorMap[PLongArray(lpaElements)^[n]], PLongArray(lpaRgbValues)^[n]]));
end;
//TODO send WM_SYSCOLORCHANGE
Result := True;
end;
{------------------------------------------------------------------------------
Function: SetTextCharacterExtra
Params: _hdc:
nCharExtra:
Returns:
------------------------------------------------------------------------------}
function TGtk2WidgetSet.SetTextCharacterExtra(DC : hdc; nCharExtra : Integer):Integer;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
Function: SetTextColor
Params: hdc: Identifies the device context.
Color: Specifies the color of the text.
Returns: The previous color if succesful, CLR_INVALID otherwise
The SetTextColor function sets the text color for the specified device
context to the specified color.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.SetTextColor(DC: HDC; Color: TColorRef): TColorRef;
begin
Result := CLR_INVALID;
if IsValidDC(DC)
then begin
with TGtkDeviceContext(DC) do
begin
Result := CurrentTextColor.ColorRef;
SetGDIColorRef(CurrentTextColor,Color);
if Result<>Color then
SelectedColors := dcscCustom; // force SelectGDKTextProps to ensure text color
end;
end;
end;
function TGtk2WidgetSet.SetViewPortExtEx(DC: HDC; XExtent, YExtent : Integer; OldSize: PSize): Boolean;
var
DevCtx: TGtkDeviceContext absolute DC;
begin
Result := False;
if not IsValidDC(DC) then Exit;
if OldSize <> nil then
begin
OldSize^.cx := DevCtx.ViewPortExt.x;
OldSize^.cy := DevCtx.ViewPortExt.y;
end;
if (XExtent <> DevCtx.ViewPortExt.x) or (YExtent <> DevCtx.ViewPortExt.y) then
begin
case DevCtx.MapMode of
MM_ANISOTROPIC, MM_ISOTROPIC:
begin
DevCtx.ViewPortExt := Point(XExtent, YExtent);
Result := True;
end;
end;
end;
end;
function TGtk2WidgetSet.SetViewPortOrgEx(DC: HDC; NewX, NewY: Integer; OldPoint: PPoint): Boolean;
var
DevCtx: TGtkDeviceContext absolute DC;
begin
Result := False;
if not IsValidDC(DC) then Exit;
if OldPoint <> nil then
begin
OldPoint^.x := DevCtx.ViewPortOrg.x;
OldPoint^.y := DevCtx.ViewPortOrg.y;
end;
if (NewX <> DevCtx.ViewPortOrg.x) or (NewY <> DevCtx.ViewPortOrg.y) then
begin
DevCtx.ViewPortOrg := Point(NewX, NewY);
Result := True;
end;
end;
function TGtk2WidgetSet.SetWindowExtEx(DC: HDC; XExtent, YExtent: Integer; OldSize: PSize): Boolean;
var
DevCtx: TGtkDeviceContext absolute DC;
begin
Result := False;
if not IsValidDC(DC) then Exit;
if OldSize <> nil then
begin
OldSize^.cx := DevCtx.WindowExt.x;
OldSize^.cy := DevCtx.WindowExt.y;
end;
if (XExtent <> DevCtx.WindowExt.x) or (YExtent <> DevCtx.WindowExt.y) then
begin
case DevCtx.MapMode of
MM_ANISOTROPIC, MM_ISOTROPIC:
begin
DevCtx.WindowExt := Point(XExtent, YExtent);
Result := True;
end;
end;
end;
Result := True;
end;
{------------------------------------------------------------------------------
Function: TextOut
Params: DC:
X:
Y:
Str:
Count:
Returns:
------------------------------------------------------------------------------}
function TGtk2WidgetSet.SetWindowLong(Handle: HWND; Idx: Integer;
NewLong: PtrInt): PtrInt;
var
Data: Pointer;
WidgetInfo: PWidgetInfo;
begin
//TODO: Finish this;
Result:=0;
Data := {%H-}Pointer(NewLong);
case idx of
GWL_WNDPROC :
begin
WidgetInfo := GetWidgetInfo({%H-}Pointer(Handle));
if WidgetInfo <> nil then
WidgetInfo^.WndProc := NewLong;
end;
GWL_HINSTANCE :
begin
g_object_set_data({%H-}pgobject(Handle),'HINSTANCE',Data);
end;
GWL_HWNDPARENT :
begin
g_object_set_data({%H-}pgobject(Handle),'HWNDPARENT',Data);
end;
GWL_STYLE :
begin
WidgetInfo := GetWidgetInfo({%H-}Pointer(Handle));
if WidgetInfo <> nil then
WidgetInfo^.Style := NewLong;
end;
GWL_EXSTYLE :
begin
WidgetInfo := GetWidgetInfo({%H-}Pointer(Handle));
if WidgetInfo <> nil then
WidgetInfo^.ExStyle := NewLong;
end;
GWL_USERDATA :
begin
g_object_set_data({%H-}pgobject(Handle),'Userdata',Data);
end;
GWL_ID :
begin
g_object_set_data({%H-}pgobject(Handle),'ID',Data);
end;
end; //case
end;
{------------------------------------------------------------------------------
function TGtk2WidgetSet.SetWindowOrgEx(DC : HDC; NewX, NewY : Integer;
OldPoint: PPoint) : Boolean;
Sets the DC offset for the specified device context.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.SetWindowOrgEx(dc: hdc; NewX, NewY: Integer;
OldPoint: PPoint): Boolean;
var
DevCtx: TGtkDeviceContext absolute DC;
begin
if Assigned(OldPoint) then
GetWindowOrgEx(DC, OldPoint);
if not IsValidDC(DC) then exit(False);
DevCtx.WindowOrg := Point(NewX, NewY);
Result := True;
end;
{------------------------------------------------------------------------------
function TGtk2WidgetSet.SetWindowPos(hWnd: HWND; hWndInsertAfter: HWND;
X, Y, cx, cy: Integer; uFlags: UINT): Boolean;
hWnd: Widget to move
hWndInsertAfter:
HWND_BOTTOM to move bottommost
HWND_TOP to move topmost
the Widget, that should lie just on top of hWnd
uFlags:
SWP_NOMOVE: ignore X, Y
SWP_NOSIZE: ignore cx, cy
SWP_NOZORDER: ignore hWndInsertAfter
SWP_NOREDRAW: skip instant redraw
SWP_NOACTIVATE: skip switching focus
------------------------------------------------------------------------------}
function TGtk2WidgetSet.SetWindowPos(hWnd: HWND; hWndInsertAfter: HWND;
X, Y, cx, cy: Integer; uFlags: UINT): Boolean;
procedure SetZOrderOnFixedWidget(Widget, FixedWidget: PGtkWidget);
var
OldListItem: PGList;
AfterWidget: PGtkWidget;
AfterListItem: PGList;
begin
OldListItem:=FindFixedChildListItem(PGtkFixed(FixedWidget),Widget);
if OldListItem=nil then begin
DebugLn('TGtk2WidgetSet.SetWindowPos.SetZOrderOnFixedWidget WARNING: Widget not on parents fixed widget');
exit;
end;
AfterWidget:=nil;
AfterListItem:=nil;
if hWndInsertAfter=HWND_BOTTOM then begin
//debugln('HWND_BOTTOM');
// HWND_BOTTOM
end else if hWndInsertAfter=HWND_TOP then begin
//debugln('HWND_TOP');
// HWND_TOP
AfterListItem:=FindFixedLastChildListItem(PGtkFixed(FixedWidget));
end else if hWndInsertAfter=0 then begin
DebugLn('TGtk2WidgetSet.SetWindowPos.SetZOrderOnFixedWidget WARNING: hWndInsertAfter=0');
exit;
end else begin
// hWndInsertAfter
AfterWidget:={%H-}PGtkWidget(hWndInsertAfter);
AfterListItem:=FindFixedChildListItem(PGtkFixed(FixedWidget),AfterWidget);
//debugln('AfterWidget=',GetWidgetDebugReport(AfterWidget));
end;
if (AfterListItem=nil) and (AfterWidget<>nil) then begin
DebugLn('TGtk2WidgetSet.SetWindowPos.SetZOrderOnFixedWidget WARNING: AfterWidget not on parents fixed widget');
exit;
end;
if (OldListItem=AfterListItem) or (OldListItem^.next=AfterListItem) then
begin
{$IFDEF EnableGtkZReordering}
DebugLn('TGtk2WidgetSet.SetWindowPos.SetZOrderOnFixedWidget Hint: Already there');
{$ENDIF}
exit;
end;
//DebugLn('TGtk2WidgetSet.SetWindowPos Moving GList entry');
// reorder
{$IFDEF EnableGtkZReordering}
// MG: This trick does not work properly
debugln('SetZOrderOnFixedWidget FixedWidget=['+GetWidgetDebugReport(FixedWidget)+']',
' Widget=['+GetWidgetDebugReport(Widget)+']',
' AfterWidget=['+GetWidgetDebugReport(AfterWidget)+']');
MoveGListLinkBehind(PGtkFixed(FixedWidget)^.children,
OldListItem,AfterListItem);
if GTK_WIDGET_VISIBLE(FixedWidget) and GTK_WIDGET_VISIBLE(Widget)
and GTK_WIDGET_MAPPED(Widget) then begin
DebugLn('TGtk2WidgetSet.SetWindowPos.SetZOrderOnFixedWidget resize ..');
gtk_widget_queue_resize(FixedWidget);
AfterListItem:=PGtkFixed(FixedWidget)^.children;
while AfterListItem<>nil do begin
AfterWidget:=GetFixedChildListWidget(AfterListItem);
DebugLn('TGtk2WidgetSet.SetWindowPos.SetZOrderOnFixedWidget A ',GetWidgetDebugReport(AfterWidget));
AfterListItem:=AfterListItem^.next;
end;
end;
{$ENDIF}
end;
procedure SetZOrderOnLayoutWidget({%H-}Widget, {%H-}LayoutWidget: PGtkWidget);
begin
//DebugLn('TGtk2WidgetSet.SetWindowPos.SetZOrderOnLayoutWidget Not implemented: ZOrdering .. on ',GetWidgetDebugReport(LayoutWidget));
end;
var
Widget: PGTKWidget;
FixedWidget: PGtkWidget;
Allocation: TGTKAllocation;
begin
Result:=false;
Widget:={%H-}PGtkWidget(hWnd);
{DebugLn('[TGtk2WidgetSet.SetWindowPos] ',GetWidgetDebugReport(Widget),
' Top=',hWndInsertAfter=HWND_TOP,
' SWP_NOZORDER=',(SWP_NOZORDER and uFlags)<>0,
' SWP_NOSIZE=',(SWP_NOSIZE and uFlags)<>0,
' SWP_NOMOVE=',(SWP_NOMOVE and uFlags)<>0,
'');}
if GtkWidgetIsA(Widget,GTK_TYPE_WINDOW) then
begin
Result := True;
exit;
{ case hWndInsertAfter of
HWND_BOTTOM: ; //gdk_window_lower(Widget^.Window);
HWND_TOP: gtk_window_set_position(PGtkWindow(hWnd),GTK_WIN_POS_CENTER);
//gdk_window_raise(Widget^.Window);
end;
}
end;
if (SWP_NOMOVE and uFlags = 0) and (SWP_NOSIZE and uFlags = 0) then
begin
// optimize if pos & size needed, so we allocate in one shot.
Allocation.X := X;
Allocation.Y := Y;
Allocation.Width := cx;
Allocation.Height := cy;
gtk_widget_size_allocate(Widget, @Allocation);
end else
begin
if (SWP_NOMOVE and uFlags = 0) then
begin
Allocation.X := X;
Allocation.Y := Y;
Allocation.Width := Widget^.Allocation.Width;
Allocation.Height := Widget^.Allocation.Height;
gtk_widget_size_allocate(Widget, @Allocation);
end;
if (SWP_NOSIZE and uFlags = 0) then
begin
Allocation.X := Widget^.Allocation.x;
Allocation.Y := Widget^.Allocation.y;
Allocation.Width := cx;
Allocation.Height := cy;
gtk_widget_size_allocate(Widget, @Allocation);
end;
end;
if (SWP_NOZORDER and uFlags)=0 then
begin
FixedWidget:=Widget^.Parent;
if FixedWidget=nil then exit;
//DebugLn('TGtk2WidgetSet.SetWindowPos ZOrdering .. on ',GetWidgetDebugReport(FixedWidget));
if GtkWidgetIsA(FixedWidget,GTK_Fixed_Get_Type) then begin
// parent's client area is a gtk_fixed widget
SetZOrderOnFixedWidget(Widget,FixedWidget);
end else if GtkWidgetIsA(FixedWidget,GTK_Layout_Get_Type) then begin
// parent's client area is a gtk_layout widget
SetZOrderOnLayoutWidget(Widget,FixedWidget);
end else begin
//DebugLn('TGtk2WidgetSet.SetWindowPos Not implemented: ZOrdering .. on ',GetWidgetDebugReport(FixedWidget));
exit;
end;
end;
Result:=true;
end;
{------------------------------------------------------------------------------
Function SetWindowRgn
Params: hWnd: HWND; hRgn: HRGN; bRedraw: Boolean
Returns: 0 - fails, in other case success
------------------------------------------------------------------------------}
function TGtk2WidgetSet.SetWindowRgn(hWnd: HWND; hRgn: HRGN; bRedraw: Boolean): longint;
var
Widget: PGtkWidget;
Window: PGdkWindow;
ShapeRegion: PGdkRegion;
LCLObject: TObject;
begin
// For normal widgets we should use GetFixedWidget,
// but for TForm we should apply the region in the raw hWnd
LCLObject := GetLCLObject({%H-}PGtkWidget(hWnd));
if LCLObject is TCustomForm then
begin
Widget := {%H-}PGtkWidget(hWnd);
end
else
begin
Widget := GetFixedWidget({%H-}PGtkWidget(hWnd));
if Widget = nil then
Widget := {%H-}PGtkWidget(hWnd);
end;
if Widget = nil then
Exit(0);
if GtkWidgetIsA(gtk_widget_get_toplevel(Widget), gtk_window_get_type)
and not gtk_widget_realized(Widget) then
gtk_widget_realize(Widget); // associate with window
Window := GetControlWindow(Widget);
if Window = nil then
Exit(0);
if hRgn = 0 then
ShapeRegion := nil
else
ShapeRegion := {%H-}PGDIObject(hRgn)^.GDIRegionObject;
gdk_window_shape_combine_region(Window, ShapeRegion, 0, 0);
if bRedraw then
gdk_window_invalidate_region(Window, ShapeRegion, True);
Result := 1;
end;
{------------------------------------------------------------------------------
Function: ShowCaret
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtk2WidgetSet.ShowCaret(hWnd: HWND): Boolean;
var
GTKObject: PGTKObject;
begin
GTKObject := {%H-}PGTKObject(HWND);
Result := GTKObject <> nil;
if Result
then begin
if gtk_type_is_a(g_object_type(GTKObject), GTKAPIWidget_GetType)
then begin
GTKAPIWidget_ShowCaret(PGTKAPIWidget(GTKObject));
end
else begin
Result := False;
end;
end
else DebugLn('WARNING: [TGtk2WidgetSet.ShowCaret] Got null HWND');
end;
{------------------------------------------------------------------------------
Function: ShowScrollBar
Params: Wnd, wBar, bShow
Returns: Nothing
------------------------------------------------------------------------------}
function TGtk2WidgetSet.ShowScrollBar(Handle: HWND; wBar: Integer;
bShow: Boolean): Boolean;
var
NewPolicy: Integer;
Scroll: PGtkWidget;
IsScrollWindow: Boolean;
begin
Result := (Handle <> 0);
if not Result then exit;
Scroll := PGtkWidget(g_object_get_data({%H-}PGObject(Handle), odnScrollArea));
if GtkWidgetIsA(Scroll, gtk_scrolled_window_get_type)
then begin
IsScrollWindow := True;
end
else begin
Scroll := {%H-}PGTKWidget(Handle);
IsScrollWindow := GtkWidgetIsA(Scroll, gtk_scrolled_window_get_type);
end;
//DebugLn(['TGtk2WidgetSet.ShowScrollBar ',GetWidgetDebugReport(Scroll),' wBar=',wBar,' bShow=',bShow]);
if IsScrollWindow then begin
if wBar in [SB_BOTH, SB_HORZ] then begin
//DebugLn(['TGtk2WidgetSet.ShowScrollBar ',GetWidgetDebugReport(Widget),' bShow=',bShow]);
if bShow then
NewPolicy:=GTK_POLICY_ALWAYS
else
NewPolicy:=GTK_POLICY_NEVER;
g_object_set(PGTKObject(Scroll), 'hscrollbar_policy', [NewPolicy,nil]);
end;
if wBar in [SB_BOTH, SB_VERT] then begin
if bShow then
NewPolicy:=GTK_POLICY_ALWAYS
else
NewPolicy:=GTK_POLICY_NEVER;
g_object_set(PGTKObject(Scroll), 'vscrollbar_policy', [NewPolicy,nil]);
end;
end
else begin
if (wBar = SB_CTL)
and gtk_type_is_a(g_object_type({%H-}PGTKObject(Handle)),gtk_widget_get_type)
then begin
if bShow
then gtk_widget_show(Scroll)
else gtk_widget_hide(Scroll);
end;
end;
end;
{------------------------------------------------------------------------------
function ShowWindow(hWnd: HWND; nCmdShow: Integer): Boolean;
nCmdShow:
SW_SHOWNORMAL, SW_MINIMIZE, SW_SHOWMAXIMIZED
------------------------------------------------------------------------------}
function TGtk2WidgetSet.ShowWindow(hWnd: HWND; nCmdShow: Integer): Boolean;
var
GtkWindow: PGtkWindow;
B: Boolean;
Widget: PGtkWidget;
AFlags: TGdkWindowState;
AWindow: PGdkWindow;
begin
Result := False;
Widget := {%H-}PGtkWidget(HWND);
if Widget = nil then
RaiseGDBException('TGtk2WidgetSet.ShowWindow hWnd is nil');
if GTK_IS_WINDOW(Widget) then
GtkWindow := {%H-}PGtkWindow(hWnd)
else
begin
// we are pure gtkwidget so only SW_SHOW AND SW_HIDE CAN GO
case nCmdShow of
SW_SHOWNORMAL,
SW_SHOW: gtk_widget_show(Widget);
SW_HIDE: gtk_widget_hide(Widget);
end;
Result := nCmdShow in [SW_SHOW, SW_HIDE];
exit;
end;
B := (PGtkWidget(GtkWindow)^.parent <> nil) and
(PGtkWidget(GtkWindow)^.parent^.window <> nil) and
(PGtkWidget(GtkWindow)^.parent^.window = PGtkWidget(GtkWindow)^.window);
if not B and not GTK_IS_WINDOW(PGtkWidget(GtkWindow)) then
begin
DebugLn(['TGtk2WidgetSet.ShowWindow ',GetWidgetDebugReport(PGTKWidget(GtkWindow))]);
RaiseGDBException('TGtk2WidgetSet.ShowWindow hWnd is not a gtkwindow');
end;
//debugln('TGtk2WidgetSet.ShowWindow A ',GetWidgetDebugReport(PGtkWidget(GtkWindow)),' nCmdShow=',dbgs(nCmdShow),' SW_MINIMIZE=',dbgs(SW_MINIMIZE=nCmdShow));
case nCmdShow of
SW_SHOWNORMAL:
begin
if B then
gtk_widget_show(PGtkWidget(GtkWindow))
else
begin
if not GTK_WIDGET_VISIBLE(PGtkWidget(GtkWindow)) then
gtk_widget_show(PGtkWidget(GtkWindow));
AWindow := PGtkWidget(GtkWindow)^.window;
if GDK_IS_WINDOW(AWindow) then
begin
AFlags := gdk_window_get_state(AWindow);
if AFlags and GDK_WINDOW_STATE_ICONIFIED <> 0 then
gtk_window_deiconify(GtkWindow);
if AFlags and GDK_WINDOW_STATE_MAXIMIZED <> 0 then
gtk_window_unmaximize(GtkWindow);
if AFlags and GDK_WINDOW_STATE_FULLSCREEN <> 0 then
gtk_window_unfullscreen(GtkWindow);
end;
end;
end;
SW_HIDE:
gtk_widget_hide(PGtkWidget(GtkWindow));
SW_MINIMIZE:
if not B then
gtk_window_iconify(GtkWindow);
SW_SHOWMAXIMIZED:
if B then
gtk_widget_show(PGtkWidget(GtkWindow))
else
begin
gtk_widget_realize(PGtkWidget(GtkWindow));
AWindow := PGtkWidget(GtkWindow)^.window;
if GDK_IS_WINDOW(AWindow) then
begin
AFlags := gdk_window_get_state(AWindow);
if AFlags and GDK_WINDOW_STATE_ICONIFIED <> 0 then
gtk_window_deiconify(GtkWindow);
if AFlags and GDK_WINDOW_STATE_FULLSCREEN <> 0 then
gtk_window_unfullscreen(GtkWindow);
if Aflags and GDK_WINDOW_STATE_MAXIMIZED = 0 then
gtk_window_maximize(GtkWindow);
end;
end;
SW_SHOWFULLSCREEN:
if B then
gtk_widget_show(PGtkWidget(GtkWindow))
else
gtk_window_fullscreen(GtkWindow);
SW_RESTORE:
begin
AWindow := PGtkWidget(GtkWindow)^.window;
if GDK_IS_WINDOW(AWindow) then
begin
AFlags := gdk_window_get_state(AWindow);
if AFlags and GDK_WINDOW_STATE_ICONIFIED <> 0 then
gtk_window_deiconify(GtkWindow);
if AFlags and GDK_WINDOW_STATE_MAXIMIZED <> 0 then
gtk_window_unmaximize(GtkWindow);
if AFlags and GDK_WINDOW_STATE_FULLSCREEN <> 0 then
gtk_window_unfullscreen(GtkWindow);
end;
end;
end;
Result := True;
end;
{------------------------------------------------------------------------------
Function: StretchBlt
Params: DestDC: The destination devicecontext
X, Y: The left/top corner of the destination rectangle
Width, Height: The size of the destination rectangle
SrcDC: The source devicecontext
XSrc, YSrc: The left/top corner of the source rectangle
SrcWidth, SrcHeight: The size of the source rectangle
ROp: The raster operation to be performed
Returns: True if succesful
The StretchBlt function copies a bitmap from a source rectangle into a
destination rectangle using the specified raster operation. If needed it
resizes the bitmap to fit the dimensions of the destination rectangle.
Sizing is done according to the stretching mode currently set in the
destination device context.
If SrcDC contains a mask the pixmap will be copied with this transparency.
ToDo: Mirroring, extended NonDrawable support (Image, Bitmap, etc)
------------------------------------------------------------------------------}
function TGtk2WidgetSet.StretchBlt(DestDC: HDC; X, Y, Width, Height: Integer;
SrcDC: HDC; XSrc, YSrc, SrcWidth, SrcHeight: Integer; ROp: Cardinal): Boolean;
begin
Result:=StretchCopyArea(DestDC,X,Y,Width,Height,
SrcDC,XSrc,YSrc,SrcWidth,SrcHeight,
0,0,0,
ROp);
end;
{------------------------------------------------------------------------------
Function: StretchMaskBlt
Params: DestDC: The destination devicecontext
X, Y: The left/top corner of the destination rectangle
Width, Height: The size of the destination rectangle
SrcDC: The source devicecontext
XSrc, YSrc: The left/top corner of the source rectangle
SrcWidth, SrcHeight: The size of the source rectangle
Mask: The handle of a monochrome bitmap
XMask, YMask: The left/top corner of the mask rectangle
ROp: The raster operation to be performed
Returns: True if succesful
The StretchMaskBlt function copies a bitmap from a source rectangle into a
destination rectangle using the specified mask and raster operation. If needed
it resizes the bitmap to fit the dimensions of the destination rectangle.
Sizing is done according to the stretching mode currently set in the
destination device context.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.StretchMaskBlt(DestDC: HDC; X, Y, Width, Height: Integer;
SrcDC: HDC; XSrc, YSrc, SrcWidth, SrcHeight: Integer; Mask: HBITMAP;
XMask, YMask: Integer; Rop: DWORD): Boolean;
begin
Result:=StretchCopyArea(DestDC,X,Y,Width,Height,
SrcDC,XSrc,YSrc,SrcWidth,SrcHeight,
Mask,XMask,YMask,
Rop);
end;
function TGtk2WidgetSet.SystemParametersInfo(uiAction: DWord; uiParam: DWord;
pvParam: Pointer; fWinIni: DWord): LongBool;
{$IFDEF HASX}
var
ax, ay, awidth, aheight: gint;
{$ENDIF}
begin
Result:=True;
Case uiAction of
SPI_GETWHEELSCROLLLINES: PDword(pvParam)^ := 3;
SPI_GETWORKAREA:
begin
{$IFDEF HASX}
if XGetWorkarea(ax, ay, awidth, aheight) <> -1 then
TRect(pvParam^) := Bounds(ax, ay, awidth, aheight)
else
{$ENDIF}
TRect(pvParam^):=Bounds(GetSystemMetrics(SM_XVIRTUALSCREEN),
GetSystemMetrics(SM_YVIRTUALSCREEN),
GetSystemMetrics(SM_CXVIRTUALSCREEN),
GetSystemMetrics(SM_CYVIRTUALSCREEN));
end;
else
Result:=False;
end;
end;
{------------------------------------------------------------------------------
Function: TextOut
Params: DC:
X:
Y:
Str:
Count:
Returns:
------------------------------------------------------------------------------}
function TGtk2WidgetSet.TextOut(DC: HDC; X, Y: Integer; Str: Pchar;
Count: Integer) : Boolean;
var
DevCtx: TGtkDeviceContext absolute DC;
DCOrigin: TPoint;
yOffset: integer;
BackGroundColor: PGdkColor;
begin
Result := IsValidDC(DC);
if not Result then Exit;
if Count <= 0 then Exit;
if DevCtx.HasTransf then
DevCtx.TransfPoint(X, Y);
UpdateDCTextMetric(DevCtx);
DCOrigin := DevCtx.Offset;
with DevCtx.DCTextMetric.TextMetric do
yOffset := tmHeight-tmDescent-tmAscent;
if yOffset < 0 then
yOffset := 0;
DevCtx.SelectedColors := dcscCustom;
EnsureGCColor(DC, dccCurrentTextColor, True, False);
BackGroundColor := nil;
if DevCtx.BkMode = OPAQUE then
begin
AllocGDIColor(DC, @DevCtx.CurrentBackColor);
BackGroundColor := @DevCtx.CurrentBackColor.Color;
end;
DevCtx.DrawTextWithColors(Str, Count,
X + DCOrigin.X, Y + DCOrigin.Y + yOffset,
nil, BackGroundColor);
end;
function TGtk2WidgetSet.UpdateWindow(Handle: HWND): Boolean;
var
CurWidget: PGtkWidget;
begin
CurWidget:={%H-}PGTKWidget(Handle);
//DebugLn(['TGtk2WidgetSet.UpdateWindow ',GetWidgetDebugReport(CurWidget)]);
if GTK_WIDGET_DRAWABLE(CurWidget) then begin
//DebugLn(['TGtk2WidgetSet.UpdateWindow DRAWING']);
gtk_widget_queue_draw(CurWidget);
if GDK_IS_WINDOW(CurWidget^.Window) then
gdk_window_process_updates(CurWidget^.window,TRUE);
Result:=true;
end else
Result:=false;
end;
{------------------------------------------------------------------------------
Function: WindowFromPoint
Params: Point: Specifies the x and y Coords
Returns: The handle of the gtkwidget. If none exist, then NULL is returned.
------------------------------------------------------------------------------}
function TGtk2WidgetSet.WindowFromPoint(APoint: TPoint): HWND;
var
Ctrl: TWinControl;
CtrlFakeRoot: THintWindow;
ev: TgdkEvent;
p: TPoint;
Window: PgdkWindow;
Widget: PgtkWidget;
WidgetInfo: PWidgetInfo;
begin
// return cached value to prevent heavy gdk_display_get_window_at_pointer call
if (APoint = LastWFPMousePos) and GTK_IS_OBJECT({%H-}Pointer(LastWFPResult)) and
GTK_WIDGET_VISIBLE({%H-}PGtkWidget(LastWFPResult)) and
GTK_WIDGET_IS_SENSITIVE({%H-}PGtkWidget(LastWFPResult)) then
Exit(LastWFPResult);
Result := 0;
WidgetInfo := nil;
// we are using gdk_display_get_window_at_pointer instead of
// gdk_window_at_pointer because of multihead support.
// !! changes the coordinates !! -> using local variable p
p := APoint;
Window := gdk_display_get_window_at_pointer(gdk_display_get_default,
@p.x, @p.y);
if window <> nil then
begin
// ignore temporary windows Hint/DragImageList/etc...
if gdk_window_get_type(Window) = GDK_WINDOW_TEMP then
begin
// FakeRoot must be a temporary window that returns HTTRANSPARENT on WM_NCHitTest.
// It is used as an entry point for CheckTransparentWindow method to start searching thgrough all forms.
CtrlFakeRoot := THintWindow.Create(nil);
try
Ctrl := CtrlFakeRoot;
CheckTransparentWindow(Result, Ctrl);
finally
CtrlFakeRoot.Free;
end;
if Result = 0 then
Result := LastWFPResult;
Exit;
end;
FillChar(ev{%H-}, SizeOf(ev), 0);
ev.any.window := Window;
Widget := gtk_get_event_widget(@ev);
Result := {%H-}PtrUInt(Widget);
if Result <> 0 then
begin
WidgetInfo := GetWidgetInfo(Widget);
if WidgetInfo = nil then
begin
// complex controls eg. ScrollBar of TTreeView
WidgetInfo := GetWidgetInfo(Widget^.parent);
if WidgetInfo <> nil then
Result := {%H-}PtrUInt(Widget^.parent);
end;
end;
end;
// disconnect old handler
if GTK_IS_OBJECT({%H-}Pointer(LastWFPResult)) then
begin
g_signal_handlers_disconnect_by_func({%H-}GPointer(LastWFPResult),
TGTKSignalFunc(@DestroyWindowFromPointCB), nil);
end;
// see issue #17389
if (WidgetInfo <> nil) and (WidgetInfo^.LCLObject <> nil) and
(WidgetInfo^.LCLObject is TWinControl) then
begin
Ctrl := TWinControl(WidgetInfo^.LCLObject);
Result := Ctrl.Handle;
CheckTransparentWindow(Result, Ctrl);
end;
// now we must check if we are visible and enabled
if Result <> 0 then
begin
if not GTK_WIDGET_VISIBLE({%H-}PGtkWidget(Result)) or
not GTK_WIDGET_IS_SENSITIVE({%H-}PGtkWidget(Result)) then
Result := 0;
end;
LastWFPMousePos := APoint;
LastWFPResult := Result;
// connect handler
if LastWFPResult <> 0 then
begin
g_signal_connect({%H-}GPointer(LastWFPResult), 'destroy',
TGTKSignalFunc(@DestroyWindowFromPointCB), nil);
end;
end;
//##apiwiz##eps## // Do not remove
// Placed CriticalSectionSupport outside the API wizard bounds
// so it won't affect sorting etc.
{$IfNDef DisableCriticalSections}
{$IfDef Unix}
{$Define pthread}
{Type
_pthread_fastlock = packed record
__status: Longint;
__spinlock: Integer;
end;
pthread_mutex_t = packed record
__m_reserved: Integer;
__m_count: Integer;
__m_owner: Pointer;
__m_kind: Integer;
__m_lock: _pthread_fastlock;
end;
ppthread_mutex_t = ^pthread_mutex_t;
pthread_mutexattr_t = packed record
__mutexkind: Integer;
end;}
{$linklib pthread}
{function pthread_mutex_init(var Mutex: pthread_mutex_t;
var Attr: pthread_mutexattr_t): Integer; cdecl;external;
function pthread_mutexattr_settype(var Attr: pthread_mutexattr_t;
Kind: Integer): Integer; cdecl;external;
function pthread_mutex_lock(var Mutex: pthread_mutex_t):
Integer; cdecl; external;
function pthread_mutex_unlock(var Mutex: pthread_mutex_t):
Integer; cdecl; external;
function pthread_mutex_destroy(var Mutex: pthread_mutex_t):
Integer; cdecl; external;}
{$EndIf}
{$EndIf}
procedure TGtk2WidgetSet.InitializeCriticalSection(var CritSection: TCriticalSection);
{$IfDef pthread}
var
ACritSec: System.PRTLCriticalSection;
begin
New(ACritSec);
System.InitCriticalSection(ACritSec^);
CritSection:={%H-}TCriticalSection(ACritSec);
end;
{var
Crit : ppthread_mutex_t;
Attribute: pthread_mutexattr_t;
begin
if pthread_mutexattr_settype(Attribute, 1) <> 0 then
Exit;
If CritSection <> 0 then
Try
Crit := ppthread_mutex_t(CritSection);
Dispose(Crit);
except
CritSection := 0;
end;
New(Crit);
pthread_mutex_init(Crit^, Attribute);
CritSection := Longint(Crit);
end;}
{$Else}
begin
end;
{$EndIf}
procedure TGtk2WidgetSet.EnterCriticalSection(var CritSection: TCriticalSection);
{$IfDef pthread}
var
ACritSec: System.PRTLCriticalSection;
begin
ACritSec:={%H-}System.PRTLCriticalSection(CritSection);
System.EnterCriticalsection(ACritSec^);
end;
{$Else}
begin
end;
{$EndIf}
procedure TGtk2WidgetSet.LeaveCriticalSection(var CritSection: TCriticalSection);
{$IfDef pthread}
var
ACritSec: System.PRTLCriticalSection;
begin
ACritSec:={%H-}System.PRTLCriticalSection(CritSection);
System.LeaveCriticalsection(ACritSec^);
end;
{$Else}
begin
end;
{$EndIf}
procedure TGtk2WidgetSet.DeleteCriticalSection(var CritSection: TCriticalSection);
{$IfDef pthread}
var
ACritSec: System.PRTLCriticalSection;
begin
ACritSec:={%H-}System.PRTLCriticalSection(CritSection);
System.DoneCriticalsection(ACritSec^);
Dispose(ACritSec);
CritSection:=0;
end;
{$Else}
begin
end;
{$EndIf}
{$IfDef ASSERT_IS_ON}
{$UNDEF ASSERT_IS_ON}
{$C-}
{$EndIf}