paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-05-29 11:02:44 +02:00
Code Issues Packages Projects Releases Wiki Activity
d2c1b2ccab
lazarus/lcl/interfaces/gtk/gtkwinapi.inc

9861 lines
317 KiB
PHP
Raw Blame History

{%MainUnit gtkint.pp}
{ $Id$ }
{******************************************************************************
All GTK Winapi implementations.
Initial Revision : Sat Nov 13 12:53:53 1999
!! Keep alphabetical !!
Support routines go to gtkproc.pp
******************************************************************************
Implementation
******************************************************************************
*****************************************************************************
* *
* This file is part of the Lazarus Component Library (LCL) *
* *
* See the file COPYING.modifiedLGPL, included in this distribution, *
* for details about the copyright. *
* *
* This program is distributed in the hope that it will be useful, *
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
* *
*****************************************************************************
}
{$IFOPT C-}
// Uncomment for local trace
// {$C+}
// {$DEFINE ASSERT_IS_ON}
{$EndIf}
const
BOOL_TEXT: array[Boolean] of string = ('False', 'True');
//##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 TGtkWidgetSet.Arc(DC: HDC;
left, top, right, bottom, angle1, angle2: Integer): Boolean;
var
DCOrigin: TPoint;
begin
Result := IsValidDC(DC);
if Result
then with TDeviceContext(DC) do
begin
// Draw outline
SelectGDKPenProps(DC);
If (dcfPenSelected in DCFlags) then begin
Result := True;
if IsNullPen(TDeviceContext(DC)) then exit;
DCOrigin:=GetDCOffset(TDeviceContext(DC));
inc(Left,DCOrigin.X);
inc(Top,DCOrigin.Y);
inc(Right,DCOrigin.X);
inc(Bottom,DCOrigin.Y);
{$IFDEF DebugGDKTraps}BeginGDKErrorTrap;{$ENDIF}
gdk_draw_arc(Drawable, GetGC, 0, left, top, right - left, bottom - top,
Angle1*4, Angle2*4);
{$IFDEF DebugGDKTraps}EndGDKErrorTrap;{$ENDIF}
end else
Result:=false;
end;
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 TGtkWidgetSet.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 TGtkWidgetSet.BeginPaint(Handle: hWnd; Var PS : TPaintStruct) : hdc;
var
{$IFDEF Gtk1}
Widget: PGtkWidget;
TargetObject: TObject;
PaintWidget: Pointer;
{$ENDIF}
IsDoubleBuffered: Boolean;
begin
{$IFDEF Gtk1}
Widget:=PGtkWidget(Handle);
TargetObject:=GetNearestLCLObject(Widget);
IsDoubleBuffered:=(TargetObject is TWinControl)
and TWinControl(TargetObject).DoubleBuffered;
// check if Handle is the paint widget of the LCL component
if IsDoubleBuffered then begin
PaintWidget:=GetFixedWidget(PGtkWidget(TWinControl(TargetObject).Handle));
IsDoubleBuffered:=(PaintWidget=Widget);
//if not IsDoubleBuffered then begin
// DebugLn('TGtkWidgetSet.BeginPaint Not the paint widget: ',
// TWinControl(TargetObject).Name,':',TWinControl(TargetObject).ClassName,
// ' PaintWidget=',GetWidgetClassName(PaintWidget),
// ' Widget=',GetWidgetClassName(Widget));
//end;
end;
{$IFNDEF UseGTKDoubleBuf}
IsDoubleBuffered:=false;
{$ENDIF}
{$ELSE below: not GTK1}
IsDoubleBuffered:=false;
{$ENDIF}
if IsDoubleBuffered then
PS.hDC:=GetDoubleBufferedDC(Handle)
else
PS.hDC:=GetDC(Handle);
Result := PS.hDC;
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 TGtkWidgetSet.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 TGtkWidgetSet.CallNextHookEx(hhk : HHOOK; ncode : Integer; wParam: WParam; lParam : LParam) : Integer;
begin
Result := 0;
//TODO: Does anything need to be done here?
Assert(False, 'Trace:!!!!!!!!!!!!!!!!!!');
Assert(False, 'Trace:!!!!!!!!!!!!!!!!!!');
Assert(False, 'Trace:TODO: CALLNEXTHOOKEX in gtkwinapi.inc');
Assert(False, 'Trace:!!!!!!!!!!!!!!!!!!');
Assert(False, 'Trace:!!!!!!!!!!!!!!!!!!');
end;
{------------------------------------------------------------------------------
Function: CallWindowProc
Params: lpPrevWndFunc:
Handle:
Msg:
wParam:
lParam:
Returns:
------------------------------------------------------------------------------}
Function TGtkWidgetSet.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;
Result := -1;
P := nil;
P := gtk_object_get_data(pgtkobject(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 TGtkWidgetSet.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(PGtkWidget(Handle));
end;
// Todo: calculate offset, since platform specific
Inc(P.X, Position.X);
Inc(P.Y, Position.Y);
Assert(False, 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 TGtkWidgetSet.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 TGtkWidgetSet.ClipboardGetData(ClipboardType: TClipboardType;
FormatID: TClipboardFormat; Stream: TStream): boolean;
type
PGdkAtom = ^TGdkAtom;
var FormatAtom, FormatTry: Cardinal;
SupportedCnt, i: integer;
SupportedFormats: PGdkAtom;
SelData: TGtkSelectionData;
CompoundTextList: PPGChar;
CompoundTextCount: integer;
function IsFormatSupported(Format: cardinal): boolean;
var a: integer;
AllID: cardinal;
begin
//DebugLn('IsFormatSupported Format=',dbgs(Format),' SupportedCnt=',dbgs(SupportedCnt));
if Format=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);
{DebugLn('IsFormatSupported A ',Dbgs(SelData.Selection),
' ',HexStr(Cardinal(ClipboardTypeAtoms[ClipboardType]),8),
' SelData.Target='+dbgs(SelData.Target),' AllID='+dbgs(AllID),
' SelData.TheType='+dbgs(SelData.TheType)+' ATOM='+dbgs(gdk_atom_intern('ATOM',0))+' Name="'+GdkAtomToStr(SelData.TheType)+'"',
' SelData.Length='+dbgs(SelData.Length),
' SelData.Format='+dbgs(SelData.Format)
);}
if (SelData.Selection<>ClipboardTypeAtoms[ClipboardType])
or (SelData.Target<>AllID)
or (SelData.{$IfDef GTK2}_Type{$Else}theType{$EndIf}<>gdk_atom_intern('ATOM',GdkFalse)) then begin
SupportedCnt:=0;
exit;
end;
SupportedCnt:=SelData.Length div (SelData.Format shr 3);
SupportedFormats:=PGdkAtom(SelData.Data);
//DebugLn('IsFormatSupported SupportedCnt=',dbgs(SupportedCnt));
{a:=SupportedCnt-1;
while (a>=0) do begin
debugln(' ',dbgs(a),' ',GdkAtomToStr(SupportedFormats[a]),' "',p,'"');
dec(a);
end;}
end;
a:=SupportedCnt-1;
while (a>=0) and (SupportedFormats[a]<>Format) do dec(a);
Result:=(a>=0);
end;
begin
{$IfDef DEBUG_CLIPBOARD}
DebugLn('[TGtkWidgetSet.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
FormatAtom:=0;
// text/plain is supported in various formats in gtk
FormatTry:=gdk_atom_intern('COMPOUND_TEXT',GdkFalse);
if IsFormatSupported(FormatTry) then
FormatAtom:=FormatTry;
// 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);
// then check for UTF8 text format 'UTF8_STRING'
FormatTry:=gdk_atom_intern('UTF8_STRING',GdkFalse);
if IsFormatSupported(FormatTry) then
FormatAtom:=FormatTry;
// then check for simple text format 'text/plain'
FormatTry:=gdk_atom_intern('text/plain',GdkFalse);
if (FormatAtom=0) and IsFormatSupported(FormatTry) then
FormatAtom:=FormatTry;
// then check for simple text format STRING
FormatTry:=gdk_atom_intern('STRING',GdkFalse);
if (FormatAtom=0) and IsFormatSupported(FormatTry) then
FormatAtom:=FormatTry;
// check for some other formats that can be interpreted as text
FormatTry:=gdk_atom_intern('FILE_NAME',GdkTrue);
if (FormatAtom=0) and IsFormatSupported(FormatTry) then
FormatAtom:=FormatTry;
FormatTry:=gdk_atom_intern('HOST_NAME',GdkTrue);
if (FormatAtom=0) and IsFormatSupported(FormatTry) then
FormatAtom:=FormatTry;
FormatTry:=gdk_atom_intern('USER',GdkTrue);
if (FormatAtom=0) and IsFormatSupported(FormatTry) then
FormatAtom:=FormatTry;
// the TEXT format is not reliable, but it should be supported
FormatTry:=gdk_atom_intern('TEXT',GdkFalse);
if (FormatAtom=0) and IsFormatSupported(FormatTry) then
FormatAtom:=FormatTry;
end;
{$IfDef DEBUG_CLIPBOARD}
DebugLn('[TGtkWidgetSet.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('[TGtkWidgetSet.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('[TGtkWidgetSet.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
CompoundTextCount:=gdk_text_property_to_text_list(SelData.{$IfDef GTK2}_Type{$Else}theType{$EndIf},
SelData.Format,SelData.Data,SelData.Length,{$IfDef GTK1}@{$EndIf}CompoundTextList);
{$IfDef DEBUG_CLIPBOARD}
DebugLn('[TGtkWidgetSet.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]));
gdk_free_text_list(CompoundTextList);
end else
Stream.Write(SelData.Data^,SelData.Length);
end else begin
Stream.Write(SelData.Data^,SelData.Length);
end;
end;
{$IfDef DEBUG_CLIPBOARD}
DebugLn('[TGtkWidgetSet.ClipboardGetData] END ',' Now=',dbgs(Now));
{$EndIf}
Result:=true;
finally
if SupportedFormats<>nil then FreeMem(SupportedFormats);
if SelData.Data<>nil 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 TGtkWidgetSet.ClipboardGetFormats(ClipboardType: TClipboardType;
var Count: integer; var List: PClipboardFormat): boolean;
type
PGdkAtom = ^TGdkAtom;
var AllID: cardinal;
FormatAtoms: PGdkAtom;
Cnt, i: integer;
AddTextPlain: boolean;
SelData: TGtkSelectionData;
function IsFormatSupported(Format: cardinal): boolean;
var a: integer;
begin
if Format<>0 then begin
for a:=0 to Cnt-1 do begin
{$IfDef DEBUG_CLIPBOARD}
DebugLn(' IsFormatSupported ',dbgs(Format),' ',dbgs(FormatAtoms[a]));
{$EndIf}
if FormatAtoms[a]=Format 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('[TGtkWidgetSet.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('[TGtkWidgetSet.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.TheType)+'='+dbgs(gdk_atom_intern('ATOM',GdkFalse))+
' "'+GdkAtomToStr(SelData.theType)+'"',
' 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.{$IfDef GTK2}_Type{$Else}TheType{$EndIf}<>gdk_atom_intern('ATOM',GdkFalse))
and (SelData.{$IfDef GTK2}_Type{$Else}TheType{$EndIf}<>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('[TGtkWidgetSet.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 TGtkWidgetSet.ClipboardGetOwnerShip(ClipboardType: TClipboardType;
OnRequestProc: TClipboardRequestEvent; FormatCount: integer;
Formats: PClipboardFormat): boolean;
var TargetEntries: PGtkTargetEntry;
function IsFormatSupported(FormatID: cardinal): 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 TGtkWidgetSet.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('[TGtkWidgetSet.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 the lcl does not
// know
ExpFormatCnt:=FormatCount;
for gtkFormat:=Low(TGtkClipboardFormat) to High(TGtkClipboardFormat) do
ClipboardExtraGtkFormats[ClipboardType][gtkFormat]:=false;
{$IfDef DEBUG_CLIPBOARD}
DebugLn('[TGtkWidgetSet.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][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('[TGtkWidgetSet.ClipboardGetOwnerShip] C');
{$EndIf}
if gtk_selection_owner_set(ClipboardWidget,
ClipboardTypeAtoms[ClipboardType],0)=GdkFalse
then begin
{$IfDef DEBUG_CLIPBOARD}
DebugLn('[TGtkWidgetSet.ClipboardGetOwnerShip] D FAILED');
{$EndIf}
exit;
end;
{$IfDef DEBUG_CLIPBOARD}
DebugLn('[TGtkWidgetSet.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: ClipboardRegisterFormat
Params: AMimeType
Returns: the registered Format identifier (TClipboardFormat)
------------------------------------------------------------------------------}
function TGtkWidgetSet.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: TGtkWidgetSet.ClipboardRegisterFormat gdk not initialized');
end;
{------------------------------------------------------------------------------
Function: CreateBitmap
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtkWidgetSet.CreateBitmap(Width, Height: Integer;
Planes, BitCount: Longint; BitmapBits: Pointer): HBITMAP;
var
GdiObject: PGdiObject;
DefGdkWindow: PGdkWindow;
begin
Assert(False, Format('Trace:> [TGtkWidgetSet.CreateBitmap] Width: %d, Height: %d, Planes: %d, BitCount: %d, BitmapBits: 0x%x', [Width, Height, Planes, BitCount, PtrInt(BitmapBits)]));
if (BitCount < 1) or (Bitcount > 32)
then begin
Result := 0;
DebugLn(Format('ERROR: [TGtkWidgetSet.CreateBitmap] Illegal depth %d', [BitCount]));
Exit;
end;
//write('TGtkWidgetSet.CreateBitmap->');
GdiObject := NewGDIObject(gdiBitmap);
{$IFDEF DebugGDKTraps}
BeginGDKErrorTrap;
{$ENDIF}
// if the bitcount is 1 then create a gdkbitmap
// else create a gdkpixmap
{if BitCount > 1
then begin
Assert(False, Format('Trace: [TGtkWidgetSet.CreateBitmap] gbPixmap', [])); }
DefGdkWindow := nil;
If BitCount = 1 then begin
GdiObject^.GDIBitmapType := gbBitmap;
GdiObject^.GDIBitmapObject := CreateGdkBitmap(DefGdkWindow,Width,Height);
GdiObject^.Visual := gdk_window_get_visual(GdiObject^.GDIBitmapObject);
end
else begin
GdiObject^.GDIBitmapType := gbPixmap;
GdiObject^.GDIPixmapObject :=
gdk_pixmap_new(DefGdkWindow, Width, Height, BitCount);
GdiObject^.Visual := gdk_window_get_visual(GdiObject^.GDIPixmapObject);
end;
gdk_visual_ref(GdiObject^.Visual);
GdiObject^.SystemVisual := False;
// the visual is created only when needed
{If GdiObject^.Visual <> nil then
gdk_visual_ref(GdiObject^.Visual)
else begin
GdiObject^.Visual := gdk_visual_get_best_with_depth(BitCount);
if GdiObject^.Visual=nil then begin
DebugLn('Warning: [TGtkWidgetSet.CreateBitmap] No visual for depth ',
BitCount,'. Using default.');
GdiObject^.Visual := gdk_visual_get_system;
end;
end;}
// the colormap is only created if needed
//GdiObject^.Colormap := gdk_colormap_new(GdiObject^.Visual, GdkTrue);
{$IFDEF DebugGDKTraps}
EndGDKErrorTrap;
{$ENDIF}
If BitmapBits <> nil then
LoadFromPixbufData(hBitmap(GdiObject), BitmapBits);
{end
else if Bitcount = 1
then begin
Assert(False, Format('Trace: [TGtkWidgetSet.CreateBitmap] gbBitmap', []));
GdiObject^.GDIBitmapType := gbBitmap;
GdiObject^.GDIBitmapObject := gdk_pixmap_new(nil, Width, Height, BitCount);
GdiObject^.Visual := gdk_window_get_visual(GdiObject^.GDIBitmapObject);
If GdiObject^.Visual = nil then
GdiObject^.Visual := gdk_visual_get_best_with_depth(BitCount)
else
gdk_visual_ref(GdiObject^.Visual);
GdiObject^.Colormap := gdk_colormap_new(GdiObject^.Visual, 1)
end;
else begin
Assert(False, Format('Trace: [TGtkWidgetSet.CreateBitmap] gbImage', []));
GdiObject^.GDIBitmapType := gbImage;
GdiObject^.GDI_RGBImageObject := NewGDI_RGBImage(Width, Height, BitCount);
GdiObject^.Visual := gdk_visual_get_best_with_depth(BitCount);
GdiObject^.Colormap := gdk_colormap_new(GdiObject^.Visual, 1);
end;}
Result := HBITMAP(GdiObject);
//DebugLn('[TGtkWidgetSet.CreateBitmap] ',DbgS(Result,8));
Assert(False, Format('Trace:< [TGtkWidgetSet.CreateBitmap] --> 0x%x', [Integer(Result)]));
end;
{------------------------------------------------------------------------------
function TGtkWidgetSet.CreateBitmapFromRawImage(const RawImage: TRawImage;
var Bitmap, MaskBitmap: HBitmap; AlwaysCreateMask: boolean): Boolean;
------------------------------------------------------------------------------}
function TGtkWidgetSet.CreateBitmapFromRawImage(const RawImage: TRawImage;
var Bitmap, MaskBitmap: HBitmap; AlwaysCreateMask: boolean): boolean;
var
GdiObject: PGDIObject;
DefGDkWindow: PGdkWindow;
GDkWindow: PGdkWindow;
GC: PGdkGC;
ImgData: Pointer;
ImgWidth: Cardinal;
ImgHeight: Cardinal;
ImgDepth: Cardinal;
Visual: PGdkVisual;
GdkImage: PGdkImage;
ImgDataSize: Cardinal;
begin
Result:=false;
Bitmap:=0;
MaskBitmap:=0;
if (RawImage.Description.Width=0) or (RawImage.Description.Height=0) then
exit;
try
{$IFDEF VerboseRawImage}
DebugLn('TGtkWidgetSet.CreateBitmapFromRawImage A ',
' AlwaysCreateMask='+dbgs(AlwaysCreateMask),
' Depth='+dbgs(RawImage.Description.Depth),
' Width='+dbgs(RawImage.Description.Width),
' Height='+dbgs(RawImage.Description.Height),
' Data='+DbgS(RawImage.Data),
' DataSize='+dbgs(RawImage.DataSize)+
' Mask='+DbgS(RawImage.Mask)+
' MaskSize='+dbgs(RawImage.MaskSize)+
' Palette='+DbgS(RawImage.Palette)+
' PaletteSize='+dbgs(RawImage.PaletteSize)+
' BitsPerPixel='+dbgs(RawImage.Description.BitsPerPixel)+
'');
{$ENDIF}
// ToDo: check description
DefGdkWindow := nil;
GdiObject := NewGDIObject(gdiBitmap);
GdiObject^.GDIBitmapType := gbPixmap;
// create Pixmap from data
ImgWidth:=RawImage.Description.Width;
ImgHeight:=RawImage.Description.Height;
ImgDepth:=RawImage.Description.Depth;
ImgData:=RawImage.Data;
ImgDataSize:=RawImage.DataSize;
if ImgDepth=1 then begin
// create a GdkBitmap
if RawImage.Data<>nil then begin
GDkWindow:=gdk_bitmap_create_from_data(DefGdkWindow,ImgData,
ImgWidth,ImgHeight);
end else begin
GDkWindow := CreateGdkBitmap(DefGdkWindow,ImgWidth,ImgHeight);
end;
GdiObject^.GDIBitmapObject := GDkWindow;
GdiObject^.GDIBitmapType := gbBitmap;
end else begin
// create a GdkPixmap
if RawImage.Data<>nil then begin
{ The gdk_pixmap_create_from_data seems to be buggy.
It only creates pixmaps of Depth 1
gdk_pixmap_create_from_data(DefGdkWindow,PGChar(RawImage.Data),
RawImage.Description.Width, RawImage.Description.Height,
RawImage.Description.Depth, @fg,@bg);}
GdkWindow:=gdk_pixmap_new(DefGdkWindow,ImgWidth,ImgHeight,ImgDepth);
// Create a GdkImage, copy our data into it and create a pixmap from it
Visual:=gdk_visual_get_best_with_depth(ImgDepth);
GdkImage:=gdk_image_new(GDK_IMAGE_FASTEST,Visual,ImgWidth,ImgHeight);
{$IFDEF VerboseRawImage}
DebugLn('TGtkWidgetSet.CreateBitmapFromRawImage GdkImage: ',
' BytesPerLine=',dbgs(GdkImage^.bpl),
' BitsPerPixel=',dbgs(GetPGdkImageBitsPerPixel(GdkImage)),
' ByteOrder=',dbgs({$IFDEF Gtk1}GdkImage^.byte_order{$ELSE}ord(GdkImage^.byte_order){$ENDIF}),
'');
{$ENDIF}
if (RawImage.Description.BitsPerPixel<>GetPGdkImageBitsPerPixel(GdkImage))
then begin
RaiseGDBException('TGtkWidgetSet.CreateBitmapFromRawImage Incompatible BitsPerPixel');
end;
if (ImgDataSize<>GdkImage^.bpl*ImgHeight) then begin
RaiseGDBException('TGtkWidgetSet.CreateBitmapFromRawImage Incompatible DataSize');
end;
System.Move(ImgData^,GdkImage^.mem^,ImgDataSize);
GC:=gdk_gc_new(GDkWindow);
gdk_draw_image(PGDKDrawable(GdkWindow),GC,
GdkImage,0,0,0,0,ImgWidth,ImgHeight);
gdk_gc_unref(GC);
gdk_image_destroy(GdkImage);
end else begin
GDkWindow := gdk_pixmap_new(DefGdkWindow,
RawImage.Description.Width,RawImage.Description.Height,
RawImage.Description.Depth);
end;
GdiObject^.GDIPixmapObject := GDkWindow;
GdiObject^.Visual := gdk_window_get_visual(GdiObject^.GDIPixmapObject);
gdk_visual_ref(GdiObject^.Visual);
GdiObject^.SystemVisual := False;
end;
// if we are here the bitmap was created successfully
Bitmap:=HBITMAP(GdiObject);
// create mask
if (AlwaysCreateMask or (not RawImageMaskIsEmpty(@RawImage,true)))
and (RawImage.Mask<>nil) then begin
{$IFDEF VerboseRawImage}
DebugLn('TGtkWidgetSet.CreateBitmapFromRawImage creating mask .. ');
{$ENDIF}
// gdk_bitmap_create_from_data expects rileByteBoundary
GdiObject^.GDIBitmapMaskObject :=
gdk_bitmap_create_from_data(DefGdkWindow,PGChar(RawImage.Mask),
RawImage.Description.Width, RawImage.Description.Height);
end;
except
if Bitmap<>0 then DeleteObject(Bitmap);
Bitmap:=0;
if MaskBitmap<>0 then DeleteObject(MaskBitmap);
MaskBitmap:=0;
exit;
end;
Result:=true;
end;
{------------------------------------------------------------------------------
Function: CreateBrushIndirect
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtkWidgetSet.CreateBrushIndirect(const LogBrush: TLogBrush): HBRUSH;
const
//HATCH_NULL : array[0..7] of Byte = ($00, $00, $00, $00, $00, $00, $00, $00);
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);
{This is too fine for a Cross Hatch ($22, $22, $FF, $22, $22, $22, $FF, $22);}
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;
begin
Assert(False, Format('Trace:> [TGtkWidgetSet.CreateBrushIndirect] Style: %d, Color: %8x', [LogBrush.lbStyle, LogBrush.lbColor]));
{$IFDEF DebugGDKTraps}
BeginGDKErrorTrap;
{$ENDIF}
//write('CreateBrushIndirect->');
GObject := NewGDIObject(gdiBrush);
try
{$IFDEF DebugGDIBrush}
DebugLn('[TGtkWidgetSet.CreateBrushIndirect] ',DbgS(GObject));
{$ENDIF}
GObject^.IsNullBrush := False;
with LogBrush do
begin
case lbStyle of
// BS_HOLLOW, // Hollow brush.
BS_NULL: // Same as BS_HOLLOW.
begin
//GObject^.GDIBrushFill := GDK_STIPPLED;
//GObject^.GDIBrushPixmap :=
// gdk_bitmap_create_from_data(nil, @HATCH_NULL, 8, 8);
GObject^.IsNullBrush := True;
end;
BS_SOLID: // Solid brush.
begin
GObject^.GDIBrushFill := GDK_SOLID;
end;
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
RaiseGDBException('invalid lbHatch');
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^.GDIBrushFill := GDK_TILED;
if IsValidGDIObject(lbHatch)
and (PGdiObject(lbHatch)^.GDIType = gdiBitmap)
then
GObject^.GDIBrushPixmap := PGdiObject(lbHatch)^.GDIBitmapObject
else
RaiseGDBException('unsupported bitmap');
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(GObject);
except
Result:=0;
DisposeGDIObject(GObject);
DebugLn('TGtkWidgetSet.CreateBrushIndirect failed');
end;
Assert(False, Format('Trace:< [TGtkWidgetSet.CreateBrushIndirect] Got --> %x', [Result]));
end;
{------------------------------------------------------------------------------
Function: CreateCaret
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtkWidgetSet.CreateCaret(Handle: HWND; Bitmap: hBitmap;
Width, Height: Integer): Boolean;
var
GTKObject: PGTKObject;
BMP: PGDKPixmap;
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.CreateCaret] Finish');
GTKObject := PGTKObject(Handle);
Result := GTKObject <> nil;
if Result then begin
if gtk_type_is_a(gtk_object_type(GTKObject), GTKAPIWidget_GetType)
then begin
if IsValidGDIObjectType(Bitmap, gdiBitmap) then
BMP := 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
else Assert(False, 'Trace:WARNING: [TGtkWidgetSet.CreateCaret] Got null HWND');
end;
{------------------------------------------------------------------------------
Function: CreateCompatibleBitmap
Params: DC:
Width:
Height:
Returns:
Creates a bitmap compatible with the specified device context.
------------------------------------------------------------------------------}
function TGtkWidgetSet.CreateCompatibleBitmap(DC: HDC;
Width, Height: Integer): HBITMAP;
var
Depth : Longint;
GDIObject: PGdiObject;
DefGdkWindow: PGDkWindow;
begin
Assert(False, Format('Trace:> [TGtkWidgetSet.CreateCompatibleBitmap] DC: 0x%x, W: %d, H: %d', [DC, Width, Height]));
Depth := -1;
{$IFDEF DebugGDKTraps}
BeginGDKErrorTrap;
{$ENDIF}
if (IsValidDC(DC) and (TDeviceContext(DC).Drawable <> nil)) then begin
DefGdkWindow := TDeviceContext(DC).Drawable;
Depth := gdk_drawable_get_depth(TDeviceContext(DC).Drawable);
end else
DefGdkWindow:=nil;
If Depth = -1 then
Depth := gdk_visual_get_system^.Depth;
if Depth <> -1 then begin
if (Depth < 1) or (Depth > 32)
then begin
Result := 0;
DebugLn(Format('ERROR: [TGtkWidgetSet.CreateCompatibleBitmap] Illegal depth %d', [Depth]));
{$IFDEF DebugGDKTraps}
EndGDKErrorTrap;
{$ENDIF}
Exit;
end;
GdiObject := NewGDIObject(gdiBitmap);
If Depth = 1 then begin
GdiObject^.GDIBitmapType := gbBitmap;
GdiObject^.GDIBitmapObject :=
gdk_pixmap_new(DefGdkWindow, Width, Height, Depth);
GdiObject^.Visual := gdk_window_get_visual(GdiObject^.GDIPixmapObject);
end
else begin
GdiObject^.GDIBitmapType := gbPixmap;
GdiObject^.GDIPixmapObject :=
gdk_pixmap_new(DefGdkWindow, Width, Height, Depth);
GdiObject^.Visual := gdk_window_get_visual(GdiObject^.GDIPixmapObject);
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);
{$IFDEF DebugGDKTraps}
EndGDKErrorTrap;
{$ENDIF}
Result := HBITMAP(GdiObject);
end else
Result := 0;
Assert(False, Format('Trace:< [TGtkWidgetSet.CreateCompatibleBitmap] DC: 0x%x --> 0x%x', [DC, Result]));
end;
{------------------------------------------------------------------------------
Function: CreateCompatibleDC
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtkWidgetSet.CreateCompatibleDC(DC: HDC): HDC;
var
pNewDC: TDeviceContext;
begin
Result := 0;
pNewDC := NewDC;
// dont copy
// In a compatible DC you have to select a bitmap into it
(*
if IsValidDC(DC) then
with TDeviceContext(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;
{$IFDEF Gtk1}
pNewDC.GetFont;
pNewDC.GetBrush;
pNewDC.GetPen;
{$ENDIF}
Result := HDC(pNewDC);
Assert(False,Format('trace: [TGtkWidgetSet.CreateCompatibleDC] DC: 0x%x --> 0x%x', [Integer(DC), Integer(Result)]));
end;
function TGtkWidgetSet.CreateCursor(ACursorInfo: PIconInfo): hCursor;
procedure GetColorMask(AImage, AMask: PGDKPixmap; AImgBits, AMskBits: PByte; AWidth, AHeight: integer);
var
i, j: integer;
colormap: PGDKColormap;
Image, MaskImage: PGDKImage;
GDKColor: TGDKColor;
Pixel, MaskPixel: LongWord;
offset: byte;
procedure SetColorAndMask(c: TGDKColor; MaskPixel: LongWord);
var
c_bit, m_bit: byte;
begin
c_bit := Ord(0.222 * c.red + 0.707 * c.green + 0.071 * c.blue >= $8000);
m_bit := ord(MaskPixel = 1);
AImgBits^ := AImgBits^ or (c_bit shl offset);
AMskBits^ := AMskBits^ or (m_bit shl offset);
inc(offset);
if offset > 7 then
begin
inc(AImgBits);
inc(AMskBits);
offset := 0;
end;
end;
begin
// most of this code was taken from TGtkWidgetSet.DCGetPixel
Image := gdk_drawable_get_image(AImage, 0, 0, AWidth, AHeight);
MaskImage := gdk_drawable_get_image(AMask, 0, 0, AWidth, AHeight);
{$ifdef Gtk1}
// previously gdk_image_get_colormap(image) was used, implementation
// was casting GdkImage to GdkWindow which is not valid and cause AVs
if gdk_window_get_type(PGdkWindow(AImage))= GDK_WINDOW_PIXMAP then
colormap := nil // pixmaps are created with null colormap, get system one instead
else
colormap := gdk_window_get_colormap(PGdkWindow(AImage));
{$else}
colormap := gdk_image_get_colormap(image);
{$endif}
if colormap = nil then
colormap := gdk_colormap_get_system;
offset := 0;
for j := 0 to AHeight - 1 do
for i := 0 to AWidth - 1 do
begin
Pixel := gdk_image_get_pixel(Image, i, j);
MaskPixel := gdk_image_get_pixel(MaskImage, i, j);
FillChar(GDKColor,SizeOf(GDKColor), 0);
// does not work with TBitmap.Canvas
gdk_colormap_query_color(colormap, Pixel, @GDKColor);
SetColorAndMask(GDKColor, MaskPixel);
end;
gdk_image_unref(Image);
gdk_image_unref(MaskImage);
end;
var
FG, BG: TGDKColor;
Img, Msk: PGdkPixmap;
srcbitmap, mskbitmap: PGdkPixmap;
W, H, bitlen: integer;
ImgBits, MskBits: array of byte;
begin
Result := 0;
if not IsValidGDIObject(ACursorInfo^.hbmColor) then Exit;
Img := PGDIObject(ACursorInfo^.hbmColor)^.GDIBitmapObject;
Msk := PGDIObject(ACursorInfo^.hbmColor)^.GDIBitmapMaskObject;
gdk_drawable_get_size(Img, @W, @H);
bitlen := (W * H) shr 3;
SetLength(ImgBits, bitlen);
SetLength(MskBits, bitlen);
FillChar(ImgBits[0], bitlen, 0);
FillChar(MskBits[0], bitlen, 0);
GetColorMask(Img, Msk, @ImgBits[0], @MskBits[0], W, H);
srcbitmap := gdk_bitmap_create_from_data (nil, @ImgBits[0], W, H);
mskbitmap := gdk_bitmap_create_from_data (nil, @MskBits[0], W, H);
// white
fg.red := $FFFF;
fg.green := $FFFF;
fg.blue := $FFFF;
fg.pixel := 0;
// black
bg.red := 0;
bg.green := 0;
bg.blue := 0;
bg.pixel := 0;
Result := hCursor(gdk_cursor_new_from_pixmap (srcbitmap, mskbitmap, @fg, @bg,
ACursorInfo^.xHotspot, ACursorInfo^.yHotspot));
gdk_pixmap_unref(srcbitmap);
gdk_pixmap_unref(mskbitmap);
end;
function TGtkWidgetSet.DestroyCursor(Handle: hCursor): Boolean;
begin
if Handle <> 0 then
gdk_cursor_destroy(PGdkCursor(Handle));
Result:=true;
end;
{------------------------------------------------------------------------------
Function: CreateFontIndirect
Params: const LogFont: TLogFont
Returns: HFONT
Creates a font GDIObject.
------------------------------------------------------------------------------}
function TGtkWidgetSet.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 TGtkWidgetSet.CreateFontIndirectEx(const LogFont: TLogFont;
const LongFontName: string): HFONT;
{$IfDef GTK2}
begin
DebugLn('ToDo: TGtkWidgetSet.CreateFontIndirectEx');
Result:=0;
end;
{$Else Gtk1}
{off $DEFINE VerboseFonts}
var
GdiObject: PGdiObject;
FontNameRegistry, Foundry, FamilyName, WeightName,
Slant, SetwidthName, AddStyleName, PixelSize,
PointSize, ResolutionX, ResolutionY, Spacing, AverageWidth,
CharSetRegistry, CharSetCoding: string;
n: Integer;
sn, cs: Float;
CachedFont: TGtkFontCacheDescriptor;
CharsetRec: PCharSetEncodingRec;
Weightlist: TStringlist;
CalcPixelSize: boolean;
function LoadFontXLFD(aXLFD: string): boolean;
var
Desc: TGtkFontCacheDescriptor;
begin
GdiObject^.GDIFontObject := gdk_font_load(PChar(aXLFD));
Result:=GdiObject^.GDIFontObject<>nil;
{$ifdef VerboseFonts}
DebugLn('LoadFontXLFD: Trying ',aXLFD,' Matched=',dbgs(Result));
{$endif}
if Result then begin
Desc:=FontCache.Add(GdiObject^.GDIFontObject,LogFont,LongFontName);
if Desc<>nil then
Desc.xlfd:=aXLFD;
end;
end;
function LoadFont: boolean;
var
S: string;
begin
S:=FontNameRegistry+'-'+Foundry+'-'+FamilyName+'-'+WeightName
+'-'+Slant+'-'+SetwidthName+'-'+AddStyleName+'-'+PixelSize
+'-'+PointSize+'-'+ResolutionX+'-'+ResolutionY+'-'+Spacing+'-'+AverageWidth
+'-'+CharSetRegistry+'-'+CharSetCoding;
{ MG: heaptrc gets corrupted heap using the construction below:
S := Format('%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s',
[FontNameRegistry, Foundry, FamilyName, WeightName,
Slant, SetwidthName, AddStyleName, PixelSize,
PointSize, ResolutionX, ResolutionY, Spacing, AverageWidth,
CharSetRegistry, CharSetCoding
]);}
//DebugLn(' Trying Font "',S,'"');
result := LoadFontXLFD(S);
end;
function LoadFontExCharset: boolean;
var
i: Integer;
aSlant,head,tail: string;
begin
Result := False;
Head := FontNameRegistry+'-'+Foundry+'-'+FamilyName+'-';
Tail := '-'+SetwidthName+'-'+AddStyleName+'-'+PixelSize
+'-'+PointSize+'-'+ResolutionX+'-'+ResolutionY+'-'+Spacing
+'-'+AverageWidth+'-'+CharSetRegistry+'-'+CharSetCoding;
//debugln('LoadFontExCharset Head=',Head,' Tail=',Tail);
for i:=0 to WeightList.Count-1 do begin
aSlant := Slant;
repeat
result := LoadFontXLFD(Head+WeightList[i]+'-'+aSlant+Tail);
if result then
exit;
if aSlant='i' then
aSlant:='o'
else
break;
until false;
end;
//debugln('LoadFontExCharset END');
end;
function LoadFontEx: boolean;
var
j: integer;
begin
Result := false;
//debugln('LoadFontEx START CharSetRegistry=',CharSetRegistry);
if CharSetRegistry<>'*' then
result := LoadFontExCharset
else
for j:=0 to CharSetEncodingList.Count-1 do begin
CharSetRec := CharsetEncodingList[j];
if (CharsetRec = nil) or (CharSetRec^.CharSet<>LogFont.lfCharset) then
continue;
CharSetCoding := CharsetRec^.CharSetCod;
CharSetRegistry := CharSetRec^.CharSetReg;
result := LoadFontExCharset;
if result then
break;
end;
//debugln('LoadFontEx END');
end;
procedure LoadDefaultFont;
begin
DisposeGDIObject(GdiObject);
GdiObject:=CreateDefaultFont;
{$IFDEF VerboseFonts}
DebugLn('TGtkWidgetSet.CreateFontIndirectEx.LoadDefaultFont');
{$ENDIF}
end;
function GetDefaultFontFamilyName: string;
begin
Result:=GetDefaultFontName;
if IsFontNameXLogicalFontDesc(Result) then
Result := ExtractXLFDItem(Result,2);
if Result='' then Result:='*';
end;
function ExtractXLFDItemMask(const ALongFontName: string;
Index: Integer): string;
begin
Result:=ExtractXLFDItem(ALongFontName,Index);
if Result='' then Result:='*';
end;
function FamilyNameExists: boolean;
var
AFont: PGdkFont;
S: String;
begin
//S := '*-*-'+FamilyName+'*-*-*-*-*-*-*-*-*-*-*-*-*';
S := '-'+Foundry+'-'+FamilyName+'-*-*-*-*-*-*-*-*-*-*-*-*';
AFont:=gdk_font_load(PChar(s));
Result:=AFont<>nil;
if Result then gdk_font_unref(AFont);
end;
function CheckFontNameIsMangledXLogicalFontDesc(const ALongFontName: string
): boolean;
var
c: Integer;
i: Integer;
begin
c:=0;
for i:=1 to length(ALongFontName) do
if ALongFontName[i]='-' then inc(c);
Result:=(c>5) and (c<>14);
if Result then
debugln('WARNING: Fontnamt "',ALongFontName,'" seems to be a XLFD fontname, but has 14<>',dbgs(c),' minus signs');
end;
function GetPixelSize(Offset: Integer): string;
begin
with LogFont do begin
result := IntToStr(Abs(lfHeight)+Offset);
{$IFNDEF OLD_ROTATION}
if lfOrientation <> 0 then begin
SinCos(lfOrientation/1800.*Pi, sn, cs);
cs := cs*(Abs(lfHeight)+Offset);
sn := sn*(Abs(lfHeight)+Offset);
PixelSize := Format('[%.3f %.3f %.3f %.3f]', [cs, sn, -sn, cs]);
repeat
n := Pos('-', PixelSize);
if n > 0 then
PixelSize[n] := '~';
until n <= 0;
end;
end;
{$ENDIF}
end;
begin
// For info about xlfd see:
// http://wwwinfo.cern.ch/umtf/working-groups/X11/fonts/hp_xlfd.html
// Lets fill in all the xlfd parts. Assume we have scalable fonts.
{$IFDEF VerboseFonts}
DebugLn('TGtkWidgetSet.CreateFontIndirectEx A Name=',LogFont.lfFaceName,' Height=',dbgs(LogFont.lfHeight),' LongName=',LongFontName);
{$ENDIF}
Result := 0;
GDIObject := NewGDIObject(gdiFont);
try
GdiObject^.LogFont := LogFont;
CachedFont:=FontCache.FindGTkFontDesc(LogFont,LongFontName);
if CachedFont<>nil then begin
CachedFont.Item.IncreaseRefCount;
GdiObject^.GDIFontObject := TGtkFontCacheItem(CachedFont.Item).GtkFont;
{$IFDEF VerboseFonts}
WriteLn('Was in cache: ', Integer(CachedFont));
{$ENDIF}
exit;
end;
// set default values
FontNameRegistry := '*';
Foundry := '*';
FamilyName := '*';
WeightName := '*';
Slant := '*';
SetwidthName := '*';
AddStyleName := '*';
PixelSize := '*';
PointSize := '*';
ResolutionX := '*';
ResolutionY := '*';
Spacing := '*';
AverageWidth := '*';
CharSetRegistry := '*';
CharSetCoding := '*';
// check if LongFontName is in XLFD format and get nicer defaults
// This way, the user can set X fonts that are not supported by TFont.
{$IFDEF VerboseFonts}
DebugLn('TGtkWidgetSet.CreateFontIndirectEx Name="',LogFont.lfFaceName,'"',
' Long="',LongFontName,'" IsXLFD=',dbgs(IsFontNameXLogicalFontDesc(LongFontName))
,' ',dbgs(ord(LogFont.lfFaceName[0])));
{$ENDIF}
if IsFontNameXLogicalFontDesc(LongFontName) then begin
FontNameRegistry := ExtractXLFDItemMask(LongFontName,0);
Foundry := ExtractXLFDItemMask(LongFontName,1);
FamilyName := ExtractXLFDItemMask(LongFontName,2);
WeightName := ExtractXLFDItemMask(LongFontName,3);
Slant := ExtractXLFDItemMask(LongFontName,4);
SetWidthName := ExtractXLFDItemMask(LongFontName,5);
AddStyleName := ExtractXLFDItemMask(LongFontName,6);
PixelSize := ExtractXLFDItemMask(LongFontName,7);
PointSize := ExtractXLFDItemMask(LongFontName,8);
ResolutionX := ExtractXLFDItemMask(LongFontName,9);
ResolutionY := ExtractXLFDItemMask(LongFontName,10);
Spacing := ExtractXLFDItemMask(LongFontName,11);
AverageWidth := ExtractXLFDItemMask(LongFontName,12);
CharSetRegistry := ExtractXLFDItemMask(LongFontName,13);
CharSetCoding := ExtractXLFDItemMask(LongFontName,14);
end else if CheckFontNameIsMangledXLogicalFontDesc(LongFontName) then begin
// warned
end;
with LogFont do
begin
if lfFaceName[0] = #0
then begin
Assert(false,'ERROR: [TGtkWidgetSet.CreateFontIndirectEx] No fontname');
Exit;
end;
FamilyName := StrPas(lfFaceName);
if (CompareText(FamilyName,'default')<>0) then begin
// check if we have foundry encoded in family name
n := pos(FOUNDRYCHAR_OPEN, FamilyName);
if n<>0 then begin
Foundry := copy(FamilyName, n+1, Length(FamilyName));
familyName := trim(copy(familyName, 1, n-1));
n := pos(FOUNDRYCHAR_CLOSE, Foundry);
if n<>0 then
Delete(Foundry, n, Length(Foundry));
end;
if not FamilyNameExists then
FamilyName:='default';
end;
if CompareText(FamilyName,'default')=0 then begin
{$IFDEF VerboseFonts}
DebugLn('TGtkWidgetSet.CreateFontIndirectEx FamilyName="',FamilyName,'" PixelSize=',PixelSize,' LogFont.lfHeight=',dbgs(LogFont.lfHeight));
{$ENDIF}
if (LogFont.lfHeight=0) then begin
LoadDefaultFont;
exit;
end else begin
FamilyName:=GetDefaultFontFamilyName;
Foundry:='*';
end;
end;
Assert(False, Format('trace: [TGtkWidgetSet.CreateFontIndirectEx] Name: %s, Height: %d', [FamilyName, lfHeight]));
// calculate weight offset.
// API XLFD
// --------------------- --------------
// Weight=400 --> normal normal
// Weight=700 --> bold normal+4000 (or bold in non scalable fonts)
//
// So in API the offset for normal = 400 and an increase of 300 equals to
// an offset of 4000
if WeightName='*' then begin
case lfWeight of
FW_DONTCARE : WeightName := '*';
FW_LIGHT : WeightName := 'light';
FW_NORMAL : ; // try several later
FW_MEDIUM : WeightName := 'medium';
FW_SEMIBOLD : WeightName := 'demi bold';
FW_BOLD : ; // try several later
else begin
n := ((lfWeight - FW_NORMAL) * 4000) div (FW_BOLD - FW_NORMAL);
if n = 0
then WeightName := 'normal'
else if n > 0
then WeightName := Format('normal+%d', [n])
else WeightName := Format('normal%d', [n]);
end;
end;
end;
if Slant='*' then begin
// TODO: find out if escapement has something to do with slant
if lfItalic = 0 then Slant := 'r' else Slant := 'i';
end;
// SetWidthName := '*';
{$IFDEF OLD_ROTATION}
if AddStyleName='*' then begin
// calculate Style name extentions (=rotation)
// API XLFD
// --------------------- --------------
// Orientation 1/10 deg 1/64 deg
if lfOrientation = 0
then AddStyleName := '*'
else begin
n := (lfOrientation * 64) div 10;
if n >= 0
then AddStyleName := Format('+%d', [n])
else AddStyleName := Format('+%d', [n]);
end;
end;
{$ENDIF}
CalcPixelSize:= (PixelSize='*') and (PointSize='*');
if CalcPixelSize then begin
// TODO: make more accurate (implement the meaning of
// positive and negative height values.
PixelSize := GetPixelSize(0);
// Since we use pixelsize, it isn't allowed to give a value here
PointSize := '*';
// Use the default
ResolutionX := '*';
ResolutionY := '*';
end;
if Spacing='*' then begin
// spacing
if (FIXED_PITCH and lfPitchAndFamily)>0 then
Spacing := 'm' // mono spaced
else if (VARIABLE_PITCH and lfPitchAndFamily)>0 then
Spacing := 'p' // proportional spaced
else
Spacing := '*';
end;
if AverageWidth='*' then begin
// calculate AverageWidth
// API XLFD
// --------------------- --------------
// Width pixel 1/10 pixel
if lfWidth = 0
then AverageWidth := '*'
else AverageWidth := InttoStr(lfWidth * 10);
end;
// this section tries several combinations of charset-weightname-slant
//
WeightList := TStringList.Create;
if LogFOnt.LfWeight = FW_BOLD then
// bold appears most times
WeightList.CommaText := 'bold,semibold,demibold,black,*'
else
// medium appears most times but if there is normal, use it
WeightList.CommaText := 'normal,medium,regular,light,*';
if WeightName<>'*' then
WeightList.Insert(0, WeightName);
try
if LoadFontEx then
exit;
// not found yet, before doing a generic fall over
// try to do a more specific guess.
if CalcPixelSize then
repeat
// try one pixel smaller
{$IFDEF VerboseFonts}
debugln('TGtkWidgetSet.CreateFontIndirectEx, LoadFontEx: try one pixel smaller');
{$ENDIF}
PixelSize:=GetPixelSize(-1);
if LoadFontEx then
exit;
// try one pixel bigger
{$IFDEF VerboseFonts}
debugln('TGtkWidgetSet.CreateFontIndirectEx, LoadFontEx: try one pixel bigger');
{$ENDIF}
PixelSize:=GetPixelSize(1); // try
if LoadFontEx then
exit;
// not found yet
// if font was slanted try with any within font face.
if Slant<>'*' then begin
Slant := '*';
continue;
end;
break;
until false;
finally
WeightList.Free;
end;
end;
// next checks are fall over
{$IFDEF VerboseFonts}
debugln('TGtkWidgetSet.CreateFontIndirectEx ');
{$ENDIF}
{
if LoadFont then exit;
// try all weights
WeightName := '*';
if LoadFont then exit;
}
// try one height smaller
{$IFDEF VerboseFonts}
debugln('TGtkWidgetSet.CreateFontIndirectEx try one height smaller');
{$ENDIF}
PixelSize := IntToStr(Abs(LogFont.lfHeight)-1);
// Since we use pixelsize, it isn't allowed to give a value here
PointSize := '*';
// Use the default
ResolutionX := '*';
ResolutionY := '*';
if LoadFont then exit;
// try one height bigger
{$IFDEF VerboseFonts}
debugln('TGtkWidgetSet.CreateFontIndirectEx try one height bigger');
{$ENDIF}
PixelSize := IntToStr(Abs(LogFont.lfHeight)+1);
if LoadFont then exit;
PixelSize := IntToStr(Abs(LogFont.lfHeight));
// try instead of mono spaced -> character cell spaced
if (Spacing='m') then begin
{$IFDEF VerboseFonts}
debugln('TGtkWidgetSet.CreateFontIndirectEx try instead of mono spaced -> character cell spaced');
{$ENDIF}
Spacing:='c';
if LoadFont then exit;
end;
{
// try instead of italic -> oblique
if (Slant='i') then begin
Slant := 'o';
if LoadFont then exit;
end;
// try all slants
Slant := '*';
if LoadFont then exit;
}
// try all spacings
if spacing<>'*' then begin
{$IFDEF VerboseFonts}
debugln('TGtkWidgetSet.CreateFontIndirectEx try all spacings');
{$ENDIF}
Spacing := '*';
if LoadFont then exit;
end;
if charSetCoding<>'*' then begin
{$IFDEF VerboseFonts}
debugln('TGtkWidgetSet.CreateFontIndirectEx try all charsets');
{$ENDIF}
charsetCoding := '*';
charSetRegistry:= '*';
if LoadFont then exit;
end;
if (Foundry<>'*') then begin
// try all Families
{$IFDEF VerboseFonts}
debugln('TGtkWidgetSet.CreateFontIndirectEx try all families');
{$ENDIF}
PixelSize := IntToStr(Abs(LogFont.lfHeight));
FamilyName := '*';
if LoadFont then exit;
end;
// nothing exists -> use default
LoadDefaultFont;
finally
if GdiObject^.GDIFontObject = nil
then begin
{$IFDEF VerboseFonts}
DebugLn('[TGtkWidgetSet.CreateFontIndirect] ',DbgS(GdiObject),' ',dbgs(FGDIObjects.Count));
{$ENDIF}
DisposeGDIObject(GdiObject);
Result := 0;
end
else begin
Result := HFONT(GdiObject);
end;
if Result = 0
then DebugLn('WARNING: [TGtkWidgetSet.CreateFontIndirectEx] NOT found XLFD: <'+LongFontName+'> Fontname="'+LogFont.lfFaceName+'"')
else Assert(False, Format('Trace: [TGtkWidgetSet.CreateFontIndirectEx] found XLFD: <%s>', [LongFontName]));
end;
end;
{$EndIf}
{------------------------------------------------------------------------------
Function: CreatePalette
Params: LogPalette
Returns: a handle to the Palette created
------------------------------------------------------------------------------}
function TGtkWidgetSet.CreatePalette(const LogPalette: TLogPalette): HPALETTE;
var
GObject: PGdiObject;
begin
Assert(False, 'trace:[TGtkWidgetSet.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(GObject);
end;
{------------------------------------------------------------------------------
Function: CreatePenIndirect
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtkWidgetSet.CreatePenIndirect(const LogPen: TLogPen): HPEN;
var
GObject: PGdiObject;
begin
Assert(False, 'trace:[TGtkWidgetSet.CreatePenIndirect]');
//write('CreatePenIndirect->');
GObject := NewGDIObject(gdiPen);
with LogPen do
begin
GObject^.GDIPenStyle := lopnStyle;
GObject^.GDIPenWidth := lopnWidth.X;
SetGDIColorRef(GObject^.GDIPenColor,lopnColor);
end;
Result := HPEN(GObject);
end;
{------------------------------------------------------------------------------
Function: CreatePixmapIndirect
Params: Data: Raw pixmap data (PPGChar of xpm file,
You can use graphics.XPMToPPChar to create this)
Returns: Handle to LCL bitmap
Creates a bitmap from raw pixmap data.
If TransColor < 0 the transparency mask will be automatically gnerated.
------------------------------------------------------------------------------}
function TGtkWidgetSet.CreatePixmapIndirect(const Data: Pointer;
const TransColor: Longint): HBITMAP;
var
GdiObject: PGdiObject;
GDKColor: TGDKColor;
ColorMap: PGdkColormap;
P: Pointer;
Depth : Longint;
begin
GdiObject := NewGDIObject(gdiBitmap);
if TransColor >= 0 then begin
GDKColor := AllocGDKColor(TransColor);
p := @GDKColor;
end else
p:=nil; // automatically create transparency mask
{$IFDEF DebugGDKTraps}
BeginGDKErrorTrap;
{$ENDIF}
ColorMap:=gdk_colormap_get_system;
try
GdiObject^.GDIPixmapObject :=
gdk_pixmap_colormap_create_from_xpm_d(nil,Colormap,
GdiObject^.GDIBitmapMaskObject, p, Data);
Depth := gdk_drawable_get_depth(GdiObject^.GDIPixmapObject);
If GdiObject^.Visual <> nil then
GDK_Visual_UnRef(GdiObject^.Visual);
GdiObject^.Visual := gdk_window_get_visual(GdiObject^.GDIPixmapObject);
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;
If GdiObject^.Colormap <> nil then
GDK_Colormap_UnRef(GdiObject^.Colormap);
GdiObject^.Colormap := gdk_colormap_new(GdiObject^.Visual, GdkFalse);
GdiObject^.GDIBitmapType:=gbPixmap;
except
DisposeGDIObject(GdiObject);
GdiObject:=nil;
end;
{$IFDEF DebugGDKTraps}
EndGDKErrorTrap;
{$ENDIF}
Result := HBITMAP(GdiObject);
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 TGtkWidgetSet.CreatePolygonRgn(Points: PPoint; NumPts: Integer;
FillMode: integer): HRGN;
var
i: integer;
PointArray: PGDKPoint;
GObject: PGdiObject;
fr : TGDKFillRule;
begin
Result := 0;
if NumPts<=0 then exit;
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(GObject);
end;
{------------------------------------------------------------------------------
Function: CreateRectRgn
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtkWidgetSet.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(GObject);
//DebugLn('TGtkWidgetSet.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 TGtkWidgetSet.CombineRgn(Dest, Src1, Src2 : HRGN;
fnCombineMode : Longint) : Longint;
var
Continue : Boolean;
D, S1, S2 : PGDKRegion;
DObj, S1Obj, S2Obj : PGDIObject;
begin
Result := SIMPLEREGION;
DObj := PGdiObject(Dest);
S1Obj := PGdiObject(Src1);
S2Obj := PGdiObject(Src2);
Continue := IsValidGDIObject(Dest) and IsValidGDIObject(Src1)
and IsValidGDIObject(Src2);
If Not Continue then begin
DebugLn('WARNING: [TGtkWidgetSet.CombineRgn] Invalid HRGN');
Result := Error;
end
else begin
If DObj^.GDIRegionObject <> nil then begin
gdk_region_destroy(DObj^.GDIRegionObject);
DObj^.GDIRegionObject:=nil;
end;
S1 := S1Obj^.GDIRegionObject;
S2 := S2Obj^.GDIRegionObject;
//DebugLn('TGtkWidgetSet.CombineRgn A fnCombineMode=',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;
DObj^.GDIRegionObject := D;
Result := RegionType(D);
//DebugLn('TGtkWidgetSet.CombineRgn B Mode=',fnCombineMode,
// ' S1=',GDKRegionAsString(S1),' S2=',GDKRegionAsString(S2),' D=',GDKRegionAsString(D),'');
end;
end;
{------------------------------------------------------------------------------
function TGtkWidgetSet.ComboBoxDropDown(Handle: HWND;
DropDown: boolean): boolean; override;
------------------------------------------------------------------------------}
function TGtkWidgetSet.ComboBoxDropDown(Handle: HWND; DropDown: boolean): boolean;
procedure gtk_combo_get_pos(combo : PGtkCombo; var x : gint; var y : gint;
var height : gint; var width : gint);
var
popwin : PGtkbin;
widget : PGtkWidget;
popup : PGtkScrolledwindow;
real_height : gint;
list_requisition : PGtkRequisition;
show_hscroll : gboolean;
show_vscroll : gboolean;
avail_height : gint;
min_height : gint;
alloc_width : gint;
work_height : gint;
old_height : gint;
old_width : gint;
okay_to_exit : boolean;
const
EMPTY_LIST_HEIGHT = 15;
begin
show_hscroll := False;
show_vscroll := False;
widget := GTK_WIDGET(combo);
popup := GTK_SCROLLED_WINDOW (combo^.popup);
popwin := GTK_BIN (combo^.popwin);
gdk_window_get_origin (combo^.entry^.window, @x, @y);
real_height := MIN (combo^.entry^.requisition.height,
combo^.entry^.allocation.height);
y := y + real_height;
avail_height := gdk_screen_height () - y;
New(list_requisition);
if combo^.list<>nil then begin
gtk_widget_size_request (combo^.list, list_requisition);
end else begin
list_requisition^.height:=1;
list_requisition^.width:=1;
end;
min_height := MIN (list_requisition^.height,popup^.vscrollbar^.requisition.height);
if GTK_LIST (combo^.list)^.children = nil then
list_requisition^.height := list_requisition^.height + EMPTY_LIST_HEIGHT;
alloc_width := (cardinal(widget^.allocation.width) -
2 * cardinal(gtk_widget_get_xthickness(gtk_bin_get_child(popwin))) -
2 * border_width(GTK_CONTAINER (gtk_bin_get_child(popwin))^) -
2 * border_width(GTK_CONTAINER (combo^.popup)^) -
2 * border_width(GTK_CONTAINER (gtk_bin_get_child(PGTKBin(popup)))^) -
2 * cardinal(gtk_widget_get_xthickness(gtk_bin_get_child(PGTKBin(popup)))));
work_height := (2 * cardinal(gtk_widget_get_ythickness(gtk_bin_get_child(popwin))) +
2 * border_width(GTK_CONTAINER (gtk_bin_get_child(popwin))^) +
2 * border_width(GTK_CONTAINER (combo^.popup)^) +
2 * border_width(GTK_CONTAINER (gtk_bin_get_child(PGTKBin(popup)))^) +
2 * cardinal(gtk_widget_get_xthickness(gtk_bin_get_child(PGTKBin(popup)))));
repeat
okay_to_exit := True;
old_width := alloc_width;
old_height := work_height;
if ((not show_hscroll) and (alloc_width < list_requisition^.width)) then
begin
work_height := work_height + popup^.hscrollbar^.requisition.height +
GTK_SCROLLED_WINDOW_CLASS(gtk_object_get_class(combo^.popup))^.scrollbar_spacing;
show_hscroll := TRUE;
okay_to_exit := False;
end;
if ((not show_vscroll) and (work_height + list_requisition^.height > avail_height)) then
begin
if ((work_height + min_height > avail_height) and (y - real_height > avail_height)) then
begin
y := y - (work_height + list_requisition^.height + real_height);
break;
end;
alloc_width := alloc_width -
popup^.vscrollbar^.requisition.width +
GTK_SCROLLED_WINDOW_CLASS(gtk_object_get_class(combo^.popup))^.scrollbar_spacing;
show_vscroll := TRUE;
okay_to_exit := False;
end;
until ((old_width <> alloc_width) or (old_height <> work_height) or okay_to_exit);
width := widget^.allocation.width;
if (show_vscroll) then
height := avail_height
else
height := work_height + list_requisition^.height;
if (x < 0) then
x := 0;
Dispose(list_requisition);
end;
var
ComboWidget: PGtkCombo;
height, width, x, y : gint;
old_width, old_height : gint;
begin
Result:=false;
if Handle=0 then exit;
ComboWidget:=PGtkCombo(Handle);
if DropDown<>GTK_WIDGET_VISIBLE(ComboWidget^.popwin) then begin
if DropDown then begin
old_width := ComboWidget^.popwin^.allocation.width;
old_height := ComboWidget^.popwin^.allocation.height;
gtk_combo_get_pos(ComboWidget,x,y,height,width);
if ((old_width <> width) or (old_height <> height)) then
begin
gtk_widget_hide (GTK_SCROLLED_WINDOW(ComboWidget^.popup)^.hscrollbar);
gtk_widget_hide (GTK_SCROLLED_WINDOW(ComboWidget^.popup)^.vscrollbar);
end;
gtk_widget_set_uposition (comboWidget^.popwin,x, y);
gtk_widget_set_usize(ComboWidget^.popwin,width ,height);
gtk_widget_realize(ComboWidget^.popwin);
{$IFDEF DebugGDKTraps}
BeginGDKErrorTrap;
{$ENDIF}
gdk_window_resize(ComboWidget^.popwin^.window,width,height);
{$IFDEF DebugGDKTraps}
EndGDKErrorTrap;
{$ENDIF}
gtk_widget_show (ComboWidget^.popwin);
gtk_widget_grab_focus(ComboWidget^.popwin);
end else
gtk_widget_hide (ComboWidget^.popwin);
end;
Result:=true;
end;
{------------------------------------------------------------------------------
Function: DeleteDC
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtkWidgetSet.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
------------------------------------------------------------------------------}
function TGtkWidgetSet.DeleteObject(GDIObject: HGDIOBJ): Boolean;
procedure RaiseInvalidGDIObject;
begin
{$ifdef TraceGdiCalls}
DebugLn();
DebugLn('TGtkWidgetSet.DeleteObject: TraceCall for invalid object: ');
DumpBackTrace(PgdiObject(GdiObject)^.StackAddrs);
DebugLn();
DebugLn('Exception will follow:');
DebugLn();
{$endif}
RaiseGDBException('TGtkWidgetSet.DeleteObject invalid GdiObject='+dbghex(GdiObject));
end;
procedure RaiseGDIObjectIsStillUsed;
var
CurGDIObject: PGDIObject;
DC: TDeviceContext;
begin
{$ifdef TraceGdiCalls}
DebugLn();
DebugLn('TGtkWidgetSet.DeleteObject: TraceCall for still used object: ');
DumpBackTrace(PgdiObject(GdiObject)^.StackAddrs);
DebugLn();
DebugLn('Exception will follow:');
DebugLn();
{$endif}
// do not raise an exception, because this is a common bug in many programs
// just give a warning
CurGDIObject:=PGdiObject(GdiObject);
debugln('TGtkWidgetSet.DeleteObject GdiObject='+dbgs(CurGDIObject)
+' '+dbgs(CurGDIObject^.GDIType)
+' is still used. DCCount='+dbgs(CurGDIObject^.DCCount));
DC:=FindDCWithGDIObject(CurGDIObject);
if DC<>nil then begin
DebugLn(['DC: ',dbgs(Pointer(DC)),' ',
GetWidgetDebugReport(DC.DCWidget)]);
end else begin
DebugLn(['No DC found with this GDIObject => either the DCCount is wrong or the DC is not in the DC list']);
end;
//DumpStack;
//RaiseGDBException('');
end;
procedure RaiseInvalidGDIOwner;
var
o: PGDIObject;
begin
{$ifdef TraceGdiCalls}
DebugLn();
DebugLn('TGtkWidgetSet.DeleteObject: TraceCall for invalid object: ');
DumpBackTrace(PgdiObject(GdiObject)^.StackAddrs);
DebugLn();
DebugLn('Exception will follow:');
DebugLn();
{$endif}
o:=PGdiObject(GdiObject);
RaiseGDBException('TGtkWidgetSet.DeleteObject invalid owner of'
+' GdiObject='+dbgs(o)
+' Owner='+dbgs(o^.Owner)
+' Owner.OwnedGDIObjects='+dbgs(o^.Owner.OwnedGDIObjects[o^.GDIType]));
end;
var
GDIObjectExists: boolean;
begin
if GDIObject=0 then begin
Result:=true;
exit;
end;
{$IFDEF DebugLCLComponents}
if DebugGdiObjects.IsDestroyed(PGDIObject(GDIObject)) then begin
DebugLn(['TGtkWidgetSet.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(PGDIObject(GDIObject));
Result:=GDIObjectExists;
if not GDIObjectExists then begin
RaiseInvalidGDIObject;
end;
with PGdiObject(GDIObject)^ do
begin
if DCCount>0 then begin
RaiseGDIObjectIsStillUsed;
exit(false);
end;
if Owner<>nil then begin
if Owner.OwnedGDIObjects[GDIType]<>PGdiObject(GDIObject) then
RaiseInvalidGDIOwner;
Owner.OwnedGDIObjects[GDIType]:=nil;
end;
case GDIType of
gdiFont:
begin
if GDIFontObject<>nil then begin
//DebugLn(['TGtkWidgetSet.DeleteObject GDIObject=',dbgs(Pointer(PtrInt(GDIObject))),' GDIFontObject=',dbgs(GDIFontObject)]);
FontCache.Unreference(GDIFontObject);
end;
end;
gdiBrush:
begin
{$IFDEF DebugGDKTraps}
BeginGDKErrorTrap;
{$ENDIF}
{$IFDEF DebugGDIBrush}
debugln('TGtkWidgetSet.DeleteObject gdiBrush: ',DbgS(GdiObject));
//if Cardinal(GdiObject)=$404826F4 then RaiseGDBException('');
{$ENDIF}
if (GDIBrushPixmap <> nil)
then gdk_bitmap_unref(GDIBrushPixmap);
{$IFDEF DebugGDKTraps}
EndGDKErrorTrap;
{$ENDIF}
FreeGDIColor(@GDIBrushColor);
end;
gdiBitmap:
begin
{$IFDEF DebugGDKTraps}
BeginGDKErrorTrap;
{$ENDIF}
if GDIBitmapObject <> nil then
gdk_bitmap_unref(GDIBitmapObject);
If (Visual <> nil) and (not SystemVisual) then
gdk_visual_unref(Visual);
If Colormap <> nil then
gdk_colormap_unref(Colormap);
{$IFDEF DebugGDKTraps}
EndGDKErrorTrap;
{$ENDIF}
end;
gdiPen:
begin
FreeGDIColor(@GDIPenColor);
end;
gdiRegion:
begin
if (GDIRegionObject <> nil) then
gdk_region_destroy(GDIRegionObject);
end;
gdiPalette:
begin
{$IFDEF DebugGDKTraps}
BeginGDKErrorTrap;
{$ENDIF}
If PaletteVisual <> nil then
gdk_visual_unref(PaletteVisual);
If PaletteColormap <> nil then
gdk_colormap_unref(PaletteColormap);
{$IFDEF DebugGDKTraps}
EndGDKErrorTrap;
{$ENDIF}
FreeAndNil(RGBTable);
FreeAndNil(IndexTable);
end;
else begin
Result:= false;
DebugLn('[TGtkWidgetSet.DeleteObject] TODO : Unimplemented GDI type');
Assert(False, 'Trace:TODO : Unimplemented GDI object in delete object');
end;
end;
end;
{ Dispose of the GDI object }
//DebugLn('[TGtkWidgetSet.DeleteObject] ',Result,' ',DbgS(GDIObject,8),' ',FGDIObjects.Count);
DisposeGDIObject(PGDIObject(GDIObject));
end;
{------------------------------------------------------------------------------
Function: DestroyCaret
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtkWidgetSet.DestroyCaret(Handle: HWND): Boolean;
var
GTKObject: PGTKObject;
begin
GTKObject := PGTKObject(Handle);
Result := true;
if GTKObject<>nil then begin
if gtk_type_is_a(gtk_object_type(GTKObject), GTKAPIWidget_GetType)
then begin
GTKAPIWidget_DestroyCaret(PGTKAPIWidget(GTKObject));
end
// else if // TODO: other widgettypes
else begin
Result := False;
end;
end
else Assert(False, 'Trace:WARNING: [TGtkWidgetSet.DestroyCaret] Got null HWND');
end;
{------------------------------------------------------------------------------
Function: DrawFrameControl
Params:
Returns:
------------------------------------------------------------------------------}
function TGtkWidgetSet.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
Widget: PGtkWidget;
procedure DrawButtonPush;
var
State: TGtkStateType;
Shadow: TGtkShadowType;
aStyle : PGTKStyle;
aDC: TDeviceContext;
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_INACTIVE and uState)<>0 then begin
// button disabled
State:=GTK_STATE_INSENSITIVE;
end else begin
if (DFCS_PUSHED and uState)<>0 then begin
// button enabled, down
if (DFCS_CHECKED and uState)<>0 then begin
// button enabled, down, special (e.g. mouse over)
State:=GTK_STATE_ACTIVE;
end else begin
// button enabled, down, normal
State:=GTK_STATE_SELECTED;
end;
end else begin
// button enabled, up
if (DFCS_CHECKED and uState)<>0 then begin
// button enabled, up, special (e.g. mouse over)
State:=GTK_STATE_PRELIGHT;
end else begin
// button enabled, up, normal
State:=GTK_STATE_NORMAL;
end;
end;
end;
// 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:=TDeviceContext(DC);
DCOrigin:=GetDCOffset(aDC);
aStyle := gtk_widget_get_style(Widget);
if aStyle=nil then
aStyle := GetStyle(lgsButton);
If aStyle = nil then
aStyle := GetStyle(lgsGTK_Default);
If State = GTK_STATE_SELECTED then
State := GTK_STATE_ACTIVE;
// 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
If (Shadow=GTK_SHADOW_NONE) then
gtk_paint_flat_box(aStyle,aDC.Drawable,
State,
Shadow,
nil,
Widget,
'button',
Rect.Left+DCOrigin.X,Rect.Top+DCOrigin.Y,
Rect.Right-Rect.Left,Rect.Bottom-Rect.Top)
else
gtk_paint_box(aStyle,aDC.Drawable,
State,
Shadow,
nil,
Widget,
'button',
Rect.Left+DCOrigin.X,Rect.Top+DCOrigin.Y,
Rect.Right-Rect.Left,Rect.Bottom-Rect.Top);
end;
Result := True;
end;
procedure DrawCheck;
var
State: TGtkStateType;
Shadow: TGtkShadowType;
aDC: TDeviceContext;
DCOrigin: TPoint;
Style : PGTKStyle;
Widget : PGTKWidget;
begin
// use the gtk paint functions to draw a widget style dependent check(box)
if (DFCS_PUSHED and uState)<>0 then begin
STATE := GTK_STATE_ACTIVE;//button checked(GTK ignores disabled)
Shadow := GTK_SHADOW_IN;//checked style
end
else begin
Shadow := GTK_SHADOW_OUT; //unchecked style
if (DFCS_INACTIVE and uState)<>0 then begin
State:=GTK_STATE_INSENSITIVE;//button disabled
end else
if (DFCS_CHECKED and uState)<>0 then begin
// button enabled, special (e.g. mouse over)
State:=GTK_STATE_PRELIGHT;
end else begin
// button enabled, normal
State:=GTK_STATE_NORMAL;
end;
end;
aDC:=TDeviceContext(DC);
DCOrigin:=GetDCOffset(aDC);
Style := GetStyle(lgsCheckbox);
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(lgsCheckbox);
If Widget = nil then
Widget := GetStyleWidget(lgsDefault);
If (Widget <> nil) and (Style <> nil) then begin
Widget^.Window := aDC.Drawable;
gtk_paint_check(Style,aDC.Drawable, State,
Shadow, nil, Widget, 'checkbutton',
Rect.Left+DCOrigin.X,Rect.Top+DCOrigin.Y,
Rect.Right-Rect.Left, Rect.Bottom-Rect.Top);
Result := True;
end
else begin
{$IfNDef Win32}
if Style<>nil then
gtk_draw_check(Style,aDC.Drawable, State,
Shadow, Rect.Left+DCOrigin.X,Rect.Top+DCOrigin.Y,
Rect.Right-Rect.Left, Rect.Bottom-Rect.Top);
{$EndIf}
Result := True;
end;
end;
var ClientWidget: PGtkWidget;
begin
Result := False;
if IsValidDC(DC) then begin
Widget:=TDeviceContext(DC).DCWidget;
ClientWidget:=GetFixedWidget(Widget);
if ClientWidget<>nil then
Widget:=ClientWidget;
end else
Widget:=nil;
case uType of
DFC_CAPTION:
begin //all draw CAPTION commands here
end;
DFC_MENU:
begin
end;
DFC_SCROLL:
begin
end;
DFC_BUTTON:
begin
Assert(False, Format('Trace: [TGtkWidgetSet.DrawFrameControl] DFC_BUTTON --> draw rect = %d,%d,%d,%d',[Rect.Left,Rect.Top,REct.Right,REct.Bottom]));
//figure out the style first
case uState and $1F of
DFCS_BUTTONRADIOIMAGE:
begin
Assert(False, 'Trace:State ButtonRadioImage');
end;
DFCS_BUTTONRADIOMASK:
begin
Assert(False, 'Trace:State ButtonRadioMask');
end;
DFCS_BUTTONRADIO:
begin
Assert(False, 'Trace:State ButtonRadio');
end;
DFCS_BUTTON3STATE:
begin
Assert(False, 'Trace:State Button3State');
end;
DFCS_BUTTONPUSH:
begin
Assert(False, 'Trace:DFCS_BUTTONPUSH in uState');
DrawButtonPush;
end;
DFCS_BUTTONCHECK:
begin
Assert(False, 'Trace:State ButtonCheck');
DrawCheck;
end;
else
DebugLn(Format('ERROR: [TGtkWidgetSet.DrawFrameControl] Unknown State 0x%x', [uState]));
end;
end;
else
DebugLn(Format('ERROR: [TGtkWidgetSet.DrawFrameControl] Unknown type %d', [uType]));
end;
end;
function TGTKWidgetSet.DrawFocusRect(DC: HDC; const Rect: TRect): boolean;
var
Origin: TPoint;
procedure DrawPixel(X1,Y1: Integer);
begin
inc(X1,Origin.X);
inc(Y1,Origin.Y);
gdk_draw_point(TDeviceContext(DC).Drawable, TDeviceContext(DC).GetGC, 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;
begin
Result := False;
if IsValidDC(DC) then begin
with LogPen do begin
lopnStyle := PS_DOT;
lopnWidth.X := 2;
lopnColor := clWhite;
end;
APen := CreatePenIndirect(LogPen);
TempPen := SelectObject(DC, APen);
OldRop := SetROP2(DC, R2_XORPEN);
Origin := GetDCOffset(TDeviceContext(DC));
try
with Rect do begin
DrawHorzLine(Left, Top, Right-1);
DrawVertLine(Right-1, Top, Bottom-1);
DrawHorzLine(Right-1, Bottom-1, Left);
DrawVertLine(Left, Bottom-1, Top);
end;
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 TGtkWidgetSet.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: TGDKColor;
BInner, BOuter: Boolean;
Width, Height: Integer;
R: TRect;
DCOrigin: TPoint;
begin
//DebugLn('TGtkWidgetSet.DrawEdge Edge=',DbgS(Edge),8),' grfFlags=',DbgS(Cardinal(grfFlags));
Result := IsValidDC(DC);
if Result
then with TDeviceContext(DC) do
begin
R := ARect;
DCOrigin:=GetDCOffset(TDeviceContext(DC));
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(GetGC, GDK_SOLID);
SelectedColors := dcscCustom;
// Draw outer rect
if BOuter then
DrawEdges(R,GetGC,Drawable,OuterTL,OuterBR);
// Draw inner rect
if BInner then
DrawEdges(R,GetGC,Drawable,InnerTL,InnerBR);
// 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) and
not IsNullBrush(TDeviceContext(DC))
then begin
Width := R.Right - R.Left + 1;
Height := R.Bottom - R.Top + 1;
SelectGDKBrushProps(DC);
if (GetBrush^.GDIBrushFill = GDK_SOLID)
and (IsBackgroundColor(TColor(GetBrush^.GDIBrushColor.ColorRef)))
then
StyleFillRectangle(Drawable, GetGC, GetBrush^.GDIBrushColor.ColorRef,
R.Left, R.Top, Width, Height)
else
gdk_draw_rectangle(Drawable, GetGC, 1, R.Left, R.Top, Width, Height);
end;
// adjust rect if needed
if (grfFlags and BF_ADJUST) = BF_ADJUST
then ARect := R;
Result := True;
end;
end;
{------------------------------------------------------------------------------
Method: DrawText
Params: DC, Str, Count, Rect, Flags
Returns: If the string was drawn, or CalcRect run
------------------------------------------------------------------------------}
function TGtkWidgetSet.DrawText(DC: HDC; Str: PChar; Count: Integer;
var Rect: TRect; Flags: Cardinal): Integer;
var
TM : TTextmetric;
theRect : TRect;
Lines : PPChar;
I, NumLines : Longint;
TempDC : HDC;
TempPen : HPEN;
TempBrush : HBRUSH;
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;
Procedure DoCalcRect;
var
AP : TSize;
J, MaxLength,
LineWidth : Integer;
begin
theRect := Rect;
MaxLength := theRect.Right - theRect.Left;
If (Flags and DT_SingleLine) > 0 then begin
// ignore word and line breaks
GetTextExtentPoint(DC, Str, Count, AP);
if (Flags and DT_CalcRect)<>0 then
theRect.Right := theRect.Left + AP.cX
else
theRect.Right := theRect.Left + Min(MaxLength, AP.cX);
theRect.Bottom := theRect.Top + TM.tmHeight;
end
else begin
// consider line breaks
If (Flags and DT_WordBreak) = 0 then begin
// do not break at word boundaries
GetTextExtentPoint(DC, Str, Count, AP);
MaxLength := AP.cX;
end;
Self.WordWrap(DC, Str, MaxLength, Lines, NumLines);
if (Flags and DT_CalcRect)<>0 then begin
LineWidth := 0;
if (Lines <> nil) then begin
LineWidth := 0;
For J := 0 to NumLines - 1 do begin
GetTextExtentPoint(DC, Lines[J], StrLen(Lines[J]), AP);
LineWidth := Max(LineWidth, AP.cX);
end;
end;
LineWidth := Min(MaxLength, LineWidth);
end else begin
LineWidth:=MaxLength;
end;
theRect.Right := theRect.Left + LineWidth;
theRect.Bottom := theRect.Top + NumLines*TM.tmHeight;
if NumLines>1 then
Inc(theRect.Bottom, (NumLines-1)*TM.tmDescent);// space between lines
//debugln('TGtkWidgetSet.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 :
OffsetRect(theRect, (Rect.Right - theRect.Right) div 2, 0);
DT_Right :
OffsetRect(theRect, Rect.Right - theRect.Right, 0);
end;
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, 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;
{Draw line of Text}
TextUtf8Out(DC, LeftPos, TopPos, theLine, lineLength);
end;
Procedure DrawLine(theLine : PChar; LineLength, TopPos : Longint);
var
Points : Array[0..1] of TSize;
LogP : TLogPen;
pIndex : Longint;
AStr : String;
LeftPos : Longint;
begin
AStr := Copy(String(theLine), 1, LineLength);
if (Flags and DT_NoPrefix) <> DT_NoPrefix then begin
pIndex := DeleteAmpersands(aStr);
If Length(aStr) = 0 then
Exit; { String consists of '&' only }
If pIndex > Length(aStr) then
pIndex := -1; { String ended in '&', which was deleted }
end else
pIndex := -1;
if TempBrush = HBRUSH(-1) then
TempBrush := SelectObject(DC, GetStockObject(NULL_BRUSH));
if LeftOffset <> DT_Left then
GetTextExtentPoint(DC, PChar(aStr), Length(aStr), 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;
{Draw line of Text}
TextUtf8Out(DC, LeftPos, TopPos, PChar(aStr), Length(aStr));
{Draw Prefix}
if pIndex > 0 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, PChar(aStr), pIndex - 1, Points[0]);
Points[0].cX := LeftPos + Points[0].cX;
Points[0].cY := TopPos + tm.tmHeight - TM.tmDescent + 1;
GetTextExtentPoint(DC, @aStr[pIndex], 1, 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;
Assert(False, Format('trace:> [TGtkWidgetSet.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]));
Result := Longint(IsValidDC(DC));
if Boolean(Result)
then with TDeviceContext(DC) do
begin
Result := 0;
Lines := nil;
NumLines := 0;
TempDC := HDC(-1);
TempPen := HPEN(-1);
TempBrush := HBRUSH(-1);
try
if (Flags and (DT_SingleLine+DT_CalcRect+Dt_NoPrefix+DT_NOClip))
=(DT_SingleLine+Dt_NoPrefix+Dt_NoClip)
then begin
//DebugLn(['TGtkWidgetSet.DrawText Calc single line']);
CopyRect(theRect, Rect);
DrawLineRaw(Str, Count, Rect.Top);
exit;
end;
Count := Min(StrLen(Str), Count);
GetTextMetrics(DC, TM);
DoCalcRect;
if (Flags and DT_CalcRect) = DT_CalcRect then begin
//DebugLn(['TGtkWidgetSet.DrawText Complex Calc']);
CopyRect(Rect, theRect);
Result := 1;
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(['TGtkWidgetSet.DrawText Draw single line']);
DrawLine(Str, Count, theRect.Top);
Result := 1;
end
else If (Lines <> nil) and (NumLines <> 0) then begin
//DebugLn(['TGtkWidgetSet.DrawText Draw multiline']);
for I := 0 to NumLines - 1 do begin
if I>0 then
Inc(theRect.Top, TM.tmDescent);// space between lines
if (((Flags and DT_EditControl) = DT_EditControl) and
(tm.tmHeight > (theRect.Bottom - theRect.Top))) or
(theRect.Top > theRect.Bottom)
then
break;
if Lines[I] <> nil then
DrawLine(Lines[I], StrLen(Lines[I]), theRect.Top);
Inc(theRect.Top, TM.tmHeight);
end;
Result := 1;
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;
Assert(False, Format('trace:> [TGtkWidgetSet.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]));
end;
{------------------------------------------------------------------------------
Function: EnableScrollBar
Params: Wnd, wSBflags, wArrows
Returns: Nothing
------------------------------------------------------------------------------}
function TGtkWidgetSet.EnableScrollBar(Wnd: HWND; wSBflags, wArrows: Cardinal): Boolean;
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.EnableScrollBar]');
//TODO: Implement this;
Result := False;
end;
{------------------------------------------------------------------------------
Function: EnableWindow
Params: hWnd:
bEnable:
Returns:
------------------------------------------------------------------------------}
function TGtkWidgetSet.EnableWindow(hWnd: HWND; bEnable: Boolean): Boolean;
begin
Assert(False, Format('Trace: [TGtkWidgetSet.EnableWindow] hWnd: 0x%x, Enable: %s', [hwnd, BOOL_TEXT[bEnable]]));
if hWnd <> 0 then
gtk_widget_set_sensitive(pgtkwidget(hWnd), bEnable);
Result:=true;
end;
{------------------------------------------------------------------------------
Function: EndPaint
Params:
Returns:
------------------------------------------------------------------------------}
function TGtkWidgetSet.EndPaint(Handle: hwnd; var PS: TPaintStruct): Integer;
{$IFDEF Gtk1}
var
Widget: PGtkWidget;
IsDoubleBuffer: Boolean;
DCDrawable: PGdkDrawable;
Width, Height: integer;
DevContext: TDeviceContext;
CaretWasVisible: Boolean;
MainWidget: PGtkWidget;
//LCLObject: TObject;
//x, y: integer;
{$ENDIF}
begin
Result:=1;
if PS.HDC <> 0 then begin
{$IFDEF Gtk1}
Widget:=PGtkWidget(Handle);
DevContext:=TDeviceContext(PS.HDC);
if Widget<>DevContext.DCWidget then
RaiseGDBException('');
DCDrawable:=DevContext.Drawable;
IsDoubleBuffer:=dcfDoubleBuffer in DevContext.DCFlags;
if IsDoubleBuffer then begin
// copy
gdk_window_get_size(DCDrawable,@Width,@Height);
{$IFDEF VerboseDoubleBuffer}
DebugLn('TGtkWidgetSet.EndPaint Copying from buffer to window: ',Width,' ',Height);
{$ENDIF}
gdk_gc_set_clip_region(DevContext.GetGC, nil);
gdk_gc_set_clip_rectangle(DevContext.GetGC, nil);
// hide caret
HideCaretOfWidgetGroup(Widget,MainWidget,CaretWasVisible);
// draw
gdk_window_copy_area(Widget^.Window, DevContext.GetGC, 0,0,
DCDrawable, 0, 0, Width, Height);
{LCLObject:=GetParentLCLObject(Widget);
if (LCLObject is TPanel)
and (csDesigning in TPanel(LCLObject).ComponentState) then begin
gdk_window_get_origin(Widget^.Window,@x,@y);
DebugLn('TGtkWidgetSet.EndPaint ',TPanel(LCLObject).Name,':',TPanel(LCLObject).ClassName,
' Widget=',GetWidgetClassName(Widget),
' Origin=',x,',',y,
' ',Widget^.allocation.x,',',Widget^.allocation.y);
end;}
// restore caret
if CaretWasVisible then
GTKAPIWidget_ShowCaret(PGTKAPIWidget(MainWidget));
end;
{$ENDIF}
ReleaseDC(Handle, PS.HDC);
end;
end;
{.$define VerboseEnumFonts}
{$note: compare TGtkWidgetSet.EnumFontFamilies with gtkproc.FillScreenFonts}
function TGtkWidgetSet.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}
{$warning implement getting XFonts for this OS}
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 TGtkWidgetSet.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) 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}
{$warning implement getting XFonts for this OS}
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;
{------------------------------------------------------------------------------
Method: Ellipse
Params: X1, Y1, X2, Y2
Returns: Nothing
Use Ellipse to draw a filled circle or ellipse.
------------------------------------------------------------------------------}
function TGtkWidgetSet.Ellipse(DC: HDC;
x1,y1,x2,y2: Integer): Boolean;
var
x,y,width,height: integer;
DCOrigin: TPoint;
begin
Result := IsValidDC(DC);
if Result
then with TDeviceContext(DC) do
begin
if x1<x2 then begin
x:=x1;
width:=x2-x1;
end else begin
x:=x2;
width:=x1-x2;
end;
if y1<y2 then begin
y:=y1;
height:=y2-y1;
end else begin
y:=y2;
height:=y1-y2;
end;
// first draw interior in brush color
DCOrigin:=GetDCOffset(TDeviceContext(DC));
{$IFDEF DebugGDKTraps}
BeginGDKErrorTrap;
{$ENDIF}
If not IsNullBrush(TDeviceContext(DC)) then begin
SelectGDKBrushProps(DC);
gdk_draw_arc(Drawable, GetGC, 1, x+DCOrigin.X, y+DCOrigin.Y, Width, Height,
0, 360 shl 6);
end;
// Draw outline
SelectGDKPenProps(DC);
If (dcfPenSelected in DCFlags) then begin
Result := True;
if not IsNullPen(TDeviceContext(DC)) then begin
gdk_draw_arc(Drawable, GetGC, 0, x+DCOrigin.X, y+DCOrigin.Y, Width, Height,
0, 360 shl 6);
end;
end else
Result := False;
{$IFDEF DebugGDKTraps}
EndGDKErrorTrap;
{$ENDIF}
end;
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 TGtkWidgetSet.ExcludeClipRect(dc: hdc;
Left, Top, Right, Bottom : Integer) : Integer;
begin
Result := Inherited ExcludeClipRect(DC, Left, Top, Right, Bottom);
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 TGtkWidgetSet.ExtSelectClipRGN(dc: hdc; rgn : hrgn;
Mode : Longint) : Integer;
var
Clip,
Tmp : hRGN;
X, Y : Longint;
DCOrigin: TPoint;
begin
Result := SIMPLEREGION;
If not IsValidDC(DC) then
Result := ERROR
else with TDeviceContext(DC) do
begin
//DebugLn('TGtkWidgetSet.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(PGdiObject(RGN)^.GDIRegionObject);
If Result <> ERROR then
Result := SelectClipRGN(DC, RGN);
end;
RGN_OR,
RGN_XOR,
RGN_AND,
RGN_DIFF:
begin
// get existing clip
GDK_Window_Get_Size(Drawable, @X, @Y);
DCOrigin:=GetDCOffset(TDeviceContext(DC));
Clip := CreateRectRGN(-DCOrigin.X,-DCOrigin.Y,X-DCOrigin.X,Y-DCOrigin.Y);
// create target clip
Tmp := CreateEmptyRegion;
// combine
Result := CombineRGN(Tmp, Clip, RGN, Mode);
// commit
//DebugLn('TGtkWidgetSet.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
------------------------------------------------------------------------------}
function TGtkWidgetSet.ExtTextOut(DC: HDC; X, Y: Integer; Options: Longint;
Rect: PRect; Str: PChar; Count: Longint; Dx: PInteger): Boolean;
{$Ifdef GTK2}
begin
DebugLn('ToDo: TGtkWidgetSet.ExtTextOut');
Result:=false;
end;
{$Else}
var
LineStart, LineEnd, StrEnd: PChar;
Left, Top, Width, Height: Integer;
TopY, LineLen, LineHeight : Integer;
TxtPt : TPoint;
UseFont : PGDKFont;
DCOrigin: TPoint;
UnderLine: boolean;
buffer: PGdkDrawable;
buffered: Boolean;
procedure DrawTextLine;
var
UnderLineLen, Y: integer;
CurDistX: PInteger;
CharsWritten, CurX, i: integer;
LinePos: PChar;
CharLen: LongInt;
begin
{$IFDEF DebugGDKTraps}
BeginGDKErrorTrap;
{$ENDIF}
with TDeviceContext(DC) do begin
if (Dx=nil) then begin
// no dist array -> write as one block
gdk_draw_text(Buffer, UseFont, GetGC, TxtPt.X, TxtPt.Y,
LineStart, LineLen);
end else begin
// dist array -> write each char separately
CharsWritten:=integer(LineStart-Str);
if DCTextMetric.IsDoubleByteChar then begin
CharLen:=2;
CharsWritten:=CharsWritten div 2;
end else
CharLen:=1;
CurDistX:=Dx+CharsWritten*SizeOf(Integer);
CurX:=TxtPt.X;
LinePos:=LineStart;
//debugln('TGtkWidgetSet.ExtTextOut.DrawTextLine ',dbgs(dx),' DCTextMetric.IsDoubleByteChar=',dbgs(DCTextMetric.IsDoubleByteChar));
i:=1;
while (i<=LineLen) do begin
//debugln('TGtkWidgetSet.ExtTextOut.DrawTextLine ',dbgs(CharLen),' ',dbgs(ord(LinePos^)));
gdk_draw_text(Buffer, UseFont, GetGC, CurX, TxtPt.Y, LinePos, CharLen);
inc(LinePos,CharLen);
inc(CurX,CurDistX^);
inc(CurDistX);
inc(i,CharLen);
end;
end;
if UnderLine then begin
if Rect<>nil then
UnderLineLen := Rect^.Right-Rect^.Left
else
UnderLineLen := gdk_text_width(UseFont,LineStart, LineLen);
Y := TxtPt.Y + 1;
gdk_draw_line(Buffer, GetGC, TxtPt.X, Y, TxtPt.X+UnderLineLen, Y);
end;
end;
{$IFDEF DebugGDKTraps}
EndGDKErrorTrap;
{$ENDIF}
end;
begin
Assert(False, Format('trace:> [TGtkWidgetSet.ExtTextOut] DC:0x%x, X:%d, Y:%d, Options:%d, Str:''%s'', Count: %d', [DC, X, Y, Options, Str, Count]));
Result := IsValidDC(DC);
if Result
then with TDeviceContext(DC) do
begin
if ((Options and (ETO_OPAQUE+ETO_CLIPPED)) <> 0)
and (Rect=nil) then begin
DebugLn('WARNING: [TGtkWidgetSet.ExtTextOut] Rect=nil');
Result := False;
exit;
end;
// TODO: implement other parameters.
// to reduce flickering calculate first and then paint
DCOrigin := GetDCOffset(TDeviceContext(DC));
buffered := false;
UseFont := nil;
buffer := Drawable;
UnderLine:=false;
if (Str<>nil) and (Count>0) then begin
Usefont:=GetGtkFont(TDeviceContext(DC));
if (CurrentFont <> nil) and (CurrentFont^.GDIFontObject <> nil) then
UnderLine:= (CurrentFont^.LogFont.lfUnderline<>0);
if UseFont <> nil then begin
if (Options and ETO_CLIPPED) <> 0 then
begin
X := Rect^.Left;
Y := Rect^.Top;
IntersectClipRect(DC, Rect^.Left, Rect^.Top,
Rect^.Right, Rect^.Bottom);
end;
end else begin
DebugLn('WARNING: [TGtkWidgetSet.ExtTextOut] Missing Font');
Result := False;
exit;
end;
end;
if ((Options and ETO_OPAQUE) <> 0) then
begin
Width := Rect^.Right - Rect^.Left;
Height := Rect^.Bottom - Rect^.Top;
SelectedColors := dcscCustom;
EnsureGCColor(DC, dccCurrentBackColor, True, False);
if buffered then begin
Left:=0;
Top:=0;
end else begin
Left:=Rect^.Left+DCOrigin.X;
Top:=Rect^.Top+DCOrigin.Y;
end;
{$IFDEF DebugGDKTraps}
BeginGDKErrorTrap;
{$ENDIF}
if IsBackgroundColor(TColor(CurrentBackColor.ColorRef)) then
StyleFillRectangle(buffer, GetGC, CurrentBackColor.ColorRef,
Left, Top, Width, Height)
else
gdk_draw_rectangle(buffer, GetGC, 1, Left, Top, Width, Height);
{$IFDEF DebugGDKTraps}
EndGDKErrorTrap;
{$ENDIF}
end;
if UseFont<>nil then begin
LineLen := FindChar(#10,Str,Count);
UpdateDCTextMetric(TDeviceContext(DC));
LineHeight:=GetTextHeight(DCTextMetric);
if Buffered then begin
TxtPt.X := 0;
TxtPt.Y := LineHeight;
end
else begin
TopY := Y;
TxtPt.X := X + DCOrigin.X;
TxtPt.Y := TopY + LineHeight + DCOrigin.Y;
end;
SelectGDKTextProps(DC);
LineStart:=Str;
if LineLen < 0 then begin
LineLen:=Count;
if Count> 0 then DrawTextLine;
end else
Begin //write multiple lines
StrEnd:=Str+Count;
while LineStart < StrEnd do begin
LineEnd:=LineStart+LineLen;
if LineLen>0 then DrawTextLine;
inc(TxtPt.Y,LineHeight);
LineStart:=LineEnd+1; // skip #10
if (LineStart<StrEnd) and (LineStart^=#13) then
inc(LineStart); // skip #10
Count:=StrEnd-LineStart;
LineLen:=FindChar(#10,LineStart,Count);
if LineLen<0 then
LineLen:=Count;
end;
end;
end;
end;
Assert(False, Format('trace:< [TGtkWidgetSet.ExtTextOut] DC:0x%x, X:%d, Y:%d, Options:%d, Str:''%s'', Count: %d', [DC, X, Y, Options, Str, Count]));
end;
{$EndIf}
{------------------------------------------------------------------------------
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 TGtkWidgetSet.FillRect(DC: HDC; const Rect: TRect; Brush: HBRUSH): Boolean;
var
Width, Height: Integer;
OldCurrentBrush: PGdiObject;
DCOrigin: TPoint;
BrushChanged: Boolean;
begin
BrushChanged :=false;
Result := IsValidDC(DC) and IsValidGDIObject(Brush);
if not Result then exit;
with TDeviceContext(DC) do
begin
if not PGdiObject(Brush)^.IsNullBrush then begin
Width := Rect.Right - Rect.Left;
Height := Rect.Bottom - Rect.Top;
// Temporary hold the old brush to
// replace it with the given brush
OldCurrentBrush := GetBrush;
if not CompareGDIBrushes(PGdiObject(Brush),OldCurrentBrush) then begin
BrushChanged:=true;
CurrentBrush := PGdiObject(Brush);
SelectedColors:=dcscCustom;
end;
//DebugLn('TGtkWidgetSet.FillRect Color=',DbgS(CurrentBrush^.GDIBrushColor.ColorRef));
SelectGDKBrushProps(DC);
DCOrigin:=GetDCOffset(TDeviceContext(DC));
if (CurrentBrush^.GDIBrushFill = GDK_SOLID)
and (IsBackgroundColor(TColor(CurrentBrush^.GDIBrushColor.ColorRef)))
then begin
StyleFillRectangle(drawable, GetGC,
CurrentBrush^.GDIBrushColor.ColorRef,
Rect.Left+DCOrigin.X, Rect.Top+DCOrigin.Y,
Width, Height)
end else begin
gdk_draw_rectangle(Drawable, GetGC, 1,
Rect.Left+DCOrigin.X, Rect.Top+DCOrigin.Y,
Width, Height);
end;
// Restore current brush
if BrushChanged then begin
SelectedColors:=dcscCustom;
CurrentBrush := OldCurrentBrush;
end;
end;
Result := True;
end;
Assert(False, Format('trace:< [TGtkWidgetSet.FillRect] DC:0x%x; Rect: ((%d,%d)(%d,%d)); brush: %x', [Integer(DC), Rect.left, rect.top, rect.right, rect.bottom, brush]));
end;
{------------------------------------------------------------------------------
function Frame(DC: HDC; const ARect: TRect): Integer; override;
Draws the border of a rectangle.
------------------------------------------------------------------------------}
function TGtkWidgetSet.Frame(DC: HDC; const ARect: TRect): Integer;
var
DCOrigin: TPoint;
begin
Result:=0;
if IsValidDC(DC) then begin
with TDeviceContext(DC) do
begin
// Draw outline
SelectGDKPenProps(DC);
If (dcfPenSelected in DCFlags) then begin
Result := 1;
if not IsNullPen(TDeviceContext(DC)) then begin
DCOrigin:=GetDCOffset(TDeviceContext(DC));
gdk_draw_rectangle(Drawable, GetGC, 0,
ARect.Left+DCOrigin.X, ARect.Top+DCOrigin.Y,
ARect.Right-ARect.Left, ARect.Bottom-ARect.Top);
end;
end;
end;
end;
end;
{------------------------------------------------------------------------------
Function: Frame3d
Params: -
Returns: Nothing
Draws a 3d border in GTK native style.
------------------------------------------------------------------------------}
function TGtkWidgetSet.Frame3d(DC : HDC; var ARect : TRect;
const FrameWidth : integer; const Style : TBevelCut) : boolean;
const GTKThinShadowType: array[TBevelCut] of integer =
(GTK_SHADOW_NONE, GTK_SHADOW_IN, GTK_SHADOW_OUT, GTK_SHADOW_NONE);
const GTKStrongShadowType: array[TBevelCut] of integer =
(GTK_SHADOW_NONE, GTK_SHADOW_ETCHED_IN, GTK_SHADOW_ETCHED_OUT, GTK_SHADOW_NONE);
var
Widget, ClientWidget: PGtkWidget;
i : integer;
DCOrigin: TPoint;
TheStyle: PGtkStyle;
Area: TGdkRectangle;
ShadowType: Integer;
AWindow: PGdkWindow;
begin
Result := IsValidDC(DC);
if not Result then exit;
if FrameWidth=0 then exit;
TheStyle:=GetStyle(lgsButton);
//DebugLn('TGtkWidgetSet.Frame3d A ',DbgS(TheStyle));
if TheStyle=nil then exit;
with TDeviceContext(DC) do
begin
Widget:=TDeviceContext(DC).DCWidget;
ClientWidget:=Widget;
if Widget<>nil then begin
ClientWidget:=GetFixedWidget(Widget);
if ClientWidget=nil then
ClientWidget:=Widget;
end;
AWindow:=Drawable;
DCOrigin:=GetDCOffset(TDeviceContext(DC));
Area.X:=ARect.Left+DCOrigin.X;
Area.Y:=ARect.Top+DCOrigin.Y;
Area.Width:=ARect.Right-ARect.Left;
Area.Height:=ARect.Bottom-ARect.Top;
if FrameWidth=1 then
ShadowType:=GTKThinShadowType[Style]
else
ShadowType:=GTKStrongShadowType[Style];
//DebugLn('ShadowType ',ShadowType,
//' dark_gc=',DbgS(TheStyle^.dark_gc[GTK_STATE_NORMAL]),
//' light_gc=',DbgS(TheStyle^.light_gc[GTK_STATE_NORMAL]),
//'');
for i:= 1 to FrameWidth do begin
gtk_paint_shadow(theStyle,
AWindow, GTK_STATE_NORMAL,
ShadowType,
@Area,
ClientWidget,
'button',
ARect.Left+DCOrigin.X, ARect.Top+DCOrigin.Y,
ARect.Right-ARect.Left, ARect.Bottom-ARect.Top);
// inflate the rectangle (! ARect will be returned to the user with this)
InflateRect(ARect, -1, -1);
end;
end;
end;
{------------------------------------------------------------------------------
function TGtkWidgetSet.FrameRect(DC: HDC; const ARect: TRect;
hBr: HBRUSH): Integer;
------------------------------------------------------------------------------}
function TGtkWidgetSet.FrameRect(DC: HDC; const ARect: TRect;
hBr: HBRUSH): Integer;
var
DCOrigin: TPoint;
begin
Result:=0;
if IsValidDC(DC) and IsValidGDIObject(hBr) then begin
// Draw outline
Result := 1;
if (not PGdiObject(hBr)^.IsNullBrush) then begin
with TDeviceContext(DC) do
begin
SelectedColors:=dcscCustom;
EnsureGCColor(DC, dccGDIBrushColor, True, False);//Brush Color
DCOrigin:=GetDCOffset(TDeviceContext(DC));
gdk_draw_rectangle(Drawable, GetGC, 0,
ARect.Left+DCOrigin.X, ARect.Top+DCOrigin.Y,
ARect.Right-ARect.Left, ARect.Bottom-ARect.Top);
end;
end;
end;
end;
{------------------------------------------------------------------------------
Function: GetActiveWindow
Params: none
Returns:
------------------------------------------------------------------------------}
Function TGtkWidgetSet.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 gtk_is_window(Window)
then begin
Widget := Window^.focus_widget;
if Widget=nil then Widget:=PGtkWidget(Window);
//DebugLn('TGtkWidgetSet.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(GetMainWidget(PGtkWidget(Window)));
//DebugLn('TGtkWidgetSet.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: GetDIBits
Params:
Returns:
------------------------------------------------------------------------------}
function TGtkWidgetSet.GetDIBits(DC: HDC; Bitmap: HBitmap; StartScan, NumScans: UINT;
Bits: Pointer; var BitInfo: BitmapInfo; Usage: UINT): Integer;
begin
Assert(False, 'trace:[TGtkWidgetSet.GetDIBits]');
Result := 0;
if IsValidGDIObject(Bitmap)
then begin
case PGDIObject(Bitmap)^.GDIType of
gdiBitmap:
Result := InternalGetDIBits(DC, Bitmap, StartScan, NumScans, -1, Bits,
BitInfo, Usage, True);
else
DebugLn('WARNING: [TGtkWidgetSet.GetDIBits] not a Bitmap!');
end;
end
else
DebugLn('WARNING: [TGtkWidgetSet.GetDIBits] invalid Bitmap!');
end;
{------------------------------------------------------------------------------
Function: GetBitmapBits
Params:
Returns:
------------------------------------------------------------------------------}
function TGtkWidgetSet.GetBitmapBits(Bitmap: HBITMAP; Count: Longint; Bits: Pointer): Longint;
var
BitInfo : tagBitmapInfo;
begin
Assert(False, 'trace:[TGtkWidgetSet.GetBitmapBits]');
Result := 0;
if IsValidGDIObject(Bitmap)
then begin
case PGDIObject(Bitmap)^.GDIType of
gdiBitmap:
Result := InternalGetDIBits(0, Bitmap, 0, 0, Count, Bits, BitInfo, 0, False);
else
DebugLn('WARNING: [TGtkWidgetSet.GetBitmapBits] not a Bitmap!');
end;
end
else
DebugLn('WARNING: [TGtkWidgetSet.GetBitmapBits] invalid Bitmap!');
end;
{------------------------------------------------------------------------------
Function: GetBitmapRawImageDescription
Params: Bitmap: HBITMAP;
Desc: PRawImageDescription
Returns: boolean;
------------------------------------------------------------------------------}
function TGtkWidgetSet.GetBitmapRawImageDescription(Bitmap: HBITMAP;
Desc: PRawImageDescription): boolean;
var
GDIObject: PGDIObject;
GdkPixmap: PGdkPixmap;
begin
Result:=false;
if not IsValidGDIObject(Bitmap) then begin
DebugLn('WARNING: [TGtkWidgetSet.GetBitmapRawImageDescription] invalid Bitmap!');
exit;
end;
GDIObject:=PGDIObject(Bitmap);
case GDIObject^.GDIBitmapType of
gbBitmap: GdkPixmap:=PGdkPixmap(PGdiObject(Bitmap)^.GDIBitmapObject);
gbPixmap: GdkPixmap:=PGdkPixmap(PGdiObject(Bitmap)^.GDIPixmapObject);
else
GdkPixmap:=nil;
DebugLn('WARNING: [TGtkWidgetSet.GetBitmapRawImageDescription] GDI_RGBImage not implemented');
exit;
end;
Result:=GetWindowRawImageDescription(PGdkWindow(GdkPixmap),Desc);
end;
{------------------------------------------------------------------------------
Function: GetCapture
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtkWidgetSet.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(Widget);
end;
{------------------------------------------------------------------------------
Function: GetCaretPos
Params: lpPoint: The caretposition
Returns: True if succesful
------------------------------------------------------------------------------}
function TGtkWidgetSet.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 TGtkWidgetSet.GetCaretRespondToFocus(handle: HWND;
var ShowHideOnFocus: boolean): Boolean;
------------------------------------------------------------------------------}
function TGtkWidgetSet.GetCaretRespondToFocus(handle: HWND;
var ShowHideOnFocus: boolean): Boolean;
begin
if handle<>0 then begin
if gtk_type_is_a(gtk_object_type(PGTKObject(handle)), GTKAPIWidget_GetType)
then begin
GTKAPIWidget_GetCaretRespondToFocus(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 TGtkWidgetSet.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 TGtkWidgetSet.GetClientBounds(handle : HWND; var ARect : TRect) : Boolean;
var
Widget, ClientWidget: PGtkWidget;
{$IFDEF Gtk1}
MainOrigin: TPoint;
{$ELSE}
CurGDKWindow: PGdkWindow;
{$ENDIF}
ClientOrigin: TPoint;
ClientWindow, MainWindow: PGdkWindow;
begin
Result := False;
if Handle = 0 then Exit;
Widget := 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
{$IFDEF Gtk1}
if MainWindow<>nil then begin
gdk_window_get_origin(MainWindow,@MainOrigin.X,@MainOrigin.Y);
end else begin
// widget not realized
MainOrigin.X:=0;
MainOrigin.Y:=0;
end;
// check if the main gdkwindow is the clientwindow of the parent
if (Widget^.Parent<>nil)
and (MainWindow=gtk_widget_get_parent_window(Widget)) then begin
// the widget is using its parent window
// -> adjust the coordinates
inc(MainOrigin.X,Widget^.Allocation.X);
inc(MainOrigin.Y,Widget^.Allocation.Y);
end;
if ClientWindow<>nil then begin
gdk_window_get_origin(ClientWindow,@ClientOrigin.X,@ClientOrigin.Y);
end else begin
// client widget not realized
ClientOrigin:=MainOrigin;
end;
ARect.Left:=ClientOrigin.X-MainOrigin.X;
ARect.Top:=ClientOrigin.Y-MainOrigin.Y;
{$ELSE}
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
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;
{$ENDIF}
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 TGtkWidgetSet.GetClientRect(handle : HWND; var ARect : TRect) : Boolean;
var
Widget, ClientWidget: PGtkWidget;
{$IFDEF Gtk2}
procedure GetNoteBookClientRect(NBWidget: PGtkNotebook);
var
PageIndex: LongInt;
PageWidget: PGtkWidget;
FrameBorders: TRect;
aWidth: LongInt;
aHeight: LongInt;
begin
// get current page
PageIndex:=gtk_notebook_get_current_page(NBWidget);
if PageIndex>=0 then
PageWidget:=gtk_notebook_get_nth_page(NBWidget,PageIndex)
else
PageWidget:=nil;
if (PageWidget<>nil)
and ((PageWidget^.Allocation.Width>1) or (PageWidget^.Allocation.Height>1))
then begin
// get the size of the current page
ARect.Right:=PageWidget^.Allocation.Width;
ARect.Bottom:=PageWidget^.Allocation.Height;
//DebugLn(['GetNoteBookClientRect using pagewidget: ',GetWidgetDebugReport(Widget),' ARect=',dbgs(aRect)]);
end else begin
// use defaults
FrameBorders:=GetStyleNotebookFrameBorders;
aWidth:=Widget^.allocation.width;
aHeight:=Widget^.allocation.height;
ARect:=Rect(0,0,
Max(0,AWidth-FrameBorders.Left-FrameBorders.Right),
Max(0,aHeight-FrameBorders.Top-FrameBorders.Bottom));
//DebugLn(['GetNoteBookClientRect using defaults: ',GetWidgetDebugReport(Widget),' ARect=',dbgs(aRect)]);
end;
end;
{$ENDIF}
begin
Result := false;
if Handle = 0 then Exit;
ARect.Left := 0;
ARect.Top := 0;
Widget := pgtkwidget(Handle);
ClientWidget := GetFixedWidget(Widget);
if (ClientWidget <> nil) then
Widget := ClientWidget;
if (Widget <> nil) then begin
ARect.Right:=Widget^.Allocation.Width;
ARect.Bottom:=Widget^.Allocation.Height;
end else begin
ARect.Right:=0;
ARect.Bottom:=0;
end;
{$IFDEF Gtk2}
if GtkWidgetIsA(Widget,GTK_TYPE_NOTEBOOK) then
GetNoteBookClientRect(PGtkNoteBook(Widget));
{$ENDIF}
{$IfDef VerboseGetClientRect}
if ClientWidget<>nil then begin
DebugLn('GetClientRect Widget=',DbgS(handle),
' Client=',DbgS(ClientWidget),
' WindowSize=',dbgs(ARect.Right),',',dbgs(ARect.Bottom),
' Allocation=',dbgs(ClientWidget^.Allocation.Width),',',dbgs(ClientWidget^.Allocation.Height)
);
end else begin
DebugLn('GetClientRect Widget=',DbgS(handle),
' Client=',DbgS(ClientWidget),
' WindowSize=',dbgs(ARect.Right),',',dbgs(ARect.Bottom),
' Allocation=',dbgs(Widget^.Allocation.Width),',',dbgs(Widget^.Allocation.Height)
);
end;
if GetLCLObject(Widget) is TCustomPage then begin
DebugLn(['TGtkWidgetSet.GetClientRect Rect=',dbgs(aRect),' ',GetWidgetDebugReport(Widget)]);
end;
{$EndIf}
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 TGtkWidgetSet.GetClipBox(DC : hDC; lpRect : PRect) : Longint;
var
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
Result := ERROR;
if Result <> ERROR
then with TDeviceContext(DC) do
begin
DCOrigin:=GetDCOffset(TDeviceContext(DC));
If ClipRegion=nil then begin
{$IFDEF DebugGDKTraps}
BeginGDKErrorTrap;
{$ENDIF}
gdk_window_get_size(Drawable, @X, @Y);
{$IFDEF DebugGDKTraps}
EndGDKErrorTrap;
{$ENDIF}
lpRect^ := Rect(-DCOrigin.X, -DCOrigin.Y, X-DCOrigin.X, Y-DCOrigin.Y);
Result := SIMPLEREGION;
end
else begin
Result := RegionType(ClipRegion^.GDIRegionObject);
gdk_region_get_clipbox(ClipRegion^.GDIRegionObject,
@CRect);
lpRect^.Left := CRect.X-DCOrigin.X;
lpRect^.Top := CRect.Y-DCOrigin.Y;
lpRect^.Right := lpRect^.Left + CRect.Width;
lpRect^.Bottom := lpRect^.Top + CRect.Height;
end;
end;
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 TGtkWidgetSet.GetRgnBox(RGN : HRGN; lpRect : PRect) : Longint;
var
CRect : 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(PGDIObject(RGN)^.GDIRegionObject);
If lpRect <> nil then begin
gdk_region_get_clipbox(PGDIObject(RGN)^.GDIRegionObject,
@CRect);
With lpRect^,CRect do begin
Left := X;
Top := Y;
Right := X + Width;
Bottom := Y + Height;
end;
end;
end;
end;
Function TGtkWidgetSet.GetROP2(DC: HDC): Integer;
begin
if not IsValidDC(DC) then begin
Assert(False, 'Trace:[TGtkWidgetSet.GetROP2] Invalid GC');
result := 0
end else
with TDeviceContext(DC) do begin
Result := GdkFunctionToROP2Mode(GCValues.{$ifdef gtk1}thefunction{$else}_function{$endif} )
end;
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 TGtkWidgetSet.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: [TGtkWidgetSet.GetClipRGN] Invalid HRGN');
end
else if (TDeviceContext(DC).ClipRegion<>nil)
and (not IsValidGDIObject(HGDIOBJ(TDeviceContext(DC).ClipRegion))) then
Result := ERROR
else with TDeviceContext(DC) do
begin
CurRegionObject:=nil;
if ClipRegion<>nil then
CurRegionObject:=ClipRegion^.GDIRegionObject;
ARect:=Rect(0,0,0,0);
if CurRegionObject<>nil 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:=GetDCOffset(TDeviceContext(DC));
//debugln('TGtkWidgetSet.GetClipRGN DCOrigin=',dbgs(DCOrigin),' CurRegionObject=',dbgs(CurRegionObject),' ',dbgs(ARect));
gdk_region_offset(ClipRegionWithDCOffset,-DCOrigin.x,-DCOrigin.Y);
end else begin
// create a default clipregion
GetClipBox(DC,@ARect);
ClipRegionWithDCOffset:=CreateRectGDKRegion(ARect);
end;
// free the old region in RGN
if PGdiObject(RGN)^.GDIRegionObject<>nil then
gdk_region_destroy(PGdiObject(RGN)^.GDIRegionObject);
// set the new region in RGN
PGdiObject(RGN)^.GDIRegionObject := ClipRegionWithDCOffset;
Result := RegionType(ClipRegionWithDCOffset);
//DebugLn('TGtkWidgetSet.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 TGtkWidgetSet.GetCmdLineParamDescForInterface: string;
function b(const s: string): string;
begin
Result:=BreakString(s,75,22)+LineEnding+LineEnding;
end;
begin
Result:=
b(rsgtkOptionNoTransient)
+b(rsgtkOptionModule)
+b(rsgOptionFatalWarnings)
+b(rsgtkOptionDebug)
+b(rsgtkOptionNoDebug)
+b(rsgdkOptionDebug)
+b(rsgdkOptionNoDebug)
+b(rsgtkOptionDisplay)
+b(rsgtkOptionSync)
+b(rsgtkOptionNoXshm)
+b(rsgtkOptionName)
+b(rsgtkOptionClass);
end;
{------------------------------------------------------------------------------
Function: GetCursorPos
Params: lpPoint: The cursorposition
Returns: True if succesful
------------------------------------------------------------------------------}
function TGtkWidgetSet.GetCursorPos(var lpPoint: TPoint): Boolean;
{$IFDEF HasX}
var
dpy: PDisplay;
root, child: twindow;
winx, winy: Integer;
xmask: Cardinal;
begin
Result := False;
if (not MousePositionValid) or (Abs(MousePositionTime-Now)>1/864000) then
begin
// querying the X cursor is expensive (especially on network connections)
// => use a lazy query
{$IFDEF DebugGDKTraps}
BeginGDKErrorTrap;
try
{$ENDIF}
dpy := gdk_display;
XQueryPointer(dpy, RootWindow(dpy, DefaultScreen(dpy)), @root, @child,
@MousePosition.X,@MousePosition.Y,@winx,@winy,@xmask);
Result := True;
{$IFDEF DebugGDKTraps}
finally
EndGDKErrorTrap;
end;
{$ENDIF}
MousePositionTime:=Now;
MousePositionValid:=true;
end;
lpPoint:=MousePosition;
end;
{$ELSE}
begin
// TODO: GTK1-win32 GetCursorPos
Result := False;
end;
{$ENDIF HasX}
{------------------------------------------------------------------------------
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 TGtkWidgetSet.GetDC(hWnd: HWND): HDC;
begin
Result:=CreateDCForWidget(PGtkWidget(hWnd),nil,false);
end;
{------------------------------------------------------------------------------
function TGtkWidgetSet.GetDeviceCaps(DC: HDC; Index: Integer): Integer;
------------------------------------------------------------------------------}
function TGtkWidgetSet.GetDeviceCaps(DC: HDC; Index: Integer): Integer;
var
Visual: PGdkVisual;
function GetVisual: boolean;
begin
Visual:=nil;
with TDeviceContext(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 TDeviceContext(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
//gdk_window_get_geometry(Drawable, nil, nil, nil, nil, @Result);
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 := RoundToInt(gdk_screen_width / (GetScreenWidthMM / 25.4));
LOGPIXELSY : { Logical pixels per inch in Y }
Result := RoundToInt(gdk_screen_height / (GetScreenHeightMM / 25.4));
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('TGtkWidgetSet.GetDeviceCaps not supported: Type=',dbgs(Index));
end;
end;
{------------------------------------------------------------------------------
function GetDeviceRawImageDescription(DC: HDC;
Desc: PRawImageDescription): boolean;
Retrieves the information about the structure of the supported image data.
------------------------------------------------------------------------------}
function TGtkWidgetSet.GetDeviceRawImageDescription(DC: HDC;
Desc: PRawImageDescription): boolean;
var
GDKWindow: PGdkWindow;
begin
GdkWindow:=nil;
If IsValidDC(DC) then
GDKWindow:=PGdkWindow(TDeviceContext(DC).Drawable);
Result:=GetWindowRawImageDescription(GDKWindow,Desc);
end;
{------------------------------------------------------------------------------
function GetDeviceSize(DC: HDC; var p: TPoint): boolean;
Retrieves the width and height of the device context in pixels.
------------------------------------------------------------------------------}
function TGtkWidgetSet.GetDeviceSize(DC: HDC; var p: TPoint): boolean;
begin
Result := false;
P := Point(0,0);
If IsValidDC(DC) then
with TDeviceContext(DC) do begin
if DCWidget<>nil then begin
if Drawable<>nil then begin
gdk_window_get_size(PGdkWindow(Drawable), @P.X, @P.Y);
Result := true;
end else begin
{$IFDEF RaiseExceptionOnNilPointers}
RaiseException('TGtkWidgetSet.GetDeviceSize Window=nil');
{$ENDIF}
DebugLn('TGtkWidgetSet.GetDeviceSize:',
' WARNING: DC ',DbgS(DC),' without gdkwindow.',
' Widget=',DbgS(DCWidget));
end;
end else begin
// screen size
p.x:=gdk_screen_width;
p.y:=gdk_screen_height;
end;
end;
end;
{------------------------------------------------------------------------------
function TGtkWidgetSet.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 TGtkWidgetSet.GetDCOriginRelativeToWindow(PaintDC: HDC;
WindowHandle: HWND; var OriginDiff: TPoint): boolean;
procedure InvalidDrawable;
begin
{$IFDEF RaiseExceptionOnNilPointers}
RaiseException('TGtkWidgetSet.GetDCOriginRelativeToWindow Window=nil');
{$ENDIF}
DebugLn('TGtkWidgetSet.GetDCOriginRelativeToWindow:',
' WARNING: PaintDC ',DbgS(PaintDC),' without gdkwindow.',
' Widget=',DbgS(TDeviceContext(PaintDC).DCWidget));
end;
var
DCOrigin: TPoint;
DCScreenOrigin: TPoint;
WindowScreenOrigin: TPoint;
Widget: PGtkWidget;
ScreenDrawable: PGdkDrawable;
begin
Result := false;
OriginDiff := Point(0,0);
If not IsValidDC(PaintDC) then exit;
with TDeviceContext(PaintDC) do begin
DCOrigin:=GetDCOffset(TDeviceContext(PaintDC));
ScreenDrawable:=Drawable;
if (dcfDoubleBuffer in DCFlags) then
ScreenDrawable:=OriginalDrawable;
if ScreenDrawable=nil then
InvalidDrawable;
gdk_window_get_origin(PGdkWindow(Drawable),
@(DCScreenOrigin.X), @(DCScreenOrigin.Y));
inc(DCScreenOrigin.X,DCOrigin.X);
inc(DCScreenOrigin.Y,DCOrigin.Y);
Widget:=GetFixedWidget(PGtkWidget(WindowHandle));
if Widget=nil then Widget:=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;
end;
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 TGtkWidgetSet.GetDesignerDC(WindowHandle: HWND): HDC;
begin
//DebugLn('TGtkWidgetSet.GetDesignerDC A');
Result:=CreateDCForWidget(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 TGtkWidgetSet.GetFocus: HWND;
var
TopList, List: PGList;
Widget: PGTKWidget;
Window: PGTKWindow;
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(['TGtkWidgetSet.GetFocus Window^.focus_widget was laready destroyed:']);
DebugLn(DebugGtkWidgets.GetInfo(Widget,true));
end;
{$ENDIF}
if (Widget <> nil) and gtk_widget_has_focus(Widget)
then begin
Result := HWND(GetMainWidget(Widget));
Break;
end;
end;
end;
list := g_list_next(list);
end;
if TopList <> nil
then g_list_free(TopList);
{$IFDEF DebugGDKTraps}EndGDKErrorTrap;{$ENDIF}
end;
{------------------------------------------------------------------------------
function GetFontLanguageInfo(DC: HDC): DWord; override;
------------------------------------------------------------------------------}
function TGtkWidgetSet.GetFontLanguageInfo(DC: HDC): DWord;
begin
Result := 0;
If IsValidDC(DC) then
with TDeviceContext(DC) do begin
UpdateDCTextMetric(TDeviceContext(DC));
if TDeviceContext(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 TGtkWidgetSet.GetKeyState(nVirtKey: Integer): Smallint;
const
KEYSTATE: array[Boolean] of Smallint = (0, -32768 { $8000});
TOGGLESTATE: array[Boolean] of Smallint = (0, 1);
begin
case nVirtKey of
VK_LSHIFT: nVirtKey := VK_SHIFT;
VK_LCONTROL: nVirtKey := VK_CONTROL;
VK_LMENU: nVirtKey := VK_MENU;
end;
{$IFDEF Use_KeyStateList}
Result := KEYSTATE[FKeyStateList_.IndexOf(Pointer(PtrInt(nVirtKey))) >=0];
{$ELSE}
Implement this
{$ENDIF}
// try extended keys
if Result = 0
then begin
nVirtKey := nVirtKey or KEYMAP_EXTENDED;
{$IFDEF Use_KeyStateList}
Result := KEYSTATE[FKeyStateList_.IndexOf(Pointer(PtrInt(nVirtKey))) >=0];
{$ELSE}
Implement this
{$ENDIF}
end;
{$IFDEF Use_KeyStateList}
// add toggle
if Result <> 0 then
Result := Result or TOGGLESTATE[FKeyStateList_.IndexOf(Pointer(
PtrInt(nVirtKey or KEYMAP_TOGGLE))) >=0];
{$ENDIF}
//Assert(False, Format('Trace:[TGtkWidgetSet.GetKeyState] %d -> 0x%x', [nVirtKey, Result]));
end;
{------------------------------------------------------------------------------
Function: GetObject
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtkWidgetSet.GetObject(GDIObj: HGDIOBJ; BufSize: Integer;
Buf: Pointer): Integer;
var
NumColors : Longint;
BitmapSection : TDIBSECTION;
begin
Assert(False, 'trace:[TGtkWidgetSet.GetObject]');
Result := 0;
if IsValidGDIObject(GDIObj)
then begin
case PGDIObject(GDIObj)^.GDIType of
gdiBitmap:
begin
Assert(False, 'Trace:FINISH: [TGtkWidgetSet.GetObject] gdiBitmap');
if Buf = nil then
Result := SizeOf(TDIBSECTION)
else begin
FillChar(BitmapSection,SizeOf(TDIBSECTION),0);
With PGDIObject(GDIObj)^, BitmapSection,
BitmapSection.dsBm, BitmapSection.dsBmih
do begin
{dsBM - BITMAP}
bmType := $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 <> nil then begin
biBitCount := word(gdk_drawable_get_depth(GDIPixmapObject));
gdk_drawable_get_size(GDIPixmapObject,@biWidth, @biHeight);
end;
{obsolete: gbImage :
If GDI_RGBImageObject <> nil then
With GDI_RGBImageObject^ do begin
biHeight := Height;
biWidth := Width;
biBitCount := Depth;
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;
end;
gdiBrush:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetObject] gdiBrush');
end;
gdiFont:
begin
{$IfDef GTK2}
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetObject] gdiFont(PANGO)');
{$Else}
if Buf = nil then
Result := SizeOf(PGDIObject(GDIObj)^.LogFont)
else begin
if BufSize >= SizeOf(PGDIObject(GDIObj)^.LogFont)
then begin
PLogfont(Buf)^ := PGDIObject(GDIObj)^.LogFont;
Result:= SizeOf(TLogFont);
end else if BufSize>0 then begin
Move(PGDIObject(GDIObj)^.LogFont,Buf^,BufSize);
Result:=BufSize;
end;
end;
{$EndIf}
end;
gdiPen:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetObject] gdiPen');
end;
gdiRegion:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetObject] gdiRegion');
end;
else
DebugLn(Format('WARNING: [TGtkWidgetSet.GetObject] Unknown type %d', [Integer(PGDIObject(GDIObj)^.GDIType)]));
end;
end;
end;
{------------------------------------------------------------------------------
Function: GetParent
Params: Handle:
Returns:
------------------------------------------------------------------------------}
Function TGtkWidgetSet.GetParent(Handle : HWND): HWND;
begin
//DebugLn('TGtkWidgetSet.GetParent ',DbgS(Handle));
Result:=0;
if Handle<>0 then
Result:=HWnd(PGtkWidget(Handle)^.Parent);
end;
{------------------------------------------------------------------------------
Function: GetProp
Params: Handle: Str
Returns: Pointer
------------------------------------------------------------------------------}
Function TGtkWidgetSet.GetProp(Handle : hwnd; Str : PChar): Pointer;
Begin
Result := gtk_object_get_data(pgtkobject(Handle),Str);
end;
{------------------------------------------------------------------------------
function TGtkWidgetSet.GetRawImageFromDevice(SrcDC: HDC; const SrcRect: TRect;
var NewRawImage: TRawImage): boolean;
------------------------------------------------------------------------------}
function TGtkWidgetSet.GetRawImageFromDevice(SrcDC: HDC; const SrcRect: TRect;
var NewRawImage: TRawImage): boolean;
var
DCOrigin: TPoint;
ARect: TRect;
GDKWindow: PGdkWindow;
begin
Result:=false;
if not IsValidDC(SrcDC) then begin
DebugLn('WARNING: TGtkWidgetSet.GetRawImageFromDevice invalid SrcDC');
exit;
end;
DCOrigin:=GetDCOffset(TDeviceContext(SrcDC));
{$IFDEF VerboseRawImage}
DebugLn('TGtkWidgetSet.GetRawImageFromDevice A DCOrigin=',dbgs(DCOrigin.X),',',dbgs(DCOrigin.Y),' SrcRect=',dbgs(SrcRect.Left),',',dbgs(SrcRect.Top),',',dbgs(SrcRect.Right),',',dbgs(SrcRect.Bottom));
{$ENDIF}
ARect:=SrcRect;
OffSetRect(ARect,DCOrigin.x,DCOrigin.y);
if TDeviceContext(SrcDC).DCWidget<>nil then begin
GDKWindow:=PGdkWindow(TDeviceContext(SrcDC).Drawable);
end else begin
// get screen shot
{$IFDEF Gtk1}
exit;
{$ELSE}
{$IFDEF HasX}
GDKWindow:=gdk_screen_get_root_window(gdk_screen_get_default);
{$ELSE}
exit;
{$ENDIF}
{$ENDIF}
end;
Result:=GetRawImageFromGdkWindow(GDKWindow,nil,ARect,NewRawImage);
end;
{------------------------------------------------------------------------------
function TGtkWidgetSet.GetRawImageFromBitmap(SrcBitmap, SrcMaskBitmap: HBITMAP;
const SrcRect: TRect; var NewRawImage: TRawImage): boolean; override;
------------------------------------------------------------------------------}
function TGtkWidgetSet.GetRawImageFromBitmap(SrcBitmap, SrcMaskBitmap: HBITMAP;
const SrcRect: TRect; var NewRawImage: TRawImage): boolean;
var
GDIImg: PGDIObject;
GdkPixmap: PGdkPixmap;
GDIMaskImg: PGDIObject;
GdkMaskBitmap: PGdkBitmap;
begin
Result:=false;
{$IFDEF VerboseRawImage}
DebugLn('TGtkWidgetSet.GetRawImageFromBitmap A');
{$ENDIF}
FillChar(NewRawImage,SizeOf(NewRawImage),0);
if (not IsValidGDIObject(SrcBitmap)) then begin
DebugLn('WARNING: [TGtkWidgetSet.GetRawImageFromBitmap] invalid SrcBitmap!');
exit;
end;
if ((SrcMaskBitmap<>0) and not IsValidGDIObject(SrcMaskBitmap)) then begin
DebugLn('WARNING: [TGtkWidgetSet.GetRawImageFromBitmap] invalid MaskBitmap!');
exit;
end;
try
// get rawimage for Bitmap
GDIImg:=PGDIObject(SrcBitmap);
GdkPixmap:=nil;
case GDIImg^.GDIBitmapType of
gbBitmap: GdkPixmap:=PGdkPixmap(GDIImg^.GDIBitmapObject);
gbPixmap: GdkPixmap:=PGdkPixmap(GDIImg^.GDIPixmapObject);
else
DebugLn('WARNING: [TGtkWidgetSet.GetRawImageFromBitmap] GDI_RGBImage not implemented');
exit;
end;
{$IFDEF VerboseRawImage}
DebugLn('TGtkWidgetSet.GetRawImageFromBitmap A GdkPixmap=',DbgS(GdkPixmap),' SrcMaskBitmap=',DbgS(SrcMaskBitmap));
{$ENDIF}
GDIMaskImg:=nil;
GdkMaskBitmap:=nil;
if SrcMaskBitmap<>0 then begin
// use special mask SrcMaskBitmap
GDIMaskImg:=PGDIObject(SrcMaskBitmap);
case GDIMaskImg^.GDIBitmapType of
gbBitmap: GdkMaskBitmap:=GDIMaskImg^.GDIBitmapObject;
else
DebugLn('WARNING: [TGtkWidgetSet.GetRawImageFromBitmap] invalid MaskBitmap');
exit;
end;
end else if GDIImg^.GDIBitmapMaskObject<>nil then begin
// use mask in SrcBitmap
GdkMaskBitmap:=GDIImg^.GDIBitmapMaskObject;
end else begin
// no mask available
end;
if not GetRawImageFromGdkWindow(PGdkWindow(GdkPixmap),GdkMaskBitmap,SrcRect,
NewRawImage)
then begin
DebugLn('WARNING: [TGtkWidgetSet.GetRawImageFromBitmap] unable to GetRawImageFromGdkWindow Image');
exit;
end;
except
FreeRawImageData(@NewRawImage);
end;
Result:=true;
end;
{------------------------------------------------------------------------------
function TGtkWidgetSet.GetScrollBarSize(Handle: HWND; BarKind: Integer): integer;
Returns the current width of the scrollbar of the widget.
------------------------------------------------------------------------------}
function TGtkWidgetSet.GetScrollBarSize(Handle: HWND; BarKind: Integer): integer;
var
Widget, ScrollWidget, BarWidget: PGtkWidget;
begin
Result:=0;
Widget:=PGtkWidget(Handle);
if GtkWidgetIsA(Widget,GTK_TYPE_SCROLLED_WINDOW) then begin
ScrollWidget:=Widget;
end else begin
ScrollWidget:=PGtkWidget(gtk_object_get_data(
PGtkObject(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 TGtkWidgetSet.GetScrollbarVisible(Handle: HWND;
SBStyle: Integer): boolean;
------------------------------------------------------------------------------}
function TGtkWidgetSet.GetScrollbarVisible(Handle: HWND; SBStyle: Integer): boolean;
var
Widget, ScrollWidget, BarWidget: PGtkWidget;
begin
Result:=false;
if Handle=0 then exit;
Widget:=PGtkWidget(Handle);
if GtkWidgetIsA(Widget,GTK_TYPE_SCROLLED_WINDOW) then begin
ScrollWidget:=Widget;
end else begin
ScrollWidget:=PGtkWidget(gtk_object_get_data(
PGtkObject(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 TGtkWidgetSet.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 := gtk_object_get_data(PGTKObject(Handle), odnScrollArea);
if GtkWidgetIsA(Scroll, gtk_scrolled_window_get_type)
then begin
IsScrollWindow := True;
end
else begin
Scroll := 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('[SetScrollInfo] 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('[SetScrollInfo] 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('[SetScrollInfo] 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 TGtkWidgetSet.GetStockObject(Value: Integer): THandle;
begin
Assert(False, Format('Trace:> [TGtkWidgetSet.GetStockObject] %d', [Value]));
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
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(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;
*) else
Assert(False, Format('Trace:TODO: [TGtkWidgetSet.GetStockObject] Implement value: %d', [Value]));
end;
Assert(False, Format('Trace:< [TGtkWidgetSet.GetStockObject] %d --> 0x%x', [Value, Result]));
end;
{------------------------------------------------------------------------------
Function: GetSysColor
Params: index to the syscolors array
Returns: RGB value
------------------------------------------------------------------------------}
function TGtkWidgetSet.GetSysColor(nIndex: Integer): DWORD;
begin
if (nIndex < 0) or (nIndex > MAX_SYS_COLORS)
then begin
Result := 0;
//RaiseException('');
DumpStack;
DebugLn(Format('ERROR: [TGtkWidgetSet.GetSysColor] Bad Value: %d. Valid Range between 0 and %d', [nIndex, MAX_SYS_COLORS]));
end
else Result := SysColorMap[nIndex];
//Assert(False, Format('Trace:[TGtkWidgetSet.GetSysColor] Index %d --> %8x', [nIndex, Result]));
end;
{------------------------------------------------------------------------------
Function: GetSystemMetrics
Params:
Returns: Nothing
------------------------------------------------------------------------------}
function TGtkWidgetSet.GetSystemMetrics(nIndex: Integer): Integer;
var
P: Pointer;
ax,ay,ah,aw: gint;
auw, auh: guint;
{$ifndef GTK2}{$ifdef HasX}
XDisplay: PDisplay;
XScreen: PScreen;
XWindow: TWindow;
{$endif}{$endif}
begin
Assert(False, Format('Trace:> [TGtkWidgetSet.GetSystemMetrics] %d', [nIndex]));
case nIndex of
SM_ARRANGE:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_ARRANGE ');
end;
SM_CLEANBOOT:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CLEANBOOT ');
end;
SM_CMOUSEBUTTONS:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CMOUSEBUTTONS ');
end;
SM_CXBORDER:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CXBORDER ');
end;
SM_CYBORDER:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CYBORDER ');
end;
SM_CXCURSOR,
SM_CYCURSOR:
begin
{$IFDEF GTK2}
// 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);
{$ELSE}
{$IFDEF HasX}
// same code used in gtk2 library
XDisplay := gdk_display;
XScreen := XDefaultScreenOfDisplay(XDisplay);
XWindow := XRootWindowOfScreen(XScreen);
XQueryBestCursor(XDisplay, XWindow, 128, 128, @auw, @auh);
{$ELSE}
Result := 32; // Default windows size
{$ENDIF}
{$ENDIF}
if nIndex = SM_CXCURSOR
then Result := auw // return width
else Result := auh; // return height
end;
SM_CXDOUBLECLK:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CXDOUBLECLK ');
end;
SM_CYDOUBLECLK:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.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
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CXFIXEDFRAME ');
end;
SM_CYFIXEDFRAME:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CYFIXEDFRAME ');
end;
SM_CXFULLSCREEN:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CXFULLSCREEN ');
end;
SM_CYFULLSCREEN:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CYFULLSCREEN ');
end;
SM_CXHSCROLL:
begin
P:=GetStyleWidget(lgsVerticalScrollbar);
Result := GTK_Widget(P)^.requisition.Width;
end;
SM_CYHSCROLL:
begin
P:=GetStyleWidget(lgsHorizontalScrollbar);
Result := GTK_Widget(P)^.requisition.Height;
end;
SM_CXHTHUMB:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CXHTHUMB ');
end;
SM_CXICON:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CXICON ');
end;
SM_CYICON:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CYICON ');
end;
SM_CXICONSPACING:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CXICONSPACING ');
end;
SM_CYICONSPACING:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CYICONSPACING ');
end;
SM_CXMAXIMIZED:
begin
{$IFDEF HasX}
if XGetWorkarea(ax,ay,aw,ah)>=0 then result:=aw
else getSystemMetrics(SM_CXSCREEN);
{$ENDIF}
end;
SM_CYMAXIMIZED:
begin
{$IFDEF HasX}
if XGetWorkarea(ax,ay,aw,ah)>=0 then result:=ah
else getSystemMetrics(SM_CYSCREEN);
{$ENDIF}
end;
SM_CXMAXTRACK:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CXMAXTRACK ');
end;
SM_CYMAXTRACK:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CYMAXTRACK ');
end;
SM_CXMENUCHECK:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CXMENUCHECK ');
end;
SM_CYMENUCHECK:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CYMENUCHECK ');
end;
SM_CXMENUSIZE:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CXMENUSIZE ');
end;
SM_CYMENUSIZE:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CYMENUSIZE ');
end;
SM_CXMIN:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CXMIN ');
end;
SM_CYMIN:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CYMIN ');
end;
SM_CXMINIMIZED:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CXMINIMIZED ');
end;
SM_CYMINIMIZED:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CYMINIMIZED ');
end;
SM_CXMINSPACING:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CXMINSPACING ');
end;
SM_CYMINSPACING:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CYMINSPACING ');
end;
SM_CXMINTRACK:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CXMINTRACK ');
end;
SM_CYMINTRACK:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CYMINTRACK ');
end;
SM_CXSCREEN,
SM_CXVIRTUALSCREEN:
begin
{$IFDEF GTK1} { Partial fix for multi monitor systems - force use of first one }
{$IFDEF UseXinerama}
if GetFirstScreen then
result := FirstScreen.x
else
{$ENDIF}
{$ENDIF}
result := gdk_Screen_Width;
end;
SM_CYSCREEN,
SM_CYVIRTUALSCREEN:
begin
{$IFDEF GTK1}
{$IFDEF UseXinerama}
if GetFirstScreen then
result := FirstScreen.y
else
{$ENDIF}
{$ENDIF}
result := gdk_Screen_Height;
end;
SM_CXSIZE:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CXSIZE ');
end;
SM_CYSIZE:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CYSIZE ');
end;
SM_CXSIZEFRAME:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CXSIZEFRAME ');
end;
SM_CYSIZEFRAME:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CYSIZEFRAME ');
end;
SM_CXSMICON:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CXSMICON ');
end;
SM_CYSMICON:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CYSMICON ');
end;
SM_CXSMSIZE:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CXSMSIZE ');
end;
SM_CYSMSIZE:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CYSMSIZE ');
end;
SM_CXVSCROLL:
begin
P:=GetStyleWidget(lgsVerticalScrollbar);
Result := GTK_Widget(P)^.requisition.Width;
end;
SM_CYVSCROLL:
begin
P:=GetStyleWidget(lgsHorizontalScrollbar);
Result := GTK_Widget(P)^.requisition.Height;
end;
SM_CYCAPTION:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CYCAPTION ');
end;
SM_CYKANJIWINDOW:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CYKANJIWINDOW ');
end;
SM_CYMENU:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CYMENU ');
end;
SM_CYSMCAPTION:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CYSMCAPTION ');
end;
SM_CYVTHUMB:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_CYVTHUMB ');
end;
SM_DBCSENABLED:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_DBCSENABLED ');
end;
SM_DEBUG:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_DEBUG ');
end;
SM_MENUDROPALIGNMENT:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_MENUDROPALIGNMENT');
end;
SM_MIDEASTENABLED:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_MIDEASTENABLED ');
end;
SM_MOUSEPRESENT:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_MOUSEPRESENT ');
end;
SM_MOUSEWHEELPRESENT:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_MOUSEWHEELPRESENT');
end;
SM_NETWORK:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_NETWORK ');
end;
SM_PENWINDOWS:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_PENWINDOWS ');
end;
SM_SECURE:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_SECURE ');
end;
SM_SHOWSOUNDS:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_SHOWSOUNDS ');
end;
SM_SLOWMACHINE:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_SLOWMACHINE ');
end;
SM_SWAPBUTTON:
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.GetSystemMetrics] --> SM_SWAPBUTTON ');
end;
else Result := 0;
end;
Assert(False, Format('Trace:< [TGtkWidgetSet.GetSystemMetrics] %d --> 0x%x (%d)', [nIndex, Result, Result]));
end;
{------------------------------------------------------------------------------
Function: GetTextColor
Params: DC
Returns: TColorRef
Gets the Font Color currently assigned to the Device Context
------------------------------------------------------------------------------}
function TGtkWidgetSet.GetTextColor(DC: HDC) : TColorRef;
begin
Result := 0;
if IsValidDC(DC) then
with TDeviceContext(DC) do
begin
Result := CurrentTextColor.ColorRef;
end;
end;
{------------------------------------------------------------------------------
Function: GetTextExtentPoint
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtkWidgetSet.GetTextExtentPoint(DC: HDC; Str: PChar; Count: Integer;
var Size: TSize): Boolean;
{$IfDef GTK2}
begin
DebugLn('TGtkWidgetSet.GetTextExtentPoint ToDo');
Result:=false;
end;
{$Else}
var
lbearing, rbearing, width, ascent,descent: LongInt;
UseFont : PGDKFont;
IsDBCSFont: Boolean;
NewCount: Integer;
begin
Result := IsValidDC(DC);
if Result
then with TDeviceContext(DC) do
begin
UseFont:=GetGtkFont(TDeviceContext(DC));
descent:=0;
UpdateDCTextMetric(TDeviceContext(DC));
IsDBCSFont:=TDeviceContext(DC).DCTextMetric.IsDoubleByteChar;
if IsDBCSFont then begin
NewCount:=Count*2;
if FExtUTF8OutCacheSize<NewCount then begin
ReAllocMem(FExtUTF8OutCache,NewCount);
FExtUTF8OutCacheSize:=NewCount;
end;
NewCount:=UTF8ToDoubleByte(Str,Count,FExtUTF8OutCache)*2;
gdk_text_extents(UseFont, FExtUTF8OutCache, NewCount,
@lbearing, @rBearing, @width, @ascent, @descent);
end else begin
gdk_text_extents(UseFont, Str, Count,
@lbearing, @rBearing, @width, @ascent, @descent);
end;
Size.cX := Width;
// I THINK this is accurate...
Size.cY :={$IFDEF Win32}
GDK_String_Height(UseFont, Str)
{$ELSE}
ascent+descent;
{$ENDIF}
//debugln('TGtkWidgetSet.GetTextExtentPoint END Str="'+DbgStr(Str)+'" Size=',dbgs(Size.cX),'x',dbgs(Size.cY),' ascent=',dbgs(ascent),' descent=',dbgs(descent),' tmDescent=',dbgs(TDeviceContext(DC).DCTextMetric.TextMetric.tmDescent));
end;
Assert(False, 'trace:< [TGtkWidgetSet.GetTextExtentPoint]');
end;
{$EndIf}
{------------------------------------------------------------------------------
Function: GetTextMetrics
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtkWidgetSet.GetTextMetrics(DC: HDC; var TM: TTextMetric): Boolean;
begin
Assert(False, Format('Trace:> TODO FINISH[TGtkWidgetSet.GetTextMetrics] DC: 0x%x', [DC]));
Result := IsValidDC(DC);
if Result then begin
UpdateDCTextMetric(TDeviceContext(DC));
TM:=TDeviceContext(DC).DCTextMetric.TextMetric;
end;
Assert(False, Format('Trace:< TODO FINISH[TGtkWidgetSet.GetTextMetrics] DC: 0x%x', [DC]));
end;
{------------------------------------------------------------------------------
Function: GetWindowLong
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
Function TGtkWidgetSet.GetWindowLong(Handle : hwnd; int : Integer): PtrInt;
var
//Data : Tobject;
P : Pointer;
begin
//TODO:Started but not finished
Assert(False, Format('Trace:> [TGtkWidgetSet.GETWINDOWLONG] HWND: 0x%x, int: 0x%x (%d)', [Handle, int, int]));
case int of
GWL_WNDPROC :
begin
Result := PtrInt(gtk_object_get_data(pgtkobject(Handle),'WNDPROC'));
end;
GWL_HINSTANCE :
begin
Result := PtrInt(gtk_object_get_data(pgtkobject(Handle),'HINSTANCE'));
end;
GWL_HWNDPARENT :
begin
P := gtk_object_get_data(pgtkobject(Handle),'HWNDPARENT');
if P = nil then Result := 0 else Result := PtrInt(p);
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) cant 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
Result := PtrInt(gtk_object_get_data(pgtkobject(Handle),'Style'));
end;
GWL_EXSTYLE :
begin
Result := PtrInt(gtk_object_get_data(pgtkobject(Handle),'ExStyle'));
end;
GWL_USERDATA :
begin
Result := PtrInt(gtk_object_get_data(pgtkobject(Handle),'Userdata'));
end;
GWL_ID :
begin
Result := PtrInt(gtk_object_get_data(pgtkobject(Handle),'ID'));
end;
else Result := 0;
end; //case
Assert(False, Format('Trace:< [TGtkWidgetSet.GETWINDOWLONG] HWND: 0x%x, int: 0x%x (%d) --> 0x%x (%d)', [Handle, int, int, Result, Result]));
end;
{------------------------------------------------------------------------------
Function: GetWindowOrgEx
Params: none
Returns: Nothing
Returns the current offset of the DC.
------------------------------------------------------------------------------}
function TGtkWidgetSet.GetWindowOrgEx(dc : hdc; P : PPoint): Integer;
begin
Result := 0;
if P=nil then exit;
P^ := Point(0,0);
If not IsValidDC(DC) then exit;
with TDeviceContext(DC) do begin
P^:=GetDCOffset(TDeviceContext(DC));
Result:=1;
end;
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 TGtkWidgetSet.GetWindowRect(Handle: hwnd; var ARect: TRect): Integer;
var
X, Y, W, H: Integer;
Widget: PGTKWidget;
Window: PGdkWindow;
begin
//DebugLn('GetWindowRect');
Result := 0; //default
if Handle <> 0 then
begin
Widget := pgtkwidget(Handle);
Window:=GetControlWindow(Widget);
if Window <> nil then Begin
gdk_window_get_origin(Window, @X, @Y);
gdk_window_get_size(Window, @W, @H);
end
else
Begin
X := 0;
Y := 0;
W := 100;
Y := 200;
end;
ARect:=Rect(X,Y,X+W,Y+H);
end;
end;
{------------------------------------------------------------------------------
Function: GetWindowRelativePosition
Params: Handle : hwnd;
Returns: true on success
Returns the Left, Top, relative to the client origin of its parent
------------------------------------------------------------------------------}
function TGtkWidgetSet.GetWindowRelativePosition(Handle : hwnd;
var Left, Top: integer): boolean;
var
aWidget: PGtkWidget;
begin
aWidget:=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 TGtkWidgetSet.GetWindowSize(Handle : hwnd;
var Width, Height: integer): boolean;
begin
if GtkWidgetIsA(PGtkWidget(Handle),GTK_TYPE_WIDGET) then begin
Result:=true;
Width:=PGtkWidget(Handle)^.Allocation.Width;
Height:=PGtkWidget(Handle)^.Allocation.Height;
end else
Result:=false;
end;
{------------------------------------------------------------------------------
Function: GradientFill
Params: DC - DeviceContext to perform on
Vertices - array of Points W/Color & Alpha
NumVertices - Number of Vertices
Meshes - array of Triangle or Rectangle Meshes,
each mesh representing one Gradient Fill
NumMeshes - Number of Meshes
Mode - Gradient Type, either Triangle,
Vertical Rect, Horizontal Rect
Returns: true on success
Performs multiple Gradient Fills, either a Three way Triangle Gradient,
or a two way Rectangle Gradient, each Vertex point also supports optional
Alpha/Transparency for more advanced Gradients.
------------------------------------------------------------------------------}
function TGtkWidgetSet.GradientFill(DC: HDC; Vertices: PTriVertex;
NumVertices : Longint;
Meshes: Pointer; NumMeshes : Longint; Mode : Longint): Boolean;
Function DoFillTriangle : Boolean;
begin
Result := (Mode and GRADIENT_FILL_TRIANGLE) = GRADIENT_FILL_TRIANGLE;
end;
Function DoFillVRect : Boolean;
begin
Result := (Mode and GRADIENT_FILL_RECT_V) = GRADIENT_FILL_RECT_V;
end;
Procedure GetGradientBrush(BeginColor, EndColor : TColorRef; Position,
TotalSteps : Longint; var GradientBrush : hBrush);
var
R1, G1, B1 : Integer;
R2, G2, B2 : Integer;
NewBrush : TLogBrush;
begin
GetRGBIntValues(BeginColor,R1,G1,B1);
GetRGBIntValues(EndColor,R2,G2,B2);
R1 := R1 + (Position*(R2 - R1) div TotalSteps);
G1 := G1 + (Position*(G2 - G1) div TotalSteps);
B1 := B1 + (Position*(B2 - B1) div TotalSteps);
With NewBrush do begin
lbStyle := BS_SOLID;
lbColor := RGB(R1,G1,B1);
end;
If GradientBrush <> 0 then
LCLIntf.DeleteObject(GradientBrush);
GradientBrush := LCLIntf.CreateBrushIndirect(NewBrush);
end;
Function FillTriMesh(Mesh : tagGradientTriangle) : Boolean;
{var
V1, V2, V3 : tagTRIVERTEX;
C1, C2, C3 : TColorRef;
begin
With Mesh do begin
Result := (Vertex1 < NumVertices) and (Vertex2 >= 0) and
(Vertex2 < NumVertices) and (Vertex2 >= 0) and
(Vertex3 < NumVertices) and (Vertex3 >= 0);
If (Vertex1 = Vertex2) or (Vertex1 = Vertex3) or
(Vertex2 = Vertex3) or not Result
then
exit;
V1 := Vertices[Vertex1];
V2 := Vertices[Vertex2];
V3 := Vertices[Vertex3];
//Check to make sure they are in reasonable positions..
//then what??
end;}
begin
Result := False;
end;
Function FillRectMesh(Mesh : tagGradientRect) : Boolean;
var
TL,BR : tagTRIVERTEX;
StartColor, EndColor : TColorRef;
I, Swap : Longint;
SwapColors : Boolean;
UseBrush : hBrush;
Steps, MaxSteps : Longint;
begin
With Mesh do begin
Result := (UpperLeft < NumVertices) and (UpperLeft >= 0) and
(LowerRight < NumVertices) and (LowerRight >= 0);
If (LowerRight = UpperLeft) or not Result then
exit;
TL := Vertices[UpperLeft];
BR := Vertices[LowerRight];
SwapColors := (BR.Y < TL.Y) and (BR.X < TL.X);
If BR.X < TL.X then begin
Swap := BR.X;
BR.X := TL.X;
TL.X := Swap;
end;
If BR.Y < TL.Y then begin
Swap := BR.Y;
BR.Y := TL.Y;
TL.Y := Swap;
end;
StartColor := RGB(TL.Red, TL.Green, TL.Blue);
EndColor := RGB(BR.Red, BR.Green, BR.Blue);
If SwapColors then begin
Swap := StartColor;
StartColor := EndColor;
EndColor := Swap;
end;
UseBrush := 0;
MaxSteps := GetDeviceCaps(DC, BITSPIXEL);
If MaxSteps >= 4 then
MaxSteps := Floor(Power(2, MaxSteps))
else
MaxSteps := 256;
If DoFillVRect then begin
Steps := Min(BR.Y - TL.Y, MaxSteps);
for I := 0 to Steps - 1 do begin
GetGradientBrush(StartColor, EndColor, I, Steps, UseBrush);
LCLIntf.FillRect(DC, Rect(TL.X, TL.Y + I, BR.X, TL.Y + I + 1),
UseBrush)
end
end
else begin
Steps := Min(BR.X - TL.X, MaxSteps);
for I := 0 to Steps - 1 do begin
GetGradientBrush(StartColor, EndColor, I, Steps, UseBrush);
LCLIntf.FillRect(DC, Rect(TL.X + I, TL.Y, TL.X + I + 1, BR.Y),
UseBrush);
end;
end;
If UseBrush <> 0 then
LCLIntf.DeleteObject(UseBrush);
end;
end;
const
MeshSize: Array[Boolean] of Integer = (
SizeOf(tagGradientRect), SizeOf(tagGradientTriangle));
var
I : Integer;
begin
//Currently Alpha blending is ignored... Ideas anyone?
Result := (Meshes <> nil) and (NumMeshes >= 1) and (NumVertices >= 2)
and (Vertices <> nil);
If Result and DoFillTriangle then
Result := NumVertices >= 3;
If Result then begin
Result := False;
//Sanity Checks For Vertices Size vs. Count
If MemSize(Vertices) < SizeOf(tagTRIVERTEX)*NumVertices then
exit;
//Sanity Checks For Meshes Size vs. Count
If MemSize(Meshes) < MeshSize[DoFillTriangle]*NumMeshes then
exit;
For I := 0 to NumMeshes - 1 do begin
If DoFillTriangle then begin
If Not FillTriMesh(PGradientTriangle(Meshes)[I]) then
exit;
end
else begin
If not FillRectMesh(PGradientRect(Meshes)[I]) then
exit;
end;
end;
Result := True;
end;
end;
{------------------------------------------------------------------------------
Function: HideCaret
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtkWidgetSet.HideCaret(hWnd: HWND): Boolean;
var
GTKObject: PGTKObject;
WasVisible: boolean;
begin
//DebugLn('[TGtkWidgetSet.HideCaret] A');
Assert(False, Format('Trace: [TGtkWidgetSet.HideCaret] HWND: 0x%x', [hWnd]));
//TODO: [TGtkWidgetSet.HideCaret] Finish (in gtkwinapi.inc)
GTKObject := PGTKObject(HWND);
Result := GTKObject <> nil;
if Result
then begin
if gtk_type_is_a(gtk_object_type(GTKObject), GTKAPIWidget_GetType)
then begin
GTKAPIWidget_HideCaret(PGTKAPIWidget(GTKObject),WasVisible);
end
// else if // TODO: other widgettypes
else begin
Result := False;
end;
end
else DebugLn('WARNING: [TGtkWidgetSet.HideCaret] Got null HWND');
end;
{------------------------------------------------------------------------------
Function: IntersectClipRect
Params: dc: hdc; Left, Top, Right, Bottom: Integer
Returns: Integer
Shrinks the clipping region in the device context dc to a region of all
intersecting points between the boundary defined by Left, Top, Right,
Bottom , and the Current clipping region.
The result can be one of the following constants
Error
NullRegion
SimpleRegion
ComplexRegion
------------------------------------------------------------------------------}
function TGtkWidgetSet.IntersectClipRect(dc: hdc;
Left, Top, Right, Bottom: Integer): Integer;
begin
Result := Inherited IntersectClipRect(DC, Left, Top, Right, Bottom);
end;
{------------------------------------------------------------------------------
Function: InvalidateRect
Params: aHandle:
Rect:
bErase:
Returns:
------------------------------------------------------------------------------}
function TGtkWidgetSet.InvalidateRect(aHandle : HWND; Rect : pRect;
bErase : Boolean) : Boolean;
var
gdkRect : TGDKRectangle;
Widget, PaintWidget: PGtkWidget;
LCLObject: TObject;
begin
// DebugLn(format('Rect = %d,%d,%d,%d',[rect^.left,rect^.top,rect^.Right,rect^.Bottom]));
Widget:=PGtkWidget(aHandle);
LCLObject:=GetLCLObject(Widget);
if (LCLObject<>nil) then begin
if (LCLObject=CurrentSentPaintMessageTarget) then begin
DebugLn('NOTE: TGtkWidgetSet.InvalidateRect during paint message: ',
LCLObject.ClassName);
//RaiseException('Double paint');
end;
{$IFDEF VerboseDsgnPaintMsg}
if (LCLObject is TComponent)
and (csDesigning in TComponent(LCLObject).ComponentState) then begin
write('TGtkWidgetSet.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
gdkRect.X := 0;//PaintWidget^.Allocation.X;
gdkRect.Y := 0;//PaintWidget^.Allocation.Y;
gdkRect.Width:=PaintWidget^.Allocation.Width;
gdkRect.Height:=PaintWidget^.Allocation.Height;
end else begin
gdkRect.X := Rect^.Left;
gdkRect.Y := Rect^.Top;
gdkRect.Width := (Rect^.Right - Rect^.Left);
gdkRect.Height := (Rect^.Bottom - Rect^.Top);
end;
{$IfDef GTK2}
if (PaintWidget<>nil) and GTK_WIDGET_NO_WINDOW(PaintWidget)
and (not GtkWidgetIsA(PGTKWidget(PaintWidget),GTKAPIWidget_GetType))
and (Rect<>nil)
then begin
Inc(gdkRect.X, PaintWidget^.Allocation.x);
Inc(gdkRect.Y, PaintWidget^.Allocation.y);
end;
{$EndIf}
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);
end;
{------------------------------------------------------------------------------
function TGtkWidgetSet.IsWindowEnabled(handle: HWND): boolean;
------------------------------------------------------------------------------}
function TGtkWidgetSet.IsWindowEnabled(handle: HWND): boolean;
var
LCLObject: TObject;
Widget: PGtkWidget;
AForm: TCustomForm;
//i: Integer;
begin
Widget:=PGtkWidget(handle);
Result:=(Widget<>nil) and GTK_WIDGET_SENSITIVE(Widget)
and GTK_WIDGET_PARENT_SENSITIVE(Widget);
LCLObject:=GetLCLObject(PGtkWidget(Handle));
//debugln('TGtkWidgetSet.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('TGtkWidgetSet.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 TGtkWidgetSet.IsWindowVisible(handle: HWND): boolean;
------------------------------------------------------------------------------}
function TGtkWidgetSet.IsWindowVisible(handle: HWND): boolean;
begin
Result:=(handle<>0) and GTK_WIDGET_VISIBLE(PGtkWidget(handle));
end;
{------------------------------------------------------------------------------
Function: LineTo
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtkWidgetSet.LineTo(DC: HDC; X, Y: Integer): Boolean;
var
DCOrigin: TPoint;
FromX: Integer;
FromY: Integer;
ToX: Integer;
ToY: Integer;
begin
Assert(False, Format('trace:> [TGtkWidgetSet.LineTo] DC:0x%x, X:%d, Y:%d', [DC, X, Y]));
Result := IsValidDC(DC);
if Result
then with TDeviceContext(DC) do
begin
SelectGDKPenProps(DC);
If (dcfPenSelected in DCFlags) then begin
Result := True;
if IsNullPen(TDeviceContext(DC)) then exit;
DCOrigin:=GetDCOffset(TDeviceContext(DC));
{$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF}
FromX:=PenPos.X+DCOrigin.X;
FromY:=PenPos.Y+DCOrigin.Y;
ToX:=X+DCOrigin.X;
ToY:=Y+DCOrigin.Y;
{debugln('TGtkWidgetSet.LineTo A ',dbgs(FromX),' ',dbgs(FromY),' ',dbgs(ToX),' ',dbgs(ToY));
if (FromX>ToX) or ((FromX=ToX) and (FromY>ToY)) then begin
// in these cases gdk starts and ends drawing a line one point later
debugln('TGtkWidgetSet.LineTo SWAPPED ',dbgs(FromX),' ',dbgs(FromY),' ',dbgs(ToX),' ',dbgs(ToY));
end;}
//gdk_gc_set_line_attributes(gc,1,GDK_LINE_SOLID, GDK_CAP_NOT_LAST, GDK_JOIN_MITER);
// if line width is 1, then we need
// "GDK_CAP_NOT_LAST - for zero width lines, the final point on the line
// will not be drawn"
if (GCValues.line_width=1) then
begin
{gc_values.line_width:=0; // fp not have "gdk_gc_set_values" implementation
gdk_gc_set_values(GC, @gc_values, GDK_GC_LINE_WIDTH);}
gdk_gc_set_line_attributes(GC, 0, GCValues.line_style, GDK_CAP_NOT_LAST,
GCValues.join_style);
end;
gdk_draw_line(Drawable, GetGC, FromX, FromY, ToX, ToY);
{$IFDEF DebugGDK}EndGDKErrorTrap;{$ENDIF}
PenPos:= Point(X, Y);
end else
Result := False;
end;
Assert(False, Format('trace:< [TGtkWidgetSet.LineTo] DC:0x%x, X:%d, Y:%d', [DC, X, Y]));
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(gtk_object_get_data(PGtkObject(Widget), 'modal_result')));
if PInteger(data)^ = 0 then
PInteger(data)^:=PtrInt(gtk_object_get_data(PGtkObject(Widget), 'modal_result'));
Result:=false;
end;
function MessageBoxClosed(Widget : PGtkWidget; Event : PGdkEvent;
data: gPointer) : GBoolean; cdecl;
var ModalResult : PtrInt;
begin
{ We were requested by window manager to close }
if PInteger(data)^ = 0 then begin
ModalResult:= PtrInt(gtk_object_get_data(PGtkObject(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 TGtkWidgetSet.MessageBox(hWnd: HWND; lpText, lpCaption: PChar;
uType : Cardinal): integer;
var Dialog, ALabel : PGtkWidget;
ButtonCount, DefButton, ADialogResult : Integer;
DialogType : Cardinal;
procedure CreateButton(const ALabel : PChar; const RetValue : integer);
var AButton : PGtkWidget;
begin
AButton:= gtk_button_new_with_label(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
gtk_object_set_data(PGtkObject(Dialog), 'modal_result', Pointer(IDCANCEL));
end;
gtk_object_set_data(PGtkObject(AButton), 'modal_result',
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;
Assert(False, 'Trace:Default button is ' + IntToStr(DefButton));
ADialogResult:= 0;
Dialog:= gtk_dialog_new;
{$IFDEF DebugLCLComponents}
DebugGtkWidgets.MarkCreated(Dialog,'TGtkWidgetSet.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);
DialogType:= (uType and $0000000F);
if DialogType = MB_OKCANCEL
then begin
CreateButton(PChar(rsMbOK), IDOK);
CreateButton(PChar(rsMbCancel), IDCANCEL);
end
else begin
if DialogType = MB_ABORTRETRYIGNORE
then begin
CreateButton(PChar(rsMbAbort), IDABORT);
CreateButton(PChar(rsMbRetry), IDRETRY);
CreateButton(PChar(rsMbIgnore), IDIGNORE);
end
else begin
if DialogType = MB_YESNOCANCEL
then begin
CreateButton(PChar(rsMbYes), IDYES);
CreateButton(PChar(rsMbNo), IDNO);
CreateButton(PChar(rsMbCancel), IDCANCEL);
end
else begin
if DialogType = MB_YESNO
then begin
CreateButton(PChar(rsMbYes), IDYES);
CreateButton(PChar(rsMbNo), IDNO);
end
else begin
if DialogType = MB_RETRYCANCEL
then 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;
end;
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 TGtkWidgetSet.MoveToEx(DC: HDC; X, Y: Integer;
OldPoint: PPoint): Boolean;
begin
Assert(False, Format('trace:> [TGtkWidgetSet.MoveToEx] DC:0x%x, X:%d, Y:%d', [DC, X, Y]));
Result := IsValidDC(DC);
if Result
then with TDeviceContext(DC) do
begin
if OldPoint <> nil then OldPoint^ := PenPos;
PenPos := Point(X, Y);
end;
Assert(False, Format('trace:< [TGtkWidgetSet.MoveToEx] DC:0x%x, X:%d, Y:%d', [DC, X, Y]));
end;
{------------------------------------------------------------------------------
function MoveWindowOrgEx(DC: HDC; dX, dY: Integer): Boolean; override;
Move the origin of all operations of a DeviceContext.
For example:
Moving the Origin to 10,20 and drawing a point to 50,50, results in
drawing a point to 60,70.
------------------------------------------------------------------------------}
function TGtkWidgetSet.MoveWindowOrgEx(DC: HDC; dX, dY: Integer): Boolean;
begin
Result:=IsValidDC(DC);
if Result then
with TDeviceContext(DC) do begin
//DebugLn('[TGtkWidgetSet.MoveWindowOrgEx] B DC=',DbgS(DC),
// ' Old=',Origin.X,',',Origin.Y,' d=',dX,',',dY,' ');
inc(Origin.X,dX);
inc(Origin.Y,dY);
end;
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 TGtkWidgetSet.PeekMessage(var lpMsg: TMsg; Handle : HWND;
wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): Boolean;
var
vlItem : TGtkMessageQueueItem;
begin
//TODO Filtering
DebugLn('Peek !!!' );
vlItem := fMessageQueue.FirstMessageItem;
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;
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 TGtkWidgetSet.PolyBezier(DC: HDC; Points: PPoint; NumPts: Integer;
Filled, Continuous: Boolean): Boolean;
begin
Result := Inherited PolyBezier(DC, Points, NumPts, Filled, Continuous);
end;
{------------------------------------------------------------------------------
Method: TGtkWidgetSet.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 TGtkWidgetSet.Polygon(DC: HDC; Points: PPoint; NumPts: Integer;
Winding: Boolean): boolean;
var
i: integer;
PointArray: PGDKPoint;
Tmp, RGN : hRGN;
ClipRect : TRect;
DCOrigin: TPoint;
OldNumPts: integer;
begin
Result := IsValidDC(DC);
if Result
then with TDeviceContext(DC) do
begin
if NumPts<=0 then exit;
DCOrigin:=GetDCOffset(TDeviceContext(DC));
// create the PointsArray, which is a copy of Points moved by the DCOrigin
GetMem(PointArray,SizeOf(TGdkPoint)*(NumPts+1)); // +1 for return line
for i:=0 to NumPts-1 do begin
PointArray[i].x:=Points[i].x;
PointArray[i].y:=Points[i].y;
Inc(PointArray[i].x, DCOrigin.X);
Inc(PointArray[i].y, DCOrigin.Y);
end;
OldNumPts:=NumPts;
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;
// first draw interior in brush color
{$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF}
If not IsNullBrush(TDeviceContext(DC)) then begin
SelectGDKBrushProps(DC);
if Winding then begin
// store old clipping
Tmp := CreateEmptyRegion;
GetClipRGN(DC, Tmp);
// apply new clipping
RGN := CreatePolygonRgn(Points, OldNumPts, LCLType.Winding);
ExtSelectClipRGN(DC, RGN, RGN_AND);
DeleteObject(RGN);
GetClipBox(DC, @ClipRect);
// draw polygon area
FillRect(DC, ClipRect, HBrush(GetBrush));
// restore old clipping
SelectClipRGN(DC, Tmp);
DeleteObject(Tmp);
end else
gdk_draw_polygon(Drawable, GetGC, 1, PointArray, NumPts);
end;
// draw outline
Result := True;
SelectGDKPenProps(DC);
if not IsNullPen(TDeviceContext(DC)) then begin
gdk_draw_polygon(Drawable, GetGC, 0, PointArray, NumPts);
end;
{$IFDEF DebugGDKTraps}EndGDKErrorTrap;{$ENDIF}
FreeMem(PointArray);
Result := True;
end;
end;
function TGtkWidgetSet.Polyline(DC: HDC; Points: PPoint; NumPts: Integer): boolean;
var i: integer;
PointArray: PGDKPoint;
DCOrigin: TPoint;
begin
Result := IsValidDC(DC);
if Result
then with TDeviceContext(DC) do
begin
if NumPts<=0 then exit;
DCOrigin:=GetDCOffset(TDeviceContext(DC));
GetMem(PointArray,SizeOf(TGdkPoint)*NumPts);
for i:=0 to NumPts-1 do begin
PointArray[i].x:=Points[i].x+DCOrigin.X;
PointArray[i].y:=Points[i].y+DCOrigin.Y;
end;
// draw outline
SelectGDKPenProps(DC);
If (dcfPenSelected in DCFlags) then begin
Result := True;
if not IsNullPen(TDeviceContext(DC)) then begin
{$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF}
gdk_draw_lines(Drawable, GetGC, PointArray, NumPts);
{$IFDEF DebugGDKTraps}EndGDKErrorTrap;{$ENDIF}
end;
end else
Result:=false;
FreeMem(PointArray);
end;
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 TGtkWidgetSet.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(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 begin
RaiseGDBException('CombinePaintMessages A unknown paint message');
end else if (OldMsg^.Message<>LM_GtkPAINT) then begin
RaiseGDBException('CombinePaintMessages B unknown paint message');
end 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;
New(AMessage);
AMessage^.HWnd := Handle; // this is normally the main gtk widget
AMessage^.Message := Msg;
AMessage^.WParam := WParam;
AMessage^.LParam := LParam;
// Message^.Time :=
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);
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 TGtkWidgetSet.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 TGtkWidgetSet.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 TGtkWidgetSet.RealizePalette(DC: HDC): Cardinal;
begin
Assert(False, 'Trace:FINISH: [TGtkWidgetSet.RealizePalette]');
Result := 0;
if IsValidDC(DC)
then with TDeviceContext(DC) do
begin
end;
end;
{------------------------------------------------------------------------------
Function: Rectangle
Params: DC: HDC; X1, Y1, X2, Y2: Integer
Returns: Nothing
The Rectangle function draws a rectangle. The rectangle is outlined by using
the current pen and filled by using the current brush.
------------------------------------------------------------------------------}
function TGtkWidgetSet.Rectangle(DC: HDC; X1, Y1, X2, Y2: Integer): Boolean;
var
Left, Top, Width, Height: Integer;
DCOrigin: TPoint;
begin
Assert(False, Format('trace:> [TGtkWidgetSet.Rectangle] DC:0x%x, X1:%d, Y1:%d, X2:%d, Y2:%d', [DC, X1, Y1, X2, Y2]));
Result := IsValidDC(DC);
if Result
then with TDeviceContext(DC) do
begin
CalculateLeftTopWidthHeight(X1,Y1,X2,Y2,Left,Top,Width,Height);
// X2, Y2 is not part of the rectangle
dec(Width);
dec(Height);
// first draw interior in brush color
SelectGDKBrushProps(DC);
DCOrigin:=GetDCOffset(TDeviceContext(DC));
{$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF}
If not IsNullBrush(TDeviceContext(DC)) then
if (GetBrush^.GDIBrushFill = GDK_SOLID)
and (IsBackgroundColor(TColor(GetBrush^.GDIBrushColor.ColorRef))) then
StyleFillRectangle(Drawable, GetGC, GetBrush^.GDIBrushColor.ColorRef,
Left+DCOrigin.X, Top+DCOrigin.Y, Width, Height)
else
gdk_draw_rectangle(Drawable, GetGC, 1, Left+DCOrigin.X, Top+DCOrigin.Y,
Width, Height);
// Draw outline
SelectGDKPenProps(DC);
If (dcfPenSelected in DCFlags) then begin
Result := True;
if not IsNullPen(TDeviceContext(DC)) then
gdk_draw_rectangle(Drawable, GetGC, 0, Left+DCOrigin.X, Top+DCOrigin.Y,
Width, Height);
end else
Result:=false;
{$IFDEF DebugGDKTraps}EndGDKErrorTrap;{$ENDIF}
end;
Assert(False, Format('trace:< [TGtkWidgetSet.Rectangle] DC:0x%x, X1:%d, Y1:%d, X2:%d, Y2:%d', [DC, X1, Y1, X2, Y2]));
end;
{------------------------------------------------------------------------------
Function: RectVisible
Params: dc : hdc; ARect: TRect
Returns: True if ARect is not completely clipped away.
------------------------------------------------------------------------------}
function TGtkWidgetSet.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 TGtkWidgetSet.RegroupMenuItem(hndMenu: HMENU;
GroupIndex: Integer): Boolean;
const
GROUPIDX_DATANAME = 'GroupIndex';
function GetGroup: PGSList;
{$IfDef GTK1}
var
Item: PGList;
Arg: TGTKArg;
begin
Result := nil;
Arg.theType := GTK_TYPE_OBJECT;
Arg.Name := 'parent';
gtk_widget_get(Pointer(hndMenu), @Arg);
if Arg.d.object_data = nil then Exit;
Item := gtk_container_children(PGTKContainer(Arg.d.object_data));
while Item <> nil do
begin
if (Item^.Data <> Pointer(hndMenu)) // exclude ourself
and gtk_is_radio_menu_item(Item^.Data)
and (GroupIndex = PtrInt(gtk_object_get_data(Item^.Data, GROUPIDX_DATANAME)))
then begin
Result := gtk_radio_menu_item_group(PGtkRadioMenuItem(Item^.Data));
Exit;
end;
Item := Item^.Next;
end;
{$Else}
var
Item: PGList;
parent : PGTKWidget;
begin
Result := nil;
parent := gtk_widget_get_parent(Pointer(hndMenu));
if parent = nil then Exit;
Item := gtk_container_children(PGTKContainer(parent));
while Item <> nil do
begin
if (Item^.Data <> Pointer(hndMenu)) // exclude ourself
and gtk_is_radio_menu_item(Item^.Data)
and (GroupIndex = Integer(gtk_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;
{$EndIf}
end;
var
RadioGroup: PGSList;
CurrentGroupIndex: Integer;
begin
Result := False;
if not gtk_is_radio_menu_item(Pointer(hndMenu))
then begin
DebugLn('WARNING: TGtkWidgetSet.RegroupMenuItem: handle is not a GTK_RADIO_MENU_ITEM');
Exit;
end;
CurrentGroupIndex := PtrInt(gtk_object_get_data(Pointer(hndMenu), GROUPIDX_DATANAME));
// Update needed ?
if GroupIndex = CurrentGroupIndex
then begin
Result := True;
Exit;
end;
// Remove current group
gtk_radio_menu_item_set_group(PGtkRadioMenuItem(hndMenu), nil);
gtk_object_set_data(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
gtk_object_set_data(Pointer(hndMenu), GROUPIDX_DATANAME, Pointer(PtrInt(GroupIndex)));
if RadioGroup = nil
then begin
// We're the only member, get a group
RadioGroup := gtk_radio_menu_item_group(PGtkRadioMenuItem(hndMenu))
end
else begin
gtk_radio_menu_item_set_group(PGtkRadioMenuItem(hndMenu), RadioGroup);
end;
//radiogroup^.data
//radiogroup^.next
// Refetch newgroup list
RadioGroup := gtk_radio_menu_item_group(PGtkRadioMenuItem(hndMenu));
// Update checks
UpdateRadioGroupChecks(RadioGroup);
Result := True;
end;
// MWE: Reimplemented to get rid of unneeded group order constraint
// (which doesn't work if the menu isn't created in order)
(*
function GetGroup(ParentMenuItem: TMenuItem;
GrpIndex, LastRadioItem: integer): PGSList;
var
i: Integer;
begin
for i:=LastRadioItem downto 0 do begin
if ParentMenuItem[i].RadioItem
and (ParentMenuItem[i].GroupIndex=GrpIndex)
and ParentMenuItem[i].HandleAllocated
and GtkWidgetIsA(Pointer(ParentMenuItem[i].Handle),
GTK_RADIO_MENU_ITEM_TYPE)
then begin
Result:=gtk_radio_menu_item_group(
GTK_RADIO_MENU_ITEM(ParentMenuItem[i].Handle));
//DebugLn('TGtkWidgetSet.RegroupMenuItem.GetGroup A i=',i,' ',ParentMenuItem[i].Name,' GrpIndex=',ParentMenuItem[i].GroupIndex,' LastRadioItem=',LastRadioItem,' Result=',DbgS(Result));
exit;
end;
end;
Result:=nil;
end;
var
RadioGroup: PGSList;
AMenuItem: TMenuItem;
ParentMenuItem: TMenuItem;
LastRadioGroupStart: integer;
i: Integer;
begin
if GTK_IS_RADIO_MENU_ITEM(Pointer(hndMenu)) then begin
AMenuItem:=TMenuItem(GetLCLObject(Pointer(hndMenu)));
if AMenuItem=nil then exit;
ParentMenuItem:=AMenuItem.Parent;
if ParentMenuItem=nil then exit;
//DebugLn('TGtkWidgetSet.RegroupMenuItem A ',AMenuItem.Name,' ',ParentMenuItem.Name,' GroupIndex=',AMenuItem.GroupIndex);
LastRadioGroupStart:=-1;
for i:=0 to ParentMenuItem.Count-1 do begin
if ParentMenuItem[i].RadioItem
and ParentMenuItem[i].HandleAllocated
and GtkWidgetIsA(Pointer(ParentMenuItem[i].Handle),
GTK_RADIO_MENU_ITEM_TYPE)
then begin
//DebugLn('TGtkWidgetSet.RegroupMenuItem B i=',i,' ',ParentMenuItem[i].Name,
//' GrpIndex=',ParentMenuItem[i].GroupIndex,
//' LastRadioGroupStart=',LastRadioGroupStart,
//' LastGroup=',DbgS(Cardinal(gtk_radio_menu_item_group(
// GTK_RADIO_MENU_ITEM(ParentMenuItem[i].Handle))),8)
//);
if (ParentMenuItem[i].GroupIndex<>0) then begin
// item has a group -> bind to group
RadioGroup:=GetGroup(ParentMenuItem,ParentMenuItem[i].GroupIndex,
LastRadioGroupStart);
gtk_radio_menu_item_set_group(
PGtkRadioMenuItem(ParentMenuItem[i].Handle),RadioGroup);
if (LastRadioGroupStart<0)
or (ParentMenuItem[LastRadioGroupStart].GroupIndex
<>ParentMenuItem[i].GroupIndex)
then
LastRadioGroupStart:=i;
end else begin
// item has no group -> unbind
if gtk_radio_menu_item_group(
GTK_RADIO_MENU_ITEM(ParentMenuItem[i].Handle))
<>nil
then
gtk_radio_menu_item_set_group(
PGtkRadioMenuItem(ParentMenuItem[i].Handle),nil);
end;
end;
end;
// update checks
RadioGroup:=gtk_radio_menu_item_group(PGtkRadioMenuItem(hndMenu));
UpdateRadioGroupChecks(RadioGroup);
Result:=true;
end else begin
DebugLn('WARNING: TGtkWidgetSet.RegroupMenuItem: handle is not a GTK_RADIO_MENU_ITEM');
Result:=false;
end;
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 TGtkWidgetSet.ReleaseCapture: Boolean;
begin
SetCapture(0);
Result := True;
end;
{------------------------------------------------------------------------------
Function: ReleaseDC
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtkWidgetSet.ReleaseDC(hWnd: HWND; DC: HDC): Integer;
var
aDC, pSavedDC: TDeviceContext;
g: TGDIType;
CurGDIObject: PGDIObject;
begin
//DebugLn('[TGtkWidgetSet.ReleaseDC] ',DbgS(DC),' ',FDeviceContexts.Count);
Assert(False, Format('trace:> [TGtkWidgetSet.ReleaseDC] DC:0x%x', [DC]));
Result := 0;
if (DC <> 0)
then begin
if FDeviceContexts.Contains(Pointer(DC))
then begin
aDC := TDeviceContext(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(['TGtkWidgetSet.ReleaseDC DC=',dbgs(TDeviceContext(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(CurGDIObject));
if aDC.OwnedGDIObjects[g]<>nil then
RaiseGDBException('');
end;
end;
//DebugLn(['TGtkWidgetSet.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 dont free}
if aDC.GC <> nil 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('TGtkWidgetSet.ReleaseDC: ',E.Message);
end;
end;
DisposeDC(aDC);
Result := 1;
end;
end;
Assert(False, Format('trace:< [TGtkWidgetSet.ReleaseDC] FDeviceContexts DC:0x%x', [DC]));
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 TGtkWidgetSet.RemoveProp(Handle: hwnd; Str: PChar): THandle;
begin
gtk_object_remove_data(pGTKObject(handle), Str);
Result := 1;
end;
{------------------------------------------------------------------------------
Function: RestoreDC
Params: none
Returns: Nothing
-------------------------------------------------------------------------------}
function TGtkWidgetSet.RestoreDC(DC: HDC; SavedDC: Integer): Boolean;
var
aDC, pSavedDC: TDeviceContext;
ClipRegionChanged: Boolean;
begin
Assert(False, Format('Trace:> [TGtkWidgetSet.RestoreDC] DC:0x%x, SavedDC: %d', [DC, SavedDC]));
Result := IsValidDC(DC) and (SavedDC > 0);
if not Result then exit;
while SavedDC>0 do begin
aDC:=TDeviceContext(DC);
pSavedDC:=aDC.SavedContext;
dec(SavedDC);
// TODO copy bitmap too
ClipRegionChanged:=aDC.ClipRegion<>pSavedDC.ClipRegion;
// clear the GDIObjects in pSavedDC, so they are not freed by DeleteDC
Result := CopyDCData(pSavedDC, aDC, true, true);
aDC.SavedContext := pSavedDC.SavedContext;
pSavedDC.SavedContext := nil;
if ClipRegionChanged then
SelectGDIRegion(HDC(aDC));
//DebugLn('TGtkWidgetSet.RestoreDC A ',GDKRegionAsString(PGdiObject(aDC.ClipRegion)^.GDIRegionObject));
// free saved DC
DeleteDC(HGDIOBJ(pSavedDC));
end;
Assert(False, Format('Trace:< [TGtkWidgetSet.RestoreDC] DC:0x%x, Saved: %d --> %s', [Integer(DC), SavedDC, BOOL_TEXT[Result]]));
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 TGtkWidgetSet.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 TGtkWidgetSet.SaveDC(DC: HDC): Integer;
var
aDC, aSavedDC: TDeviceContext;
begin
Assert(False, Format('Trace:> [TGtkWidgetSet.SaveDC] 0x%x', [Integer(DC)]));
Result := 0;
if IsValidDC(DC)
then begin
aDC := TDeviceContext(DC);
aSavedDC := NewDC;
CopyDCData(aDC,aSavedDC,false,true);
aSavedDC.SavedContext:=aDC.SavedContext;
aDC.SavedContext:= aSavedDC;
Result:=1;
end;
Assert(False, Format('Trace:< [TGtkWidgetSet.SaveDC] 0x%x --> %d', [Integer(DC), Result]));
end;
{------------------------------------------------------------------------------
Function: ScreenToClient
Params: Handle:
P:
Returns:
------------------------------------------------------------------------------}
Function TGtkWidgetSet.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(pgtkwidget(Handle));
if Widget = nil then
Widget := 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
gdk_window_get_origin(Window, @X, @Y)
else begin
X:=0;
Y:=0;
end;
{$IFDEF DebugGDKTraps}EndGDKErrorTrap;{$ENDIF}
end;
end;
//DebugLn('[TGtkWidgetSet.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 TGtkWidgetSet.ScrollWindowEx(hWnd: HWND; dx, dy: Integer; prcScroll, prcClip: PRect; hrgnUpdate: HRGN; prcUpdate: PRect; flags: UINT): Boolean;
begin
Result := False;
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 TGtkWidgetSet.SelectClipRGN(DC : hDC; RGN : HRGN) : Longint;
var
RegObj: PGdkRegion;
DCOrigin: TPoint;
OldClipRegion: PGDIObject;
begin
If not IsValidDC(DC) then begin
Result := ERROR;
exit;
end;
Result := SIMPLEREGION;
with TDeviceContext(DC) do
begin
// clear old clipregion
if ClipRegion<>nil then begin
OldClipRegion:=ClipRegion;
ClipRegion := nil;// decrease DCCount
if (OldClipRegion=OwnedGDIObjects[gdiRegion]) then
DeleteObject(HGDIOBJ(OldClipRegion));
end;
If (RGN = 0) then begin
SelectGDIRegion(DC);
end
else If IsValidGDIObject(RGN) then begin
ClipRegion := PGdiObject(CreateRegionCopy(RGN));
OwnedGDIObjects[gdiRegion]:=ClipRegion;
RegObj:=ClipRegion^.GDIRegionObject;
DCOrigin:=GetDCOffset(TDeviceContext(DC));
//DebugLn('TGtkWidgetSet.SelectClipRGN A RegObj=',GDKRegionAsString(RegObj),' DCOrigin=',dbgs(DCOrigin),' RGN=',GDKRegionAsString(PGdiObject(RGN)^.GDIRegionObject));
gdk_region_offset(RegObj,DCOrigin.x,DCOrigin.Y);
Result := RegionType(RegObj);
//DebugLn('TGtkWidgetSet.SelectClipRGN B RegObj=',GDKRegionAsString(RegObj),' DCOrigin=',dbgs(DCOrigin));
SelectGDIRegion(DC);
end
else begin
Result := ERROR;
DebugLn('WARNING: [TGtkWidgetSet.SelectClipRGN] Invalid RGN');
{$ifdef TraceGdiCalls}
DebugLn();
DebugLn('TraceCall for invalid object: ');
DumpBackTrace(PgdiObject(RGN)^.StackAddrs);
DebugLn();
{$endif}
end;
end;
end;
{------------------------------------------------------------------------------
Function: SelectObject
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtkWidgetSet.SelectObject(DC: HDC; GDIObj: HGDIOBJ): HGDIOBJ;
procedure RaiseInvalidGDIType;
begin
RaiseGDBException('TGtkWidgetSet.SelectObject Invalid GDIType '+IntToStr(ord(PGdiObject(GDIObj)^.GDIType)));
end;
procedure DebugInvalidGDIObject;
begin
DebugLn(['TGtkWidgetSet.SelectObject DC=',dbghex(DC),' IsValidDC(DC)=',IsValidDC(DC),' GDIObj=',dbghex(GDIObj),' IsValidGDIObject(GDIObj)=',IsValidGDIObject(GDIObj)]);
DumpStack;
{$IFDEF DebugLCLComponents}
if not IsValidDC(DC) then begin
DebugLn(['DebugInvalidGDIObject DC:']);
debugln(DebugDeviceContexts.GetInfo(Pointer(DC),true));
end;
if not IsValidGDIObject(GDIObj) then begin
DebugLn(['DebugInvalidGDIObject GDIObj:']);
debugln(DebugGdiObjects.GetInfo(Pointer(GDIObj),true));
end;
{$ENDIF}
end;
begin
Result := 0;
{if not IsValidDC(DC) then begin
DebugLn('TGtkWidgetSet.SelectObject invalid DC ',DbgS(DC));
end;
if not IsValidGDIObject(GDIObj) then begin
DebugLn('TGtkWidgetSet.SelectObject invalid GDIObj ',DbgS(GDIObj));
end;}
if IsValidDC(DC) and IsValidGDIObject(GDIObj)
then begin
//DebugLn('TGtkWidgetSet.SelectObject DC=',DbgS(DC),8),' GDIObj=',DbgS(Cardinal(GDIObj),' GDIType=',ord(PGdiObject(GDIObj)^.GDIType),' ',ord(gdiBitmap),' ',ord(gdiRegion));
case PGdiObject(GDIObj)^.GDIType of
gdiBitmap:
with TDeviceContext(DC) do
begin
Assert(False, Format('trace: [TGtkWidgetSet.SelectObject] DC: 0x%x, Type: Bitmap', [DC]));
Result := HBITMAP(GetBitmap);// always create, because a valid GDIObject is needed to restore
if CurrentBitmap<>PGDIObject(GDIObj) then begin
CurrentBitmap := PGDIObject(GDIObj);
with CurrentBitmap^ do
case GDIBitmapType of
gbPixmap: Drawable := GDIPixmapObject;
gbBitmap: Drawable := GDIBitmapObject;
else
Drawable := nil;
end;
if Drawable<>nil then begin
//DebugLn(['TGtkWidgetSet.SelectObject DC=',DbgS(Pointer(DC)),' GDIBitmap=',DbgS(CurrentBitmap),
//' GDIBitmapType=',ord(CurrentBitmap^.GDIBitmapType),' Drawable=',DbgS(Drawable)]);
if GC <> nil then begin
gdk_gc_unref(GC);
GC:=nil;
end;
GC := gdk_gc_new(Drawable);
gdk_gc_set_function(GC, GDK_COPY);
SelectedColors := dcscCustom;
end;
end;
end;
gdiBrush:
with TDeviceContext(DC), PGdiObject(GDIObj)^ do
begin
Assert(False, Format('trace: [TGtkWidgetSet.SelectObject] DC: 0x%x, Type: Brush', [DC]));
Result := HBRUSH(GetBrush);// always create, because a valid GDIObject is needed to restore
if CurrentBrush<>PGDIObject(GDIObj) then begin
CurrentBrush := PGDIObject(GDIObj);
gdk_gc_set_fill(GetGC, GDIBrushFill);
case GDIBrushFill of
GDK_STIPPLED: gdk_gc_set_stipple(GetGC, GDIBrushPixMap);
GDK_TILED: gdk_gc_set_tile(GetGC, GDIBrushPixMap);
end;
SelectedColors := dcscCustom;
end;
end;
gdiFont:
with TDeviceContext(DC) do
begin
Assert(False, Format('trace: [TGtkWidgetSet.SelectObject] DC: 0x%x, Type: Font', [DC]));
Result := HFONT(GetFont);// always create, because a valid GDIObject is needed to restore
if CurrentFont<> PGDIObject(GDIObj) then begin
//DebugLn(['TGtkWidgetSet.SelectObject DC=',dbghex(DC),' Font Old=',dbghex(PtrInt(CurrentFont)),' New=',dbghex(GDIObj)]);
//dumpstack;
CurrentFont := PGDIObject(GDIObj);
{$IfDef GTK1}
gdk_gc_set_font(GetGC, PGdiObject(GDIObj)^.GDIFontObject);
{$ENDIF}
Exclude(DCFlags,dcfTextMetricsValid);
SelectedColors := dcscCustom;
end;
end;
gdiPen:
with TDeviceContext(DC) do
begin
Result := HPEN(GetPen);// always create, because a valid GDIObject is needed to restore
if CurrentPen<> PGDIObject(GDIObj) then begin
CurrentPen := PGDIObject(GDIObj);
DCFlags:=DCFlags-[dcfPenSelected];
SelectGDKPenProps(DC);
SelectedColors := dcscCustom;
end;
end;
gdiRegion:
with TDeviceContext(DC) do
begin
Result := HRGN(ClipRegion);
SelectClipRGN(DC, GDIObj)
end;
else
RaiseInvalidGDIType;
end;
end else begin
{$IFDEF DebugLCLComponents}
DebugInvalidGDIObject;
{$ENDIF}
end;
//DebugLn('[TGtkWidgetSet.SelectObject] GDI=',DbgS(GDIObj),' Old=',DbgS(Result));
end;
{------------------------------------------------------------------------------
Function: SelectPalette
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtkWidgetSet.SelectPalette(DC: HDC; Palette: HPALETTE; ForceBackground: Boolean): HPALETTE;
begin
Assert(False, 'Trace:TODO: [TGtkWidgetSet.SelectPalette]');
//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 TGtkWidgetSet.SendMessage(HandleWnd: HWND; Msg: Cardinal; wParam: WParam;
lParam: LParam): LResult;
var
OldMsg: Cardinal;
procedure PreparePaintMessage(TargetObject: TObject; var AMessage: TLMessage);
var
GtkPaintData: TLMGtkPaintData;
OldGtkPaintMsg: TLMGtkPaint;
{$IFNDEF Gtk2}
PaintDC: HDC;
DCOrigin: TPoint;
{$ENDIF}
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('TGtkWidgetSet.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('TGtkWidgetSet.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));
{$IfNDef GTK2}
if (GtkPaintData<>nil) and (not GtkPaintData.RepaintAll) then begin
PaintDC:=TLMPaint(AMessage).DC;
DCOrigin:=GetDCOffset(TDeviceContext(PaintDC));
with GtkPaintData.Rect do
IntersectClipRect(PaintDC,Left-DCOrigin.X,Top-DCOrigin.Y,
Right-DCOrigin.X,Bottom-DCOrigin.Y);
end;
{$EndIf}
GtkPaintData.Free;
end;
end;
procedure DisposePaintMessage(TargetObject: TObject; var AMessage: TLMessage);
begin
if OldMsg=LM_GtkPAINT then begin
FinalizePaintMessage(@AMessage);
//if (csDesigning in TComponent(TargetObject).ComponentState)
//and (TargetObject is TWinControl) then
// SendPaintMessagesForInternalWidgets(TWinControl(TargetObject));
end else
if ((AMessage.Msg=LM_PAINT) or (AMessage.Msg=LM_INTERNALPAINT))
and (AMessage.WParam<>0) then begin
// free DC
ReleaseDC(0,AMessage.WParam);
AMessage.WParam:=0;
//if (csDesigning in TComponent(TargetObject).ComponentState)
//and (TargetObject is TWinControl) then
// SendPaintMessagesForInternalWidgets(TWinControl(TargetObject));
end;
end;
var
AMessage: TLMessage;
Target: TObject;
begin
OldMsg:=Msg;
AMessage.Msg := Msg;
AMessage.WParam := WParam;
AMessage.LParam := LParam;
AMessage.Result := 0;
Target := GetLCLObject(Pointer(HandleWnd));
if Target<>nil then begin
if (Msg=LM_PAINT) or (Msg=LM_GtkPaint) then begin
PreparePaintMessage(Target,AMessage);
end;
// deliver it
Result := DeliverMessage(Target, AMessage);
if (Msg=LM_PAINT) or (Msg=LM_INTERNALPAINT) or (Msg=LM_GtkPaint) then begin
DisposePaintMessage(Target,AMessage);
end;
end;
end;
{------------------------------------------------------------------------------
function SetActiveWindow(Handle: HWND): HWND;
------------------------------------------------------------------------------}
function TGtkWidgetSet.SetActiveWindow(Handle: HWND): HWND;
begin
// ToDo
Result:=GetActiveWindow;
end;
{------------------------------------------------------------------------------
Function: SetBkColor pbd
Params: DC: Device context to change the text background color
Color: RGB Tuple
Returns: Old Background color
------------------------------------------------------------------------------}
function TGtkWidgetSet.SetBKColor(DC: HDC; Color: TColorRef): TColorRef;
begin
Assert(False, Format('trace:> [TGtkWidgetSet.SetBKColor] DC: 0x%x Color: %8x', [Integer(DC), Color]));
Result := CLR_INVALID;
if IsValidDC(DC)
then begin
with TDeviceContext(DC) do
begin
Result := CurrentBackColor.ColorRef;
SetGDIColorRef(CurrentBackColor,Color);
end;
end;
Assert(False, Format('trace:< [TGtkWidgetSet.SetBKColor] DC: 0x%x Color: %8x --> %8x', [Integer(DC), Color, Result]));
end;
{------------------------------------------------------------------------------
Function: SetBkMode
Params: DC:
bkMode:
Returns:
------------------------------------------------------------------------------}
Function TGtkWidgetSet.SetBkMode(DC: HDC; bkMode : Integer) : Integer;
begin
// Your code here
Result:=0;
end;
{------------------------------------------------------------------------------
Function TGtkWidgetSet.SetComboMinDropDownSize(Handle: HWND;
MinItemsWidth, MinItemsHeight: integer): boolean;
------------------------------------------------------------------------------}
Function TGtkWidgetSet.SetComboMinDropDownSize(Handle: HWND;
MinItemsWidth, MinItemsHeight, MinItemCount: integer): boolean;
var
ComboWidget: PGtkCombo;
DropDownWidget, ListWidget, FirstChildWidget: PGtkWidget;
FirstChild: PGList;
CurX, CurY, CurWidth, CurHeight, CurItemHeight, BorderX, BorderY,
OldWidth, OldHeight,
NewWidth, NewHeight: integer;
ComboPopup: PGtkScrolledWindow;
item_requisition: TGtkRequisition;
begin
Result:=true;
if not (GtkWidgetIsA(PgtkWidget(Handle),GTK_TYPE_COMBO)) then
RaiseGDBException('TGtkWidgetSet.SetComboMinDropDownSize invalid handle');
// get current items width and height
ComboWidget:=PGtkCombo(Handle);
ListWidget:=ComboWidget^.List;
if ListWidget=nil then exit;
CurWidth:=ListWidget^.Allocation.Width;
// CurHeight:=ListWidget^.Allocation.Height;
CurHeight:=ListWidget^.requisition.Height;
if MinItemCount>0 then begin
FirstChild:=PGTkList(ListWidget)^.children;
if FirstChild<>nil then begin
FirstChildWidget:=PGtkWidget(FirstChild^.Data);
if FirstChildWidget<>nil then begin
gtk_widget_size_request(FirstChildWidget,@item_requisition);
CurItemHeight:=Max(FirstChildWidget^.Allocation.Height,
item_requisition.Height);
end else begin
CurItemHeight:=1;
end;
if MinItemsHeight<CurItemHeight*MinItemCount then
MinItemsHeight:=CurItemHeight*MinItemCount;
end;
end;
// calculate new width and height
DropDownWidget:=ComboWidget^.popwin;
if DropDownWidget=nil then exit;
ComboPopup:=PGtkScrolledWindow(ComboWidget^.popup);
if ComboPopup=nil then exit;
CurX:=DropDownWidget^.Allocation.x;
CurY:=DropDownWidget^.Allocation.y;
CurWidth:=pGtkWidget(ComboPopup)^.allocation.Width;
CurHeight:=pGtkWidget(ComboPopup)^.allocation.Height;
OldWidth:=DropDownWidget^.allocation.Width;
OldHeight:=DropDownWidget^.allocation.Height;
BorderX:=2*(OldWidth-CurWidth);
if BorderX<0 then BorderX:=0;
BorderY:=2*(OldHeight-CurHeight);
if BorderY<0 then BorderY:=0;
if Gtk_Widget_visible(ComboPopup^.hscrollbar) then
inc(BorderY, ComboPopup^.hscrollbar^.requisition.height
+GTK_SCROLLED_WINDOW_CLASS(gtk_object_get_class(comboWidget^.popup))^.scrollbar_spacing);
if Gtk_Widget_visible(ComboPopup^.vscrollbar) then
inc(BorderX,ComboPopup^.vscrollbar^.requisition.width
+GTK_SCROLLED_WINDOW_CLASS(gtk_object_get_class(comboWidget^.popup))^.scrollbar_spacing);
if minItemsWidth <>0 then NewWidth := MinItemsWidth+BorderX
else NewWidth := OldWidth;
if minItemsHeight<>0 then NewHeight := MinItemsHeight+BorderY
else NewHeight := OldHeight;
if (NewWidth=OldWidth) and (NewHeight=OldHeight) then exit;
NewWidth:=Min(NewWidth, Screen.Width - CurX);
NewHeight:=Min(NewHeight, Screen.Height - CurY);
if assigned(dropdownWidget^.Window) then
// widget is realized, resize gdkwindow directly
gdk_window_resize(dropdownwidget^.Window,newWidth,newHeight)
else
// widget is not yet realized, force resize needed for shrinking under gtk1)
gtk_widget_set_usize(PGtkWidget(dropDownWidget), -1,-1);
end;
{------------------------------------------------------------------------------
Function: SetCapture
Params: Value: Handle of window to capture
Returns: Nothing
------------------------------------------------------------------------------}
function TGtkWidgetSet.SetCapture(AHandle: HWND): HWND;
var
Widget: PGtkWidget;
begin
Assert(False, Format('Trace:> [TGtkWidgetSet.SetCapture] 0x%x', [AHandle]));
Widget := PGtkWidget(AHandle);
{$IfDef VerboseMouseCapture}
DebugLn('TGtkWidgetSet.SetCapture NewValue=[',GetWidgetDebugReport(Widget),']');
{$EndIf}
// return old capture handle
Result := GetCapture;
// capture
CaptureMouseForWidget(Widget, mctLCL);
end;
{------------------------------------------------------------------------------
Function: SetCaretPos
Params: new position x, y
Returns: true on success
------------------------------------------------------------------------------}
function TGtkWidgetSet.SetCaretPos(X, Y: Integer): Boolean;
var
FocusObject: PGTKObject;
begin
FocusObject := PGTKObject(GetFocus);
Result:=SetCaretPosEx(PtrInt(FocusObject),X,Y);
end;
{------------------------------------------------------------------------------
Function: SetCaretPos
Params: new position x, y
Returns: true on success
------------------------------------------------------------------------------}
function TGtkWidgetSet.SetCaretPosEx(Handle: HWNd; X, Y: Integer): Boolean;
var
GtkObject: PGTKObject;
begin
GtkObject := PGTKObject(Handle);
Result := GtkObject <> nil;
if Result then begin
if gtk_type_is_a(gtk_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 TGtkWidgetSet.SetCaretRespondToFocus(handle: HWND;
ShowHideOnFocus: boolean): Boolean;
begin
if handle<>0 then begin
if gtk_type_is_a(gtk_object_type(PGTKObject(handle)), GTKAPIWidget_GetType)
then begin
GTKAPIWidget_SetCaretRespondToFocus(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 TGtkWidgetSet.SetCursor(ACursor: HCURSOR): HCURSOR;
var
DefaultCursor: HCursor;
procedure SetGlobalCursor;
var
TopList, List: PGList;
begin
TopList := gdk_window_get_toplevels;
List := TopList;
while List <> nil do
begin
if (List^.Data <> nil) then
SetWindowCursor(PGDKWindow(List^.Data), ACursor, True);
list := g_list_next(list);
end;
if TopList <> nil then
g_list_free(TopList);
end;
procedure ResetGlobalCursor;
procedure SetToWindow(AWindow: PGDKWindow);
var
data: gpointer;
Widget: PGTKWidget absolute data;
WidgetInfo: PWidgetInfo;
WSPrivate: TWSPrivateClass;
begin
gdk_window_get_user_data(AWindow, @data);
if GtkWidgetIsA(Widget, gtk_widget_get_type)
then begin
WidgetInfo := GetWidgetInfo(Widget);
if (WidgetInfo <> nil)
and (WidgetInfo^.LCLObject <> nil)
and (WidgetInfo^.LCLObject is TWinControl)
then begin
WSPrivate := TWinControl(WidgetInfo^.LCLObject).WidgetSetClass.WSPrivate;
TGtkPrivateWidgetClass(WSPrivate).UpdateCursor(WidgetInfo);
Exit;
end;
end;
// no lcl cursor, so reset to default
gdk_window_set_cursor(AWindow, PGdkCursor(DefaultCursor));
end;
procedure Traverse(AWindow: PGDKWindow);
var
ChildWindows, ListEntry: PGList;
begin
SetToWindow(AWindow);
ChildWindows := gdk_window_get_children(AWindow);
ListEntry := ChildWindows;
while ListEntry <> nil do
begin
Traverse(PGdkWindow(ListEntry^.Data));
ListEntry := ListEntry^.Next;
end;
g_list_free(ChildWindows);
end;
var
TopList, List: PGList;
begin
TopList := gdk_window_get_toplevels;
List := TopList;
while List <> nil do
begin
if (List^.Data <> nil) then
Traverse(PGDKWindow(List^.Data));
list := g_list_next(list);
end;
if TopList <> nil then
g_list_free(TopList);
end;
begin
// set global gtk cursor
Result := FGlobalCursor;
if ACursor = FGlobalCursor then Exit;
DefaultCursor := Screen.Cursors[crDefault];
if ACursor <> DefaultCursor
then SetGlobalCursor
else ResetGlobalCursor;
FGlobalCursor := ACursor;
end;
{------------------------------------------------------------------------------
Function: SetCursorPos
Params: X:
Y:
Returns:
------------------------------------------------------------------------------}
function TGtkWidgetSet.SetCursorPos(X, Y: Integer): Boolean;
{$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 UNIX}
begin
Result := False;
DebugLn('TGtkWidgetSet.SetCursorPos not implemented for this platform');
// Can this call TWin32WidgetSet.SetCursorPos?
end;
{$ENDIF UNIX}
{------------------------------------------------------------------------------
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 TGtkWidgetSet.SetFocus(hWnd: HWND): HWND;
{off $DEFINE VerboseFocus}
var
Widget, TopLevel, NewFocusWidget: PGtkWidget;
{$IfDef VerboseFocus}
AWinControl: TWinControl;
{$EndIf}
NewTopLevelWidget: PGtkWidget;
NewTopLevelObject: TObject;
NewForm: TCustomForm;
begin
if hWnd=0 then exit;
Widget:=PGtkWidget(hWnd);
{$IfDef VerboseFocus}
DebugLn('');
debugln('[TGtkWidgetSet.SetFocus] A hWnd=',GetWidgetDebugReport(Widget));
{$EndIf}
if hwnd = 0 then begin
Result:=0;
exit;
end;
// return the old focus handle
Result := GetFocus;
NewFocusWidget:=nil;
TopLevel := gtk_widget_get_toplevel(Widget);
{$IfDef VerboseFocus}
Debugln('[TGtkWidgetSet.SetFocus] B');
DbgOut(' TopLevel=',DbgS(TopLevel));
DbgOut(' OldFocus=',GetWidgetDebugReport(PGtkWidget(Result)));
DebugLn('');
if not GTK_WIDGET_VISIBLE(Widget) then
Raise Exception('TGtkWidgetSet.SetFocus: Widget is not visible');
{$EndIf}
if Result=hWnd then exit;
if GtkWidgetIsA(TopLevel, gtk_window_get_type)
then begin
// TopLevel is a gtkwindow
{$IfDef VerboseFocus}
AWinControl:=TWinControl(GetNearestLCLObject(PGtkWindow(TopLevel)^.focus_widget));
write(' C TopLevel is a gtkwindow ');
write(' focus_widget=',DbgS(PGtkWindow(TopLevel)^.focus_widget));
if AWinControl<>nil then
write(' LCLParent=',AWinControl.Name,':',AWinControl.ClassName)
else
write(' LCLParent=nil');
DebugLn('');
{$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}
write(' G NewFocusWidget=',DbgS(NewFocusWidget),' ',DbgSName(GetNearestLCLObject(NewFocusWidget)));
write(' WidVisible=',GTK_WIDGET_VISIBLE(PGtkWidget(NewFocusWidget)));
write(' WidRealized=',GTK_WIDGET_REALIZED(PGtkWidget(NewFocusWidget)));
write(' WidMapped=',GTK_WIDGET_MAPPED(PGtkWidget(NewFocusWidget)));
write(' WidCanfocus=',GTK_WIDGET_CAN_FOCUS(PGtkWidget(NewFocusWidget)));
write(' 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)));
{$EndIf}
//DebugLn('TGtkWidgetSet.SetFocus TopLevel[',DebugGtkWidgets.GetInfo(TopLevel,false),'] NewFocusWidget=[',DebugGtkWidgets.GetInfo(NewFocusWidget,false),']');
gtk_window_set_focus(PGtkWindow(TopLevel),NewFocusWidget);
{$IfDef VerboseFocus}
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);
if (Screen<>nil)
and (Screen.GetCurrentModalForm<>nil)
and (GetNearestLCLObject(NewTopLevelWidget)<>Screen.GetCurrentModalForm)
then begin
{$IFDEF VerboseFocus}
DebugLn('[TGtkWidgetSet.SetFocus] there is a modal form -> not grabbing');
{$ENDIF}
end else begin
{$IfDef VerboseFocus}
DebugLn(' J Grabbing focus ',GetWidgetDebugReport(NewFocusWidget));
{$EndIf}
gtk_widget_grab_focus(NewFocusWidget);
end;
end;
{$IfDef VerboseFocus}
write('[TGtkWidgetSet.SetFocus] END hWnd=',DbgS(hWnd));
NewFocusWidget:=PGtkWidget(GetFocus);
write(' NewFocus=',DbgS(NewFocusWidget));
AWinControl:=TWinControl(GetNearestLCLObject(NewFocusWidget));
if AWinControl<>nil then
write(' NewLCLParent=',AWinControl.Name,':',AWinControl.ClassName)
else
write(' NewLCLParent=nil');
DebugLn('');
{$EndIf}
end;
{------------------------------------------------------------------------------
Function: SetForegroundWindow
Params: hWnd:
Returns:
------------------------------------------------------------------------------}
function TGtkWidgetSet.SetForegroundWindow(hWnd : HWND): boolean;
var
{$IFDEF VerboseFocus}
LCLObject: TControl;
{$ENDIF}
GdkWindow: PGdkWindow;
AForm: TCustomForm;
{$IFDEF GTK1}
FormWidget: PGtkWidget;
FormWindow: PGdkWindowPrivate;
WindowDesktop: Integer;
{$ENDIF}
begin
{$IFDEF VerboseFocus}
DbgOut('TGtkWidgetSet.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(PGtkWidget(hWnd),GTK_TYPE_WINDOW);
if Result then begin
GdkWindow:=GetControlWindow(PgtkWidget(hwnd));
if GdkWindow<>nil then begin
AForm:=TCustomForm(GetLCLObject(PgtkWidget(hwnd)));
if (AForm<>nil) and (AForm is TCustomForm) and (AForm.Parent=nil) then
begin
if Screen.CustomFormZIndex(AForm)<Screen.GetCurrentModalFormZIndex then
begin
debugln('TGtkWidgetSet.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);
{$IFDEF DebugGDKTraps}
EndGDKErrorTrap;
{$ENDIF}
{$IFDEF GTK1}
FormWidget:=PGtkWidget(AForm.Handle);
FormWindow:=PGdkWindowPrivate(FormWidget^.window);
if FormWindow<>nil then begin
WindowDesktop := GDK_WINDOW_GET_DESKTOP(FormWindow);
// this prevents the window from appearing on a different desktop
// which could be undesirable.
// check if the window is on all desktops or is on the current desktop
if (WindowDesktop < 0) or (WindowDesktop = GDK_GET_CURRENT_DESKTOP) then
begin
GDK_WINDOW_ACTIVATE(FormWindow);
end
else begin
// TODO: Figure out how to set the focus on an inactive desktop without
// bringing the window to the current desktop
end;
end;
{$ENDIF}
{$ifdef gtk2}
// this currently will bring the window to the current desktop and focus it
gtk_window_present(PGtkWindow(hWnd));
{$endif gtk2}
end;
end;
end;
{------------------------------------------------------------------------------
Function TGtkWidgetSet.SetProp(Handle: hwnd; Str : PChar;
Data : Pointer) : Boolean;
------------------------------------------------------------------------------}
function TGtkWidgetSet.SetProp(Handle: hwnd; Str : PChar; Data : Pointer) : Boolean;
begin
gtk_object_set_data(pGTKObject(handle),Str,data);
Result:=true;
end;
{------------------------------------------------------------------------------
Function TGtkWidgetSet.SetROPMode(Handle: hwnd; Str : PChar;
Data : Pointer) : Boolean;
------------------------------------------------------------------------------}
Function TGtkWidgetSet.SetROP2(DC: HDC; Mode: Integer) : Integer;
Begin
if IsValidDC(DC)
then with TDeviceContext(DC) do begin
Result := GetROP2(DC);
gdk_gc_set_function(GetGC, ROP2ModeToGdkFunction(Mode));
end else begin
Assert(False, 'Trace:[TGtkWidgetSet.SetROP2] Invalid DC');
Result := 0;
end;
end;
{------------------------------------------------------------------------------
Function: SetScrollInfo
Params: none
Returns: The old position value
------------------------------------------------------------------------------}
function TGtkWidgetSet.SetScrollInfo(Handle : HWND; SBStyle : Integer;
ScrollInfo: TScrollInfo; bRedraw : Boolean): Integer;
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;
gtk_range_set_update_policy(Range, UpdPolicy);
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;
const
POLICY: array[BOOLEAN] of TGTKPolicyType = (GTK_POLICY_NEVER, GTK_POLICY_ALWAYS);
var
Adjustment: PGtkAdjustment;
Layout: PgtkLayout;
Scroll: PGTKWidget;
IsScrollWindow: Boolean;
begin
Result := 0;
if (Handle = 0) then exit;
//DebugLn('TGtkWidgetSet.SetScrollInfo A Widget=',GetWidgetClassName(PGtkWidget(Handle)));
Scroll := gtk_object_get_data(PGTKObject(Handle), odnScrollArea);
if GtkWidgetIsA(Scroll, gtk_scrolled_window_get_type)
then begin
IsScrollWindow := True;
end
else begin
Scroll := PGTKWidget(Handle);
IsScrollWindow := GtkWidgetIsA(Scroll, gtk_scrolled_window_get_type);
end;
if IsScrollWindow
then begin
Layout := GetFixedWidget(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 gtk_layout_set_size(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, scrolbar 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 is 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 gtk_layout_set_size(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, scrolbar 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;
Result := Round(Adjustment^.Value);
if (ScrollInfo.fMask and SIF_POS) <> 0
then begin
Adjustment^.Value := ScrollInfo.nPos;
end;
if (ScrollInfo.fMask and SIF_RANGE) <> 0
then begin
Adjustment^.Lower := ScrollInfo.nMin;
Adjustment^.Upper := ScrollInfo.nMax;
end;
if (ScrollInfo.fMask and SIF_PAGE) <> 0
then begin
Adjustment^.Page_Size := ScrollInfo.nPage;
Adjustment^.Page_Increment := (ScrollInfo.nPage div 6)+1;
end;
{DebugLn('');
DebugLn('[TGtkWidgetSet.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
if IsScrollWindow
then begin
case SBStyle of
SB_HORZ: gtk_object_set(PGTKObject(Scroll),'hscrollbar_policy',[POLICY[bRedraw],nil]);
SB_VERT: gtk_object_set(PGTKObject(Scroll),'vscrollbar_policy',[POLICY[bRedraw],nil]);
end;
end
else begin
if (SBSTYLE = SB_CTL)
and GtkWidgetIsA(PGtkWidget(Scroll),gtk_widget_get_type) then
gtk_widget_show(PGTKWidget(Scroll))
else
gtk_widget_hide(PGTKWidget(Scroll))
end;
(*
DebugLn('TGtkWidgetSet.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 TGtkWidgetSet.SetSysColors(cElements: Integer; const lpaElements;
const lpaRgbValues): Boolean;
type
TLongArray = array[0..0] of Longint;
PLongArray = ^TLongArray;
var
n: Integer;
Element: LongInt;
begin
Result := False;
if cElements > MAX_SYS_COLORS then Exit;
for n := 0 to cElements - 1 do
begin
Element := PLongArray(lpaElements)^[n];
if (Element > MAX_SYS_COLORS)
or (Element < 0)
then Exit;
SysColorMap[PLongArray(lpaElements)^[n]] := PLongArray(lpaRgbValues)^[n];
//Assert(False, Format('Trace:[TGtkWidgetSet.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 TGtkWidgetSet.SetTextCharacterExtra(_hdc : 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 TGtkWidgetSet.SetTextColor(DC: HDC; Color: TColorRef): TColorRef;
begin
Assert(False, Format('trace:> [TGtkWidgetSet.SetTextColor] DC: 0x%x Color: %8x', [Integer(DC), Color]));
Result := CLR_INVALID;
if IsValidDC(DC)
then begin
with TDeviceContext(DC) do
begin
Result := CurrentTextColor.ColorRef;
SetGDIColorRef(CurrentTextColor,Color);
if Result<>Color then
SelectedColors := dcscCustom; // force SelectGDKTextProps to ensure text color
end;
end;
Assert(False, Format('trace:< [TGtkWidgetSet.SetTextColor] DC: 0x%x Color: %8x --> %8x', [Integer(DC), Color, Result]));
end;
{------------------------------------------------------------------------------
Procedure: SetWindowLong
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtkWidgetSet.SetWindowLong(Handle: HWND; Idx: Integer;
NewLong: PtrInt): PtrInt;
var
Data: Pointer;
begin
//TODO: Finish this;
Assert(False, Format('Trace:> [TGtkWidgetSet.SETWINDOWLONG] HWND: 0x%x, idx: 0x%x(%d), Value: 0x%x(%d)', [Handle, idx, idx, newlong, newlong]));
Result:=0;
Data := Pointer(NewLong);
case idx of
GWL_WNDPROC :
begin
gtk_object_set_data(pgtkobject(Handle),'WNDPROC',Data);
end;
GWL_HINSTANCE :
begin
gtk_object_set_data(pgtkobject(Handle),'HINSTANCE',Data);
end;
GWL_HWNDPARENT :
begin
gtk_object_set_data(pgtkobject(Handle),'HWNDPARENT',Data);
end;
GWL_STYLE :
begin
gtk_object_set_data(pgtkobject(Handle),'Style',Data);
end;
GWL_EXSTYLE :
begin
gtk_object_set_data(pgtkobject(Handle),'ExStyle',Data);
end;
GWL_USERDATA :
begin
gtk_object_set_data(pgtkobject(Handle),'Userdata',Data);
end;
GWL_ID :
begin
gtk_object_set_data(pgtkobject(Handle),'ID',Data);
end;
end; //case
Assert(False, Format('Trace:< [TGtkWidgetSet.SETWINDOWLONG] HWND: 0x%x, idx: 0x%x(%d), Value: 0x%x(%d) --> 0x%x(%d)', [Handle, idx, idx, newlong, newlong, Result, Result]));
end;
{------------------------------------------------------------------------------
Function TGtkWidgetSet.SetWindowOrgEx(DC : HDC; NewX, NewY : Integer;
OldPoint: PPoint) : Boolean;
Sets the DC offset for the specified device context.
------------------------------------------------------------------------------}
Function TGtkWidgetSet.SetWindowOrgEx(DC : HDC; NewX, NewY : Integer;
OldPoint: PPoint) : Boolean;
var
OldP: TPoint;
begin
//DebugLn('[TGtkWidgetSet.SetWindowOrgEx] ',NewX,' ',NewY);
GetWindowOrgEx(DC,@OldP);
Result := MoveWindowOrgEx(DC,NewX-OldP.X,NewY-OldP.Y);
if OldPoint<>nil then
OldPoint^:=OldP;
end;
{------------------------------------------------------------------------------
function TGtkWidgetSet.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 TGtkWidgetSet.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('TGtkWidgetSet.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('TGtkWidgetSet.SetWindowPos.SetZOrderOnFixedWidget WARNING: hWndInsertAfter=0');
exit;
end else begin
// hWndInsertAfter
AfterWidget:=PGtkWidget(hWndInsertAfter);
AfterListItem:=FindFixedChildListItem(PGtkFixed(FixedWidget),AfterWidget);
//debugln('AfterWidget=',GetWidgetDebugReport(AfterWidget));
end;
if (AfterListItem=nil) and (AfterWidget<>nil) then begin
DebugLn('TGtkWidgetSet.SetWindowPos.SetZOrderOnFixedWidget WARNING: AfterWidget not on parents fixed widget');
exit;
end;
if (OldListItem=AfterListItem) or (OldListItem^.next=AfterListItem) then
begin
{$IFDEF EnableGtkZReordering}
DebugLn('TGtkWidgetSet.SetWindowPos.SetZOrderOnFixedWidget Hint: Already there');
{$ENDIF}
exit;
end;
//DebugLn('TGtkWidgetSet.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('TGtkWidgetSet.SetWindowPos.SetZOrderOnFixedWidget resize ..');
gtk_widget_queue_resize(FixedWidget);
AfterListItem:=PGtkFixed(FixedWidget)^.children;
while AfterListItem<>nil do begin
AfterWidget:=GetFixedChildListWidget(AfterListItem);
DebugLn('TGtkWidgetSet.SetWindowPos.SetZOrderOnFixedWidget A ',GetWidgetDebugReport(AfterWidget));
AfterListItem:=AfterListItem^.next;
end;
end;
{$ENDIF}
end;
procedure SetZOrderOnLayoutWidget(Widget, LayoutWidget: PGtkWidget);
begin
//DebugLn('TGtkWidgetSet.SetWindowPos.SetZOrderOnLayoutWidget Not implemented: ZOrdering .. on ',GetWidgetDebugReport(LayoutWidget));
end;
var
Widget: PGTKWidget;
FixedWidget: PGtkWidget;
begin
Result:=false;
Widget:=PGtkWidget(hWnd);
{DebugLn('[TGtkWidgetSet.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
{ 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 else if (SWP_NOZORDER and uFlags)=0 then begin
FixedWidget:=Widget^.Parent;
if FixedWidget=nil then exit;
//DebugLn('TGtkWidgetSet.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('TGtkWidgetSet.SetWindowPos Not implemented: ZOrdering .. on ',GetWidgetDebugReport(FixedWidget));
exit;
end;
end;
Result:=true;
end;
{------------------------------------------------------------------------------
Function: ShowCaret
Params: none
Returns: Nothing
------------------------------------------------------------------------------}
function TGtkWidgetSet.ShowCaret(hWnd: HWND): Boolean;
var
GTKObject: PGTKObject;
begin
Assert(False, Format('Trace:> [TGtkWidgetSet.ShowCaret] HWND: 0x%x', [hWnd]));
GTKObject := PGTKObject(HWND);
Result := GTKObject <> nil;
if Result
then begin
if gtk_type_is_a(gtk_object_type(GTKObject), GTKAPIWidget_GetType)
then begin
GTKAPIWidget_ShowCaret(PGTKAPIWidget(GTKObject));
end
else begin
Result := False;
end;
end
else DebugLn('WARNING: [TGtkWidgetSet.ShowCaret] Got null HWND');
Assert(False, Format('Trace:< [TGtkWidgetSet.ShowCaret] HWND: 0x%x --> %s', [hWnd, BOOL_TEXT[Result]]));
end;
{------------------------------------------------------------------------------
Function: ShowScrollBar
Params: Wnd, wBar, bShow
Returns: Nothing
------------------------------------------------------------------------------}
function TGtkWidgetSet.ShowScrollBar(Handle: HWND; wBar: Integer;
bShow: Boolean): Boolean;
var
Widget: PGtkWidget;
NewPolicy: Integer;
begin
Assert(False, 'trace:[TGtkWidgetSet.ShowScrollBar]');
Result:=false;
Result := (Handle <> 0);
if Result then begin
Widget:=PGtkWidget(Handle);
if GtkWidgetIsA(Widget,gtk_scrolled_window_get_type) then begin
if wBar in [SB_BOTH, SB_HORZ] then begin
//DebugLn(['TGtkWidgetSet.ShowScrollBar ',GetWidgetDebugReport(Widget),' bShow=',bShow]);
if bShow then
NewPolicy:=GTK_POLICY_ALWAYS
else
NewPolicy:=GTK_POLICY_NEVER;
gtk_object_set(PGTKObject(Widget), '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;
gtk_object_set(PGTKObject(Widget), 'vscrollbar_policy', [NewPolicy,nil]);
end;
end
else begin
if (wBar = SB_CTL)
and gtk_type_is_a(gtk_object_type(PGTKObject(Handle)),gtk_widget_get_type)
then begin
if bShow
then gtk_widget_show(Widget)
else gtk_widget_hide(Widget);
end;
end;
end;
end;
{------------------------------------------------------------------------------
function ShowWindow(hWnd: HWND; nCmdShow: Integer): Boolean;
nCmdShow:
SW_SHOWNORMAL, SW_MINIMIZE, SW_SHOWMAXIMIZED
------------------------------------------------------------------------------}
function TGtkWidgetSet.ShowWindow(hWnd: HWND; nCmdShow: Integer): Boolean;
var
GtkWindow: PGtkWindow;
begin
Result:=false;
GtkWindow:=PGtkWindow(hWnd);
if GtkWindow=nil then
RaiseGDBException('TGtkWidgetSet.ShowWindow hWnd is nil');
if not GtkWidgetIsA(PGtkWidget(GtkWindow),GTK_TYPE_WINDOW) then
RaiseGDBException('TGtkWidgetSet.ShowWindow hWnd is not a gtkwindow');
{$IFDEF Gtk2}
// Implemented on gtk2winapi.inc
// This ifdef is necessary otherwise the gtk2 interface wont compile
{$ELSE}
case nCmdShow of
SW_SHOWNORMAL:
begin
{$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF}
gdk_window_show(PgtkWidget(GtkWindow)^.Window);
{$IFDEF DebugGDKTraps}EndGDKErrorTrap;{$ENDIF}
end;
SW_HIDE:
begin
gdk_window_hide(PgtkWidget(GtkWindow)^.Window);
end;
SW_MINIMIZE:
begin
GDK_WINDOW_MINIMIZE(PGdkWindowPrivate(PgtkWidget(GtkWindow)^.Window));
end;
SW_SHOWMAXIMIZED:
begin
GDK_WINDOW_MAXIMIZE(PGdkWindowPrivate(PgtkWidget(GtkWindow)^.Window));
end;
end;
{$ENDIF}
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 TGtkWidgetSet.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 TGtkWidgetSet.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: TextOut
Params: DC:
X:
Y:
Str:
Count:
Returns:
------------------------------------------------------------------------------}
Function TGtkWidgetSet.TextOut(DC: HDC; X,Y : Integer; Str : Pchar;
Count: Integer) : Boolean;
{$IfDef GTK2}
begin
DebugLn('TGtkWidgetSet.TextOut ToDo');
Result:=false;
end;
{$ELSE}
var
aRect : TRect;
txtpt : TPoint;
sz : TSize;
UseFont : PGDKFont;
Underline,
StrikeOut : Boolean;
DCOrigin: TPoint;
TempPen : hPen;
LogP : TLogPen;
Points : array[0..1] of TSize;
lbearing, rbearing, width, ascent,descent: LongInt;
begin
Result := IsValidDC(DC);
if Result and (Count>0)
then with TDeviceContext(DC) do
begin
UseFont:=GetGtkFont(TDeviceContext(DC));
if (CurrentFont = nil) or (CurrentFont^.GDIFontObject = nil)
then begin
Underline := False;
StrikeOut := False;
end
else begin
Underline := LongBool(CurrentFont^.LogFont.lfUnderline);
StrikeOut := LongBool(CurrentFont^.LogFont.lfStrikeOut);
end;
DCOrigin:=GetDCOffset(TDeviceContext(DC));
descent:=0;
gdk_text_extents(UseFont, Str, Count,
@lbearing, @rBearing, @width, @ascent, @descent);
sz.cx:=width;
Sz.cY :={$IFDEF Win32}
GDK_String_Height(UseFont, Str)
{$ELSE}
ascent+descent;
{$ENDIF}
aRect := Rect(X+DCOrigin.X,Y+DCOrigin.Y,X + Sz.CX, Sz.CY);
//DebugLn('TGtkWidgetSet.TextOut ',ARect.Left,',',ARect.Top,',',ARect.RIght,',',ARect.Bottom);
FillRect(DC,aRect,hBrush(GetBrush));
UpdateDCTextMetric(TDeviceContext(DC));
TxtPt.X := X;
{$IfDef Win32}
TxtPt.Y := Y + DCTextMetric.TextMetric.tmHeight div 2;
{$Else}
TxtPt.Y := Y + DCTextMetric.TextMetric.tmAscent;
{$EndIf}
SelectGDKTextProps(DC);
{$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF}
gdk_draw_text(Drawable, UseFont,
GetGC, TxtPt.X+DCOrigin.X, TxtPt.Y+DCOrigin.Y, Str, Count);
{$IFDEF DebugGDKTraps}EndGDKErrorTrap;{$ENDIF}
If Underline or StrikeOut then begin
{Create & select pen of font color}
LogP.lopnStyle := PS_SOLID;
LogP.lopnWidth.X := 1;
LogP.lopnColor := GetTextColor(DC);
TempPen := SelectObject(DC, CreatePenIndirect(LogP));
{Get line(s) horizontal position(s)}
Points[0].cX := X;
Points[1].cX := X + sz.cX;
{Draw line(s)}
If Underline then begin
Points[0].cY := Y + 2 + DCTextMetric.TextMetric.tmHeight -
DCTextMetric.TextMetric.tmDescent;
Points[1].cY := Points[0].cY;
Polyline(DC, PPoint(@Points[0]), 2);
end;
If StrikeOut then begin
Points[0].cY := Y + 2 + (TxtPt.Y - Y) div 2;
Points[1].cY := Points[0].cY;
Polyline(DC, PPoint(@Points[0]), 2);
end;
DeleteObject(SelectObject(DC, TempPen));
end;
Result := True;
end;
end;
{$EndIf}
{------------------------------------------------------------------------------
Function: WindowFromPoint
Params: Point: Specifies the x and y Coords
Returns: The handle of the gtkwidget. If none exist, then NULL is returned.
------------------------------------------------------------------------------}
Function TGtkWidgetSet.WindowFromPoint(Point : TPoint) : HWND;
var
ev : TgdkEvent;
Window : PgdkWindow;
Widget : PgtkWidget;
p: TPoint;
begin
Result := 0;
// !!!gdk_window_at_pointer changes the coordinates!!!
// -> using local variable p
p:=Point;
Window := gdk_window_at_pointer(@p.x,@p.Y);
if window <> nil then
begin
FillChar(ev,SizeOf(ev),0);
ev.any.window := Window;
Widget := gtk_get_event_widget(@ev);
Result := PtrInt(widget);
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 TGtkWidgetSet.InitializeCriticalSection(var CritSection: TCriticalSection);
{$IfDef pthread}
var
ACritSec: System.PRTLCriticalSection;
begin
New(ACritSec);
System.InitCriticalSection(ACritSec^);
CritSection:=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 TGtkWidgetSet.EnterCriticalSection(var CritSection: TCriticalSection);
{$IfDef pthread}
var
ACritSec: System.PRTLCriticalSection;
begin
ACritSec:=System.PRTLCriticalSection(CritSection);
System.EnterCriticalsection(ACritSec^);
end;
{var
Crit,
tmp : ppthread_mutex_t;
begin
New(Crit);
If CritSection <> 0 then
Try
Crit^ := ppthread_mutex_t(CritSection)^;
except
begin
CritSection := Longint(Crit);
exit;
end;
end;
pthread_mutex_lock(Crit^);
tmp := ppthread_mutex_t(CritSection);
CritSection := Longint(Crit);
Dispose(Tmp);
end;}
{$Else}
begin
end;
{$EndIf}
Procedure TGtkWidgetSet.LeaveCriticalSection(var CritSection: TCriticalSection);
{$IfDef pthread}
var
ACritSec: System.PRTLCriticalSection;
begin
ACritSec:=System.PRTLCriticalSection(CritSection);
System.LeaveCriticalsection(ACritSec^);
end;
{var
Crit,
tmp : ppthread_mutex_t;
begin
New(Crit);
If CritSection <> 0 then
Try
Crit^ := ppthread_mutex_t(CritSection)^;
except
begin
CritSection := Longint(Crit);
exit;
end;
end;
pthread_mutex_unlock(Crit^);
tmp := ppthread_mutex_t(CritSection);
CritSection := Longint(Crit);
Dispose(Tmp);
end;}
{$Else}
begin
end;
{$EndIf}
Procedure TGtkWidgetSet.DeleteCriticalSection(var CritSection: TCriticalSection);
{$IfDef pthread}
var
ACritSec: System.PRTLCriticalSection;
begin
ACritSec:=System.PRTLCriticalSection(CritSection);
System.DoneCriticalsection(ACritSec^);
Dispose(ACritSec);
CritSection:=0;
end;
{var
Crit,
tmp : ppthread_mutex_t;
begin
New(Crit);
If CritSection <> 0 then
Try
Crit^ := ppthread_mutex_t(CritSection)^;
except
begin
CritSection := Longint(Crit);
exit;
end;
end;
pthread_mutex_destroy(Crit^);
Dispose(Crit);
tmp := ppthread_mutex_t(CritSection);
CritSection := 0;
Dispose(Tmp);
end;}
{$Else}
begin
end;
{$EndIf}
{$IfDef ASSERT_IS_ON}
{$UNDEF ASSERT_IS_ON}
{$C-}
{$EndIf}
Reference in New Issue View Git Blame Copy Permalink