paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-05-02 00:43:41 +02:00
Code Issues Packages Projects Releases Wiki Activity
06ac76f560
lazarus/lcl/interfaces/gtk2/gtk2int.pas

1131 lines
34 KiB
ObjectPascal
Raw Blame History

{
/***************************************************************************
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, //XUtil,
{$EndIf}
{$EndIf}
gdk2pixbuf, gtk2, gdk2, glib2, Pango,
// LCL
Maps, LazFileUtils, Dialogs, Controls, Forms, LCLStrConsts,
LMessages, LCLProc, LazUTF8, LCLIntf, LCLType, DynHashArray, GraphType, GraphMath,
Graphics, Menus, Themes, WSLCLClasses,
Buttons, StdCtrls, CheckLst,
ComCtrls, Spin,
ExtCtrls, LResources,
InterfaceBase,
Gtk2WinApiWindow,
Gtk2Globals, Gtk2Proc,
Gtk2Def, Gtk2FontCache, Gtk2Extra,
Gtk2MsgQueue;
type
{ TGtk2WidgetSet }
TGtk2WidgetSet = class(TWidgetSet)
private
{$IFNDEF USE_GTK_MAIN_OLD_ITERATION}
FMainPoll: PGPollFD;
{$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 he 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);
// 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) : THandle; override;
function DestroyTimer(TimerHandle: THandle) : boolean; override;
procedure DestroyLCLComponent(Sender: TObject);
// notebook
{$IFDEF GTK2USEDUMMYNOTEBOOKPAGE}
procedure AddDummyNoteBookPage(NoteBookWidget: PGtkNoteBook);
{$ENDIF}
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;
{$ENDIF}
procedure Gtk2Create;
procedure Gtk2Destroy;
protected
function GetAppHandle: THandle; override;
public
constructor Create; override;
destructor Destroy; override;
function LCLPlatform: TLCLPlatform; 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 compositeManagerRunning: Boolean;
function GetDesktopWidget: PGtkWidget;
//function X11Raise(AHandle: HWND): boolean; currently not used
function GetWindowManager: String;
function IsCurrentDesktop(AWindow: PGdkWindow): Boolean;
function X11GetActiveWindow: HWND;
function GetAlwaysOnTopX11(AWindow: PGdkWindow): boolean;
procedure HideAllHints;
procedure RestoreAllHints;
{$ENDIF}
procedure StartFocusTimer;
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_;
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;
// 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 AnsiCompareText(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), False);
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 := AnsiCompareText(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}
// 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;
LastLeft:=EmptyLastMouseClick;
LastMiddle:=EmptyLastMouseClick;
LastRight:=EmptyLastMouseClick;
// 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.
Reference in New Issue View Git Blame Copy Permalink