{ /*************************************************************************** gtk2int.pas - GTK2 Interface Object ------------------------------------- ***************************************************************************/ ***************************************************************************** This file is part of the Lazarus Component Library (LCL) See the file COPYING.modifiedLGPL.txt, included in this distribution, for details about the license. ***************************************************************************** } unit Gtk2Int; {$mode objfpc}{$H+} interface {$ifdef Trace} {$ASSERTIONS ON} {$endif} {$I gtk2defines.inc} uses // RTL {$ifdef Unix} BaseUnix, Unix, {$endif} Types, Classes, SysUtils, Math, {$IfNDef GTK2_2} {$IfDef HasX} XLib, xatom, X, gdk2x, {$EndIf} {$EndIf} gdk2pixbuf, gtk2, gdk2, glib2, Pango, // LCL LMessages, LCLProc, LCLIntf, LCLType, Dialogs, Controls, Forms, LCLStrConsts, Graphics, Menus, Themes, Buttons, StdCtrls, CheckLst, ComCtrls, ExtCtrls, LCLPlatformDef, InterfaceBase, WSLCLClasses, WSControls, Gtk2WinApiWindow, Gtk2Globals, Gtk2Proc, Gtk2Def, Gtk2FontCache, Gtk2Extra, Gtk2MsgQueue, // LazUtils GraphType, GraphMath, LazFileUtils, LazUTF8, DynHashArray, Maps, IntegerList, LazLoggerBase, LazTracer, LazUtilities, LazStringUtils; type {$IFDEF HASX} { TDummyWidget } TDummyWidget = class(TObject) {needed for accurate frame on x11} private FFrameRect: TRect; FFirstPaintEvent: boolean; FWidget: PGtkWidget; public constructor Create; overload; destructor Destroy; override; function GetWidgetFrame: TRect; function ShowDummyWidget(const ALeft, ATop, AWidth, AHeight: integer): boolean; procedure SendToBack; procedure HideWidget; property Widget: PGtkWidget read FWidget write FWidget; end; {$ENDIF} { TGtk2WidgetSet } TGtk2WidgetSet = class(TWidgetSet) private {$IFNDEF USE_GTK_MAIN_OLD_ITERATION} FMainPoll: PGPollFD; {$ENDIF} {$IFDEF HASX} FIsWayland: boolean; {$ENDIF} FIsLibraryInstance: Boolean; FGtkTerminated: Boolean; FMultiThreadingEnabled: boolean; FocusTimer: cardinal; FLastFocusIn: PGtkWidget; FLastFocusOut: PGtkWidget; StayOnTopList: TMap; FAppActive: Boolean; FCachedTitleBarHeight: Integer; FCachedBorderSize: Integer; function GetAppActive: Boolean; function GetTitleBarHeight: Integer; procedure SetAppActive(const AValue: Boolean); protected function CreateThemeServices: TThemeServices; override; protected FKeyStateList_: TFPList; // Keeps track of which keys are pressed FDeviceContexts: TDynHashArray;// hasharray of HDC FGDIObjects: TDynHashArray; // hasharray of PGdiObject FMessageQueue: TGtkMessageQueue; // queue of PMsg (must be thread safe!) WaitingForMessages: boolean; MovedPaintMessageCount: integer;// how many paint messages moved to the end of the queue FRCFilename: string; FRCFileParsed: boolean; FRCFileAge: integer; FGTKToolTips: PGtkToolTips; FLogHandlerID: guint; // ID returend by set_handler FStockNullBrush: HBRUSH; FStockBlackBrush: HBRUSH; FStockLtGrayBrush: HBRUSH; FStockGrayBrush: HBRUSH; FStockDkGrayBrush: HBRUSH; FStockWhiteBrush: HBRUSH; FStockNullPen: HPEN; FStockBlackPen: HPEN; FStockWhitePen: HPEN; FSysColorBrushes: array[0..MAX_SYS_COLORS] of HBrush; FWaitHandles: PWaitHandleEventHandler; {$ifdef unix} FChildSignalHandlers: PChildSignalEventHandler; {$else} {$IFDEF VerboseGtkToDos}{$warning no declaration of FChildSignalHandlers for this OS}{$ENDIF} {$endif} FDefaultFontDesc: PPangoFontDescription; FDefaultFont: TGtkIntfFont; FStockSystemFont: HFONT; FExtUTF8OutCache: Pointer; FExtUTF8OutCacheSize: integer; FGlobalCursor: HCursor; FDCManager: TDeviceContextMemManager; FDockImage: PGtkWidget; FDragImageList: PGtkWidget; FDragImageListIcon: PGtkWidget; FDragHotStop: TPoint; public procedure InitStockItems; procedure FreeStockItems; procedure InitSystemColors; procedure InitSystemBrushes; procedure FreeSystemBrushes; procedure PassCmdLineOptions; override; {$ifdef Unix} procedure InitSynchronizeSupport; procedure ProcessChildSignal; procedure PrepareSynchronize({%H-}AObject: TObject); {$endif} procedure HandlePipeEvent(AData: PtrInt; AFlags: dword); // styles procedure FreeAllStyles; function GetCompStyle(Sender : TObject) : Longint; // create and destroy function CreateAPIWidget(AWinControl: TWinControl): PGtkWidget; function CreateSimpleClientAreaWidget(Sender: TObject; NotOnParentsClientArea: boolean): PGtkWidget; procedure DestroyEmptySubmenu(Sender: TObject); procedure DestroyConnectedWidget(Widget: PGtkWidget; CheckIfDestroying: boolean); function AllocateHWnd(Method: TLCLWndMethod): HWND; override; procedure DeallocateHWnd(Wnd: HWND); override; // clipboard procedure SetClipboardWidget(TargetWidget: PGtkWidget); // device contexts function IsValidDC(const DC: HDC): Boolean; function NewDC: TGtkDeviceContext; function FindDCWithGDIObject(GDIObject: PGdiObject): TGtkDeviceContext; procedure DisposeDC(aDC: TGtkDeviceContext); function CreateDCForWidget(AWidget: PGtkWidget; AWindow: PGdkWindow; AWithChildWindows: Boolean; ADoubleBuffer: PgdkDrawable = nil): HDC; // GDIObjects function IsValidGDIObject(const AGDIObj: HGDIOBJ): Boolean; function IsValidGDIObjectType(const GDIObject: HGDIOBJ; const GDIType: TGDIType): Boolean; function NewGDIObject(const GDIType: TGDIType): PGdiObject; procedure DisposeGDIObject(GdiObject: PGdiObject); function ReleaseGDIObject(GdiObject: PGdiObject): boolean; procedure ReferenceGDIObject(GdiObject: PGdiObject); function CreateDefaultBrush: PGdiObject; function CreateDefaultFont: PGdiObject; function CreateDefaultPen: PGdiObject; function CreateDefaultGDIBitmap: PGdiObject; procedure UpdateDCTextMetric(DC: TGtkDeviceContext); function GetDefaultFontDesc(IncreaseReferenceCount: boolean): PPangoFontDescription; function GetDefaultGtkFont(IncreaseReferenceCount: boolean): TGtkIntfFont; function GetGtkFont(DC: TGtkDeviceContext): TGtkIntfFont; function CreateRegionCopy(SrcRGN: hRGN): hRGN; override; function DCClipRegionValid(DC: HDC): boolean; override; function CreateEmptyRegion: hRGN; override; // images procedure LoadPixbufFromLazResource(const ResourceName: string; var Pixbuf: PGdkPixbuf); function InternalGetDIBits(DC: HDC; Bitmap: HBitmap; StartScan, NumScans: UINT; BitSize : Longint; Bits: Pointer; out BitInfo: BitmapInfo; Usage: UINT; DIB : Boolean): Integer; function RawImage_DescriptionFromDrawable(out ADesc: TRawImageDescription; ADrawable: PGdkDrawable; ACustomAlpha: Boolean): boolean; function RawImage_DescriptionFromPixbuf(out ADesc: TRawImageDescription; APixbuf: PGdkPixbuf): boolean; function RawImage_FromDrawable(out ARawImage: TRawImage; ADrawable, AAlpha: PGdkDrawable; ARect: PRect = nil): boolean; function RawImage_FromPixbuf(out ARawImage: TRawImage; APixbuf: PGdkPixbuf; ARect: PRect = nil): boolean; function RawImage_SetAlpha(var ARawImage: TRawImage; AAlpha: PGdkPixmap; ARect: PRect = nil): boolean; function RawImage_AddMask(var ARawImage: TRawImage; AMask: PGdkBitmap; ARect: PRect = nil): boolean; function StretchCopyArea(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc, SrcWidth, SrcHeight: Integer; Mask: HBITMAP; XMask, YMask: Integer; Rop: Cardinal): Boolean; // RC file procedure SetRCFilename(const AValue: string); procedure CheckRCFilename; procedure ParseRCFile; // forms and dialogs procedure BringFormToFront(Sender: TObject); procedure UntransientWindow(GtkWindow: PGtkWindow); // misc function GetCaption(Sender : TObject) : String; procedure WordWrap(DC: HDC; AText: PChar; MaxWidthInPixel: integer; out Lines: PPChar; out LineCount: integer); procedure ResizeChild(Sender : TObject; {%H-}Left,{%H-}Top,{%H-}Width,{%H-}Height : Integer); procedure RemoveCallbacks(Widget: PGtkWidget); // for gtk specific components: procedure SetWidgetColor(const AWidget: PGtkWidget; const FGColor, BGColor: TColor; const Mask: tGtkStateEnum); procedure SetCallbackDirect(const AMsg: LongInt; const AGTKObject: PGTKObject; const ALCLObject: TObject); procedure SetCallback(const AMsg: LongInt; const AGTKObject: PGTKObject; const ALCLObject: TObject); function LCLtoGtkMessagePending: boolean; procedure SendCachedGtkMessages; // show, hide and invalidate procedure SetVisible(Sender: TObject; const AVisible: Boolean); // Drag ImageLsit function DragImageList_BeginDrag(APixmap: PGdkPixmap; AMask: PGdkBitmap; AHotSpot: TPoint): Boolean; procedure DragImageList_EndDrag; function DragImageList_DragMove(X, Y: Integer): Boolean; function DragImageList_SetVisible(NewVisible: Boolean): Boolean; procedure UpdateTransientWindows; procedure SendCachedLCLMessages; override; function CreateTimer(Interval: integer; TimerProc: TWSTimerProc) : TLCLHandle; override; function DestroyTimer(TimerHandle: TLCLHandle) : boolean; override; procedure DestroyLCLComponent(Sender: TObject); // notebook procedure DCSetAntialiasing(CanvasHandle: HDC; AEnabled: Boolean); override; function DCGetPixel(CanvasHandle: HDC; X, Y: integer): TGraphicsColor; override; procedure DCSetPixel(CanvasHandle: HDC; X, Y: integer; AColor: TGraphicsColor); override; procedure DCRedraw(CanvasHandle: HDC); override; {used by 3rd party components eg. opengl implementation} procedure FinishCreateHandle(const AWinControl: TWinControl; Widget: PGtkWidget; const AParams: TCreateParams); private {$IFDEF HASX} FDesktopWidget: PGtkWidget; FMenuWidget: PGtkWidget; FWSFrameRect: TRect; {$ENDIF} procedure Gtk2Create; procedure Gtk2Destroy; procedure SetMenuWidget(const AValue: PGtkWidget); protected function GetAppHandle: TLCLHandle; override; public constructor Create; override; destructor Destroy; override; function LCLPlatform: TLCLPlatform; override; function GetLCLCapability(ACapability: TLCLCapability): PtrUInt; override; procedure AppInit(var ScreenInfo: TScreenInfo); override; procedure AppBringToFront; override; procedure AppMinimize; override; procedure AppRestore; override; function AppRemoveStayOnTopFlags(const ASystemTopAlso: Boolean = False): Boolean; override; function AppRestoreStayOnTopFlags(const ASystemTopAlso: Boolean = False): Boolean; override; procedure AppProcessMessages; override; procedure AppWaitMessage; override; procedure AppTerminate; override; procedure AppSetTitle(const {%H-}ATitle: string); override; procedure _SetCallbackEx(const AMsg: LongInt; const AGTKObject: PGTKObject; const ALCLObject: TObject; Direct: Boolean); procedure SetCallbackEx(const AMsg: LongInt; const AGTKObject: PGTKObject; const ALCLObject: TObject; Direct: Boolean); procedure SetCommonCallbacks(const AGTKObject: PGTKObject; const ALCLObject: TObject); procedure SetLabelCaption(const ALabel: PGtkLabel; const ACaption: String); procedure SetSelectionMode(Sender: TObject; Widget: PGtkWidget; MultiSelect, {%H-}ExtendedSelect: Boolean); function ForceLineBreaks(DC : hDC; Src: PChar; MaxWidthInPixels : Longint; ConvertAmpersandsToUnderScores: Boolean) : PChar; procedure SetWidgetFont(const AWidget: PGtkWidget; const AFont: TFont); {$I gtk2winapih.inc} {$I gtk2lclintfh.inc} public {$IFDEF HASX} function CreateDummyWidgetFrame(const ALeft, ATop, AWidth, AHeight: integer): boolean; function GetDummyWidgetFrame: TRect; function compositeManagerRunning: Boolean; function GetDesktopWidget: PGtkWidget; //function X11Raise(AHandle: HWND): boolean; currently not used function GetWindowManager: String; function IsWayland: boolean; function IsCurrentDesktop(AWindow: PGdkWindow): Boolean; function X11GetActiveWindow: HWND; function GetAlwaysOnTopX11(AWindow: PGdkWindow): boolean; procedure HideAllHints; procedure RestoreAllHints; {$ENDIF} procedure StartAppFocusTimer; procedure StopAppFocusTimer; property AppActive: Boolean read GetAppActive write SetAppActive; property IsLibraryInstance: Boolean read FIsLibraryInstance; property GtkIsTerminated: Boolean read FGtkTerminated; property LastFocusIn: PGtkWidget read FLastFocusIn write FLastFocusIn; property LastFocusOut: PGtkWidget read FLastFocusOut write FLastFocusOut; property MultiThreadingEnabled: boolean read FMultiThreadingEnabled; property KeyStateList: TFPList read FKeyStateList_; property MenuWidget: PGtkWidget read FMenuWidget write SetMenuWidget; end; {$I gtk2listslh.inc} { TGtkListStoreStringList } TGtkListStoreStringList = class(TStrings) private FChangeStamp: Integer; FColumnIndex: Integer; FGtkListStore: PGtkListStore; FOwner: TWinControl; FSorted: Boolean; FStates: TGtkListStringsStates; FCachedCount: Integer; FCachedCapacity: Integer; FCachedSize: Integer; FCachedItems: PGtkTreeIter; FUpdateCount: Integer; protected function GetCount: Integer; override; function Get(Index: Integer): String; override; function GetObject(Index: Integer): TObject; override; procedure Put(Index: Integer; const S: String); override; procedure PutObject(Index: Integer; AnObject: TObject); override; procedure SetSorted(Val: Boolean); procedure UpdateItemCache; procedure GrowCache; procedure ShrinkCache; procedure IncreaseChangeStamp; public constructor Create(AListStore: PGtkListStore; ColumnIndex: Integer; AOwner: TWinControl); destructor Destroy; override; function Add(const S: String): Integer; override; procedure Assign(Source: TPersistent); override; procedure Clear; override; procedure Delete(Index: Integer); override; function Find(const S: String; out Index: Integer): Boolean; function IndexOf(const S: String): Integer; override; procedure Insert(Index: Integer; const S: String); override; procedure Move(CurIndex, NewIndex: Integer); override; procedure Sort; function IsEqual(List: TStrings): Boolean; procedure BeginUpdate; procedure EndUpdate; public property Sorted: Boolean read FSorted write SetSorted; property Owner: TWinControl read FOwner; property ChangeStamp: Integer read FChangeStamp; end; var GTK2WidgetSet: TGTK2WidgetSet; procedure ExtractPangoFontFaceSuffixes(var AFontName: string; out AStretch: TPangoStretch; out AWeight: TPangoWeight); function AppendPangoFontFaceSuffixes(AFamilyName: string; AStretch: TPangoStretch; AWeight: TPangoWeight): string; function PangoFontHasItalicFace(context: PPangoContext; const familyName: String): Boolean; function GetPangoFontFamilyDefaultStretch(const AFamilyName: string): TPangoStretch; // Gtk2FileDialogUtils procedure ExtractFilterList(const Filter: string; out ListOfFileSelFilterEntry: TFPList; SplitMultiMask: boolean); procedure FreeListOfFileSelFilterEntry(ListOfFileSelFilterEntry: TFPList); implementation uses {%H-}Gtk2WSFactory{%H-}, {$ifdef Windows} Gtk2Windows, {$endif} Gtk2WSStdCtrls, Gtk2WSControls, Gtk2WSCheckLst, Gtk2WSPrivate, Gtk2Themes, //////////////////////////////////////////////////// {%H-}Gtk2Debug{%H-}; {$include gtk2widgetset.inc} {$include gtk2winapi.inc} {$include gtk2lclintf.inc} {*************************************************************} { TGtkListStoreStringList methods } {*************************************************************} {------------------------------------------------------------------------------ Method: TGtkListStoreStringList.Create Params: Returns: ------------------------------------------------------------------------------} constructor TGtkListStoreStringList.Create(AListStore: PGtkListStore; ColumnIndex: Integer; AOwner: TWinControl); begin inherited Create; if AListStore = nil then RaiseGDBException('TGtkListStoreStringList.Create Unspecified list store'); FGtkListStore := AListStore; if (ColumnIndex < 0) or (ColumnIndex >= gtk_tree_model_get_n_columns(GTK_TREE_MODEL(fGtkListStore))) then RaiseGDBException('TGtkListStoreStringList.Create Invalid Column Index'); FColumnIndex := ColumnIndex; if AOwner = nil then RaiseGDBException('TGtkListStoreStringList.Create Unspecified owner'); FOwner := AOwner; FStates := [glsItemCacheNeedsUpdate, glsCountNeedsUpdate]; end; destructor TGtkListStoreStringList.Destroy; begin FGtkListStore := nil; // don't destroy the widgets ReAllocMem(FCachedItems, 0); inherited Destroy; end; function TGtkListStoreStringList.Add(const S: String): Integer; begin if FSorted then Find(S, Result) else Result := Count; //DebugLn(['TGtkListStoreStringList.Add ',S,' Count=',Result]); Insert(Result, S); end; {------------------------------------------------------------------------------ Method: TGtkListStringList.SetSorted Params: Returns: ------------------------------------------------------------------------------} procedure TGtkListStoreStringList.SetSorted(Val: Boolean); var i: Integer; begin if Val = FSorted then Exit; FSorted := Val; if not FSorted then Exit; for i := 0 to Count - 2 do begin if DoCompareText(Strings[i], Strings[i + 1]) < 0 then begin Sort; Break; end; end; end; {------------------------------------------------------------------------------ procedure TGtkListStoreStringList.RemoveAllCallbacks; ------------------------------------------------------------------------------} procedure TGtkListStoreStringList.UpdateItemCache; var i: Integer; begin if not (glsItemCacheNeedsUpdate in FStates) then exit; //DebugLn(['TGtkListStoreStringList.UpdateItemCache ']); DumpStack; FCachedSize := Count; FCachedCapacity := Count; ReAllocMem(FCachedItems, SizeOf(TGtkTreeIter) * FCachedCapacity); if FGtkListStore <> nil then for I := 0 to FCachedSize - 1 do gtk_tree_model_iter_nth_child(GTK_TREE_MODEL(FGtkListStore), @FCachedItems[i], nil, I); Exclude(FStates, glsItemCacheNeedsUpdate); end; procedure TGtkListStoreStringList.GrowCache; begin FCachedCapacity := ((FCachedCapacity * 5) div 4) + 10; ReAllocMem(FCachedItems, SizeOf(TGtkTreeIter) * FCachedCapacity); end; procedure TGtkListStoreStringList.ShrinkCache; begin FCachedCapacity := FCachedSize + 1; ReAllocMem(FCachedItems, SizeOf(TGtkTreeIter) * FCachedCapacity); end; procedure TGtkListStoreStringList.IncreaseChangeStamp; begin if FChangeStamp < High(FChangeStamp) then Inc(FChangeStamp) else FChangeStamp := Low(FChangeStamp); end; procedure TGtkListStoreStringList.PutObject(Index: Integer; AnObject: TObject); var ListItem: TGtkTreeIter; begin if (Index < 0) or (Index >= Count) then begin RaiseGDBException('TGtkListStoreStringList.PutObject Out of bounds.'); Exit; end; if FGtkListStore = nil then Exit; UpdateItemCache; ListItem := FCachedItems[Index]; gtk_list_store_set(FGtkListStore, @ListItem, [FColumnIndex + 1, Pointer(AnObject), -1]); IncreaseChangeStamp; end; {------------------------------------------------------------------------------ Method: TGtkListStoreStringList.Sort Params: Returns: ------------------------------------------------------------------------------} procedure TGtkListStoreStringList.Sort; var sl: TStringList; OldSorted: Boolean; begin BeginUpdate; // sort internally (sorting in the widget would be slow and unpretty ;) sl := TStringList.Create; sl.Assign(Self); sl.Sort; OldSorted := Sorted; FSorted := False; Assign(sl); FSorted := OldSorted; sl.Free; EndUpdate; end; function TGtkListStoreStringList.IsEqual(List: TStrings): Boolean; var i, Cnt: Integer; begin if List = Self then Exit(True); if List = nil then Exit(False); Cnt := Count; if (Cnt <> List.Count) then Exit(False); for i := 0 to Cnt - 1 do begin if Strings[i] <> List[i] then Exit(False); if Objects[i] <> List.Objects[i] then Exit(False); end; Result := True; end; procedure TGtkListStoreStringList.BeginUpdate; begin Inc(FUpdateCount); end; procedure TGtkListStoreStringList.EndUpdate; begin Dec(FUpdateCount); end; {------------------------------------------------------------------------------ Method: TGtkListStoreStringList.Assign Params: Returns: ------------------------------------------------------------------------------} procedure TGtkListStoreStringList.Assign(Source: TPersistent); var i, Cnt: Integer; CmpList: TStrings; OldSorted: Boolean; begin if (Source = Self) or (Source = nil) then Exit; if ((Source is TGtkListStoreStringList) and (TGtkListStoreStringList(Source).FGtkListStore = FGtkListStore)) then RaiseGDBException('TGtkListStoreStringList.Assign: There are 2 lists with the same FGtkListStore'); BeginUpdate; OldSorted := Sorted; CmpList := nil; try if Source is TStrings then begin // clearing and resetting can change other properties of the widget, // => don't change if the content is already the same if Sorted then begin CmpList := TStringList.Create; CmpList.Assign(TStrings(Source)); TStringList(CmpList).Sort; end else CmpList := TStrings(Source); if IsEqual(CmpList) then Exit; Clear; FSorted := False; Cnt := TStrings(Source).Count; for i := 0 to Cnt - 1 do begin AddObject(CmpList[i], CmpList.Objects[i]); //DebugLn(['TGtkListStoreStringList.Assign ',i,' ',CmpList[i],' ',Count]); end; // ToDo: restore other settings // Do not call inherited Assign as it does things we do not want to happen end else inherited Assign(Source); finally fSorted := OldSorted; if CmpList <> Source then CmpList.Free; EndUpdate; end; end; {------------------------------------------------------------------------------ Method: TGtkListStoreStringList.Get Params: Returns: ------------------------------------------------------------------------------} function TGtkListStoreStringList.Get(Index: Integer): String; var Item: PChar; ListItem: TGtkTreeIter; begin if (Index < 0) or (Index >= Count) then begin RaiseGDBException('TGtkListStoreStringList.Get Out of bounds.'); Exit; end; UpdateItemCache; ListItem := FCachedItems[Index]; Item := nil; gtk_tree_model_get(GTK_TREE_MODEL(FGtkListStore), @ListItem, [FColumnIndex, @Item, -1]); if Item = nil then Exit(''); Result := Item; g_free(Item); end; function TGtkListStoreStringList.GetObject(Index: Integer): TObject; var ListItem: TGtkTreeIter; begin if (Index < 0) or (Index >= Count) then begin RaiseGDBException('TGtkListStoreStringList.GetObject Out of bounds.'); Exit(nil); end; if FGtkListStore = nil then Exit(nil); UpdateItemCache; ListItem := FCachedItems[Index]; gtk_tree_model_get(FGtkListStore, @ListItem, [FColumnIndex + 1, @Result, -1]); end; procedure TGtkListStoreStringList.Put(Index: Integer; const S: String); var ListItem: TGtkTreeIter; begin if (Index < 0) or (Index >= Count) then begin RaiseGDBException('TGtkListStoreStringList.Put Out of bounds.'); Exit; end; if FGtkListStore = nil then Exit; UpdateItemCache; ListItem := FCachedItems[Index]; gtk_list_store_set(FGtkListStore, @ListItem, [FColumnIndex, PChar(S), -1]); IncreaseChangeStamp; end; {------------------------------------------------------------------------------ Method: TGtkListStoreStringList.GetCount Params: Returns: ------------------------------------------------------------------------------} function TGtkListStoreStringList.GetCount: Integer; begin if (glsCountNeedsUpdate in FStates) then begin if FGtkListStore <> nil then FCachedCount := gtk_tree_model_iter_n_children(GTK_TREE_MODEL(FGtkListStore), nil) else FCachedCount := 0; Exclude(FStates, glsCountNeedsUpdate); end; Result := FCachedCount; end; {------------------------------------------------------------------------------ Method: TGtkListStoreStringList.Clear Params: Returns: ------------------------------------------------------------------------------} procedure TGtkListStoreStringList.Clear; var WidgetInfo: PWidgetInfo; begin //DebugLn(['TGtkListStoreStringList.Clear ']); //while Count>0 do Delete(Count-1); //Lock the widget to avoid trigger events //Note: Assign/Clear is called inside CreateHandle before Handle is set if FOwner.HandleAllocated then begin WidgetInfo := GetWidgetInfo({%H-}Pointer(FOwner.Handle)); Inc(WidgetInfo^.ChangeLock); gtk_list_store_clear(FGtkListStore); //resize columns to optimal width. See issue #17837 //TODO: see if this is needed by TComboBox and others. if FOwner is TListBox then gtk_tree_view_columns_autosize(PGtkTreeView(WidgetInfo^.CoreWidget)); Dec(WidgetInfo^.ChangeLock); //Update the internal Index cache PInteger(WidgetInfo^.UserData)^ := -1; end; IncreaseChangeStamp; ReAllocMem(FCachedItems, 0); FCachedCapacity := 0; FCachedSize := 0; Exclude(FStates, glsItemCacheNeedsUpdate); FCachedCount := 0; Exclude(FStates, glsCountNeedsUpdate); end; {------------------------------------------------------------------------------ Method: TGtkListStoreStringList.Delete Params: Returns: ------------------------------------------------------------------------------} procedure TGtkListStoreStringList.Delete(Index: Integer); var ListItem: TGtkTreeIter; WidgetInfo: PWidgetInfo; begin if not (glsItemCacheNeedsUpdate in FStates) then ListItem := FCachedItems[Index] else gtk_tree_model_iter_nth_child(FGtkListStore, @ListItem, nil, Index); //gtk_list_store_g WidgetInfo := GetWidgetInfo({%H-}Pointer(FOwner.Handle)); //Lock the widget to avoid trigger events Inc(WidgetInfo^.ChangeLock); gtk_list_store_remove(FGtkListStore, @ListItem); Dec(WidgetInfo^.ChangeLock); IncreaseChangeStamp; if not (glsCountNeedsUpdate in FStates) then Dec(FCachedCount); if (not (glsItemCacheNeedsUpdate in FStates)) and (Index = Count) then begin // cache is valid and the last item was deleted -> just remove last item Dec(FCachedSize); if (FCachedSize < FCachedCapacity div 2) then ShrinkCache; end else Include(FStates, glsItemCacheNeedsUpdate); if FOwner is TCustomComboBox then begin TGtk2WSCustomComboBox.SetText(FOwner, ''); //Update the internal Index cache PInteger(WidgetInfo^.UserData)^ := -1; end; end; function TGtkListStoreStringList.Find(const S: String; out Index: Integer): Boolean; var L, R, I: Integer; CompareRes: Integer; begin Result := False; // Use binary search. L := 0; R := Count - 1; while (L <= R) do begin I := L + (R - L) div 2; CompareRes := DoCompareText(S, Strings[I]); if (CompareRes > 0) then L := I + 1 else begin R := I - 1; if (CompareRes = 0) then begin Result := True; L := I; // forces end of while loop end; end; end; Index := L; end; function TGtkListStoreStringList.IndexOf(const S: String): Integer; begin Result := -1; BeginUpdate; if FSorted then begin //Binary Search if not Find(S, Result) then Result := -1; end else Result := inherited IndexOf(S); EndUpdate; end; {------------------------------------------------------------------------------ Method: TGtkListStoreStringList.Insert Params: Returns: ------------------------------------------------------------------------------} procedure TGtkListStoreStringList.Insert(Index: Integer; const S: String); var li: TGtkTreeIter; LCLIndex: PInteger; begin if (Index < 0) or (Index > Count) then begin RaiseGDBException('TGtkListStoreStringList.Insert: Index ' + IntToStr(Index) + ' out of bounds. Count=' + IntToStr(Count)); Exit; end; if Owner = nil then begin RaiseGDBException('TGtkListStoreStringList.Insert Unspecified owner'); Exit; end; BeginUpdate; try // this call is few times faster than gtk_list_store_insert, gtk_list_store_set gtk_list_store_insert_with_values(FGtkListStore, @li, Index, FColumnIndex, PChar(S), -1); IncreaseChangeStamp; //if the item is inserted before the selected item the //internal index cache becomes out of sync if (FOwner is TCustomComboBox) and FOwner.HandleAllocated then begin LCLIndex := PInteger(GetWidgetInfo({%H-}Pointer(FOwner.Handle))^.UserData); if Index <= LCLIndex^ then Inc(LCLIndex^); end; // ToDo: connect callbacks if not (glsCountNeedsUpdate in FStates) then Inc(FCachedCount); if (not (glsItemCacheNeedsUpdate in FStates)) and (Index = Count - 1) then begin // cache is valid and item was added as last // Add item to cache (instead of updating the whole cache) // This accelerates Assign. if FCachedSize = FCachedCapacity then GrowCache; FCachedItems[FCachedSize] := li; Inc(FCachedSize); end else Include(FStates, glsItemCacheNeedsUpdate); finally EndUpdate; end; end; procedure TGtkListStoreStringList.Move(CurIndex, NewIndex: Integer); const AState: Array[Boolean] of TCheckBoxState = (cbUnchecked, cbChecked); var AItemChecked: Boolean; begin if FOwner is TCheckListBox then AItemChecked := TCheckListBox(FOwner).Checked[CurIndex]; inherited Move(CurIndex, NewIndex); if FOwner is TCheckListBox then TGtk2WSCustomCheckListBox.SetState(TCustomCheckListBox(FOwner), NewIndex, AState[AItemChecked]); end; {$I gtk2listsl.inc} procedure ExtractPangoFontFaceSuffixes(var AFontName: string; out AStretch: TPangoStretch; out AWeight: TPangoWeight); var stretch, weight: integer; begin ExtractFontFaceSuffixes(AFontName, stretch, weight); AStretch := TPangoStretch(stretch); AWeight := TPangoWeight(weight); end; function AppendPangoFontFaceSuffixes(AFamilyName: string; AStretch: TPangoStretch; AWeight: TPangoWeight): string; var stretch: integer; begin if AStretch < PANGO_STRETCH_ULTRA_CONDENSED then stretch := FONT_STRETCH_ULTRA_CONDENSED else if AStretch > PANGO_STRETCH_ULTRA_EXPANDED then stretch := FONT_STRETCH_ULTRA_EXPANDED else stretch := integer(AStretch); result := AppendFontFaceSuffixes(AFamilyName, stretch, integer(AWeight)); end; function PangoFontHasItalicFace(context: PPangoContext; const familyName: String): Boolean; var families: PPPangoFontFamily; faces: PPPangoFontFace; num_families, num_faces, i, j: Integer; fontFamily: PPangoFontFamily; hasOblique, hasItalic: boolean; desc: PPangoFontDescription; begin Result := False; pango_context_list_families(context, @families, @num_families); for i := 0 to num_families - 1 do begin fontFamily := families[i]; if StrComp(pango_font_family_get_name(fontFamily), PChar(familyName)) = 0 then begin pango_font_family_list_faces(fontFamily, @faces, @num_faces); for j := 0 to num_faces - 1 do begin desc := pango_font_face_describe(faces[j]); if pango_font_description_get_style(desc) = PANGO_STYLE_ITALIC then begin Result := True; Break; end; end; g_free(faces); end; if Result then Break; end; g_free(families); end; function GetPangoFontFamilyDefaultStretch(const AFamilyName: string): TPangoStretch; begin result := TPangoStretch(GetFontFamilyDefaultStretch(AFamilyName)); end; // Gtk2FileDialogUtils {------------------------------------------------------------------------------ Function: ExtractFilterList Params: const Filter: string; var FilterIndex: integer; var ListOfPFileSelFilterEntry: TStringList Returns: - Converts a Delphi file filter of the form 'description1|mask1|description2|mask2|...' into a TFPList of PFileSelFilterEntry(s). Multi masks: - multi masks like '*.pas;*.pp' are converted into multiple entries. - if the masks are found in the description they are adjusted - if the mask is not included in the description it will be concatenated For example: 'Pascal files (*.pas;*.pp)|*.pas;*.lpr;*.pp; is converted to three filter entries: 'Pascal files (*.pas)' + '*.pas' 'Pascal files (*.pp)' + '*.pp' 'Pascal files (*.lpr)' + '*.lpr' ------------------------------------------------------------------------------} procedure ExtractFilterList(const Filter: string; out ListOfFileSelFilterEntry: TFPList; SplitMultiMask: boolean); var Masks: TStringList; CurFilterIndex: integer; procedure ExtractMasks(const MultiMask: string); var CurMaskStart, CurMaskEnd: integer; s: string; begin if Masks=nil then Masks:=TStringList.Create else Masks.Clear; CurMaskStart:=1; while CurMaskStart<=length(MultiMask) do begin CurMaskEnd:=CurMaskStart; if SplitMultiMask then begin while (CurMaskEnd<=length(MultiMask)) and (MultiMask[CurMaskEnd]<>';') do inc(CurMaskEnd); end else begin CurMaskEnd:=length(MultiMask)+1; end; s:=Trim(copy(MultiMask,CurMaskStart,CurMaskEnd-CurMaskStart)); Masks.Add(s); CurMaskStart:=CurMaskEnd+1; end; end; procedure AddEntry(const Desc, Mask: string); var NewFilterEntry: TFileSelFilterEntry; begin NewFilterEntry:=TFileSelFilterEntry.Create(Desc,Mask); NewFilterEntry.FilterIndex:=CurFilterIndex; ListOfFileSelFilterEntry.Add(NewFilterEntry); end; // remove all but one masks from description string function RemoveOtherMasks(const Desc: string; MaskIndex: integer): string; var i, StartPos, EndPos: integer; begin Result:=Desc; for i:=0 to Masks.Count-1 do begin if i=MaskIndex then continue; StartPos:=Pos(Masks[i],Result); EndPos:=StartPos+length(Masks[i]); if StartPos<1 then continue; while (StartPos>1) and (Result[StartPos-1] in [' ',#9,';']) do dec(StartPos); while (EndPos<=length(Result)) and (Result[EndPos] in [' ',#9]) do inc(EndPos); if (StartPos>1) and (Result[StartPos-1]='(') and (EndPos<=length(Result)) then begin if (Result[EndPos]=')') then begin dec(StartPos); inc(EndPos); end else if Result[EndPos]=';' then begin inc(EndPos); end; end; System.Delete(Result,StartPos,EndPos-StartPos); end; end; procedure AddEntries(const Desc: string; MultiMask: string); var i: integer; CurDesc: string; begin ExtractMasks(MultiMask); for i:=0 to Masks.Count-1 do begin CurDesc:=RemoveOtherMasks(Desc,i); if (Masks.Count>1) and (Pos(Masks[i],CurDesc)<1) then begin if (CurDesc='') or (CurDesc[length(CurDesc)]<>' ') then CurDesc:=CurDesc+' '; CurDesc:=CurDesc+'('+Masks[i]+')'; end; //debugln('AddEntries ',CurDesc,' ',Masks[i]); AddEntry(CurDesc,Masks[i]); end; inc(CurFilterIndex); end; var CurDescStart, CurDescEnd, CurMultiMaskStart, CurMultiMaskEnd: integer; CurDesc, CurMultiMask: string; begin ListOfFileSelFilterEntry:=TFPList.Create; Masks:=nil; CurFilterIndex:=0; CurDescStart:=1; while CurDescStart<=length(Filter) do begin // extract next filter description CurDescEnd:=CurDescStart; while (CurDescEnd<=length(Filter)) and (Filter[CurDescEnd]<>'|') do inc(CurDescEnd); CurDesc:=copy(Filter,CurDescStart,CurDescEnd-CurDescStart); // extract next filter multi mask CurMultiMaskStart:=CurDescEnd+1; CurMultiMaskEnd:=CurMultiMaskStart; while (CurMultiMaskEnd<=length(Filter)) and (Filter[CurMultiMaskEnd]<>'|') do inc(CurMultiMaskEnd); CurMultiMask:=copy(Filter,CurMultiMaskStart,CurMultiMaskEnd-CurMultiMaskStart); if CurDesc='' then CurDesc:=CurMultiMask; // add filter(s) if (CurMultiMask<>'') or (CurDesc<>'') then AddEntries(CurDesc,CurMultiMask); // next filter CurDescStart:=CurMultiMaskEnd+1; end; Masks.Free; end; procedure FreeListOfFileSelFilterEntry(ListOfFileSelFilterEntry: TFPList); var i: Integer; begin if ListOfFileSelFilterEntry=nil then exit; for i:=0 to ListOfFileSelFilterEntry.Count-1 do TObject(ListOfFileSelFilterEntry[i]).Free; ListOfFileSelFilterEntry.Free; end; procedure InternalInit; var c: TClipboardType; begin gtk_handler_quark := g_quark_from_static_string('gtk-signal-handlers'); MouseCaptureWidget := nil; // clipboard ClipboardSelectionData:=TFPList.Create; for c:=Low(TClipboardType) to High(TClipboardType) do begin ClipboardTypeAtoms[c]:=0; ClipboardHandler[c]:=nil; //ClipboardIgnoreLossCount[c]:=0; ClipboardTargetEntries[c]:=nil; ClipboardTargetEntryCnt[c]:=0; end; // charset encodings CharSetEncodingList := TList.Create; CreateDefaultCharsetEncodings; InitDesignSignalMasks; end; procedure InternalFinal; var i: integer; ced: PClipboardEventData; c: TClipboardType; begin // clipboard for i:=0 to ClipboardSelectionData.Count-1 do begin ced:=PClipboardEventData(ClipboardSelectionData[i]); FreeMem(ced^.Data.Data); Dispose(ced); end; for c:=Low(TClipboardType) to High(TClipboardType) do FreeClipboardTargetEntries(c); FreeAndNil(ClipboardSelectionData); // charset encodings if CharSetEncodingList<>nil then begin ClearCharSetEncodings; FreeAndNil(CharSetEncodingList); end; end; initialization InternalInit; finalization InternalFinal; end.