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