1 {
2  /***************************************************************************
3                        gtk2int.pas  -  GTK2 Interface Object
4                        -------------------------------------
5 
6 
7  ***************************************************************************/
8 
9  *****************************************************************************
10   This file is part of the Lazarus Component Library (LCL)
11 
12   See the file COPYING.modifiedLGPL.txt, included in this distribution,
13   for details about the license.
14  *****************************************************************************
15  }
16 
17 unit Gtk2Int;
18 
19 {$mode objfpc}{$H+}
20 
21 interface
22 
23 {$ifdef Trace}
24 {$ASSERTIONS ON}
25 {$endif}
26 
27 {$I gtk2defines.inc}
28 
29 uses
30   // RTL
31   {$ifdef Unix}
32   BaseUnix, Unix,
33   {$endif}
34   Types, Classes, SysUtils, Math,
35   {$IfNDef GTK2_2}
36     {$IfDef HasX}
37      XLib, xatom, X, gdk2x,
38     {$EndIf}
39   {$EndIf}
40   gdk2pixbuf, gtk2, gdk2, glib2, Pango,
41   // LCL
42   LMessages, LCLProc, LCLIntf, LCLType, Dialogs, Controls, Forms, LCLStrConsts,
43   Graphics, Menus, Themes, Buttons, StdCtrls, CheckLst, ComCtrls, ExtCtrls,
44   LCLPlatformDef, InterfaceBase,
45   WSLCLClasses, WSControls,
46   Gtk2WinApiWindow, Gtk2Globals, Gtk2Proc, Gtk2Def, Gtk2FontCache, Gtk2Extra, Gtk2MsgQueue,
47   // LazUtils
48   GraphType, GraphMath, LazFileUtils, LazUTF8, DynHashArray, Maps, IntegerList,
49   LazLoggerBase, LazTracer, LazUtilities, LazStringUtils;
50 
51 type
52 
53 {$IFDEF HASX}
54   { TDummyWidget }
55 
56   TDummyWidget = class(TObject) {needed for accurate frame on x11}
57   private
58     FFrameRect: TRect;
59     FFirstPaintEvent: boolean;
60     FWidget: PGtkWidget;
61   public
62     constructor Create; overload;
63     destructor Destroy; override;
GetWidgetFramenull64     function GetWidgetFrame: TRect;
ShowDummyWidgetnull65     function ShowDummyWidget(const ALeft, ATop, AWidth, AHeight: integer): boolean;
66     procedure SendToBack;
67     procedure HideWidget;
68     property Widget: PGtkWidget read FWidget write FWidget;
69   end;
70 {$ENDIF}
71 
72   { TGtk2WidgetSet }
73 
74   TGtk2WidgetSet = class(TWidgetSet)
75   private
76     {$IFNDEF USE_GTK_MAIN_OLD_ITERATION}
77     FMainPoll: PGPollFD;
78     {$ENDIF}
79     FIsLibraryInstance: Boolean;
80     FGtkTerminated: Boolean;
81     FMultiThreadingEnabled: boolean;
82     FocusTimer: cardinal;
83     FLastFocusIn: PGtkWidget;
84     FLastFocusOut: PGtkWidget;
85     StayOnTopList: TMap;
86     FAppActive: Boolean;
87     FCachedTitleBarHeight: Integer;
88     FCachedBorderSize: Integer;
GetAppActivenull89     function GetAppActive: Boolean;
GetTitleBarHeightnull90     function GetTitleBarHeight: Integer;
91     procedure SetAppActive(const AValue: Boolean);
92   protected
CreateThemeServicesnull93     function CreateThemeServices: TThemeServices; override;
94   protected
95     FKeyStateList_: TFPList; // Keeps track of which keys are pressed
96     FDeviceContexts: TDynHashArray;// hasharray of HDC
97     FGDIObjects: TDynHashArray;    // hasharray of PGdiObject
98     FMessageQueue: TGtkMessageQueue; // queue of PMsg (must be thread safe!)
99     WaitingForMessages: boolean;
100     MovedPaintMessageCount: integer;// how many paint messages moved to the end of the queue
101 
102     FRCFilename: string;
103     FRCFileParsed: boolean;
104     FRCFileAge: integer;
105     FGTKToolTips: PGtkToolTips;
106 
107     FLogHandlerID: guint; // ID returend by set_handler
108 
109     FStockNullBrush: HBRUSH;
110     FStockBlackBrush: HBRUSH;
111     FStockLtGrayBrush: HBRUSH;
112     FStockGrayBrush: HBRUSH;
113     FStockDkGrayBrush: HBRUSH;
114     FStockWhiteBrush: HBRUSH;
115 
116     FStockNullPen: HPEN;
117     FStockBlackPen: HPEN;
118     FStockWhitePen: HPEN;
119 
120     FSysColorBrushes: array[0..MAX_SYS_COLORS] of HBrush;
121 
122     FWaitHandles: PWaitHandleEventHandler;
123     {$ifdef unix}
124     FChildSignalHandlers: PChildSignalEventHandler;
125     {$else}
126     {$IFDEF VerboseGtkToDos}{$warning no declaration of FChildSignalHandlers for this OS}{$ENDIF}
127     {$endif}
128 
129     FDefaultFontDesc: PPangoFontDescription;
130     FDefaultFont: TGtkIntfFont;
131     FStockSystemFont: HFONT;
132     FExtUTF8OutCache: Pointer;
133     FExtUTF8OutCacheSize: integer;
134     FGlobalCursor: HCursor;
135 
136     FDCManager: TDeviceContextMemManager;
137     FDockImage: PGtkWidget;
138     FDragImageList: PGtkWidget;
139     FDragImageListIcon: PGtkWidget;
140     FDragHotStop: TPoint;
141   public
142     procedure InitStockItems;
143     procedure FreeStockItems;
144     procedure InitSystemColors;
145     procedure InitSystemBrushes;
146     procedure FreeSystemBrushes;
147     procedure PassCmdLineOptions; override;
148 
149     {$ifdef Unix}
150     procedure InitSynchronizeSupport;
151     procedure ProcessChildSignal;
152     procedure PrepareSynchronize({%H-}AObject: TObject);
153     {$endif}
154 
155     procedure HandlePipeEvent(AData: PtrInt; AFlags: dword);
156 
157     // styles
158     procedure FreeAllStyles;
GetCompStylenull159     function GetCompStyle(Sender : TObject) : Longint;
160 
161     // create and destroy
CreateAPIWidgetnull162     function CreateAPIWidget(AWinControl: TWinControl): PGtkWidget;
CreateSimpleClientAreaWidgetnull163     function CreateSimpleClientAreaWidget(Sender: TObject;
164       NotOnParentsClientArea: boolean): PGtkWidget;
165     procedure DestroyEmptySubmenu(Sender: TObject);
166     procedure DestroyConnectedWidget(Widget: PGtkWidget;
167                                      CheckIfDestroying: boolean);
168     // clipboard
169     procedure SetClipboardWidget(TargetWidget: PGtkWidget);
170 
171     // device contexts
IsValidDCnull172     function IsValidDC(const DC: HDC): Boolean;
NewDCnull173     function NewDC: TGtkDeviceContext;
FindDCWithGDIObjectnull174     function FindDCWithGDIObject(GDIObject: PGdiObject): TGtkDeviceContext;
175     procedure DisposeDC(aDC: TGtkDeviceContext);
CreateDCForWidgetnull176     function CreateDCForWidget(AWidget: PGtkWidget; AWindow: PGdkWindow;
177                                AWithChildWindows: Boolean; ADoubleBuffer: PgdkDrawable = nil): HDC;
178 
179     // GDIObjects
IsValidGDIObjectnull180     function IsValidGDIObject(const AGDIObj: HGDIOBJ): Boolean;
IsValidGDIObjectTypenull181     function IsValidGDIObjectType(const GDIObject: HGDIOBJ;
182                                   const GDIType: TGDIType): Boolean;
NewGDIObjectnull183     function NewGDIObject(const GDIType: TGDIType): PGdiObject;
184     procedure DisposeGDIObject(GdiObject: PGdiObject);
ReleaseGDIObjectnull185     function ReleaseGDIObject(GdiObject: PGdiObject): boolean;
186     procedure ReferenceGDIObject(GdiObject: PGdiObject);
CreateDefaultBrushnull187     function CreateDefaultBrush: PGdiObject;
CreateDefaultFontnull188     function CreateDefaultFont: PGdiObject;
CreateDefaultPennull189     function CreateDefaultPen: PGdiObject;
CreateDefaultGDIBitmapnull190     function CreateDefaultGDIBitmap: PGdiObject;
191     procedure UpdateDCTextMetric(DC: TGtkDeviceContext);
GetDefaultFontDescnull192     function GetDefaultFontDesc(IncreaseReferenceCount: boolean): PPangoFontDescription;
GetDefaultGtkFontnull193     function GetDefaultGtkFont(IncreaseReferenceCount: boolean): TGtkIntfFont;
GetGtkFontnull194     function GetGtkFont(DC: TGtkDeviceContext): TGtkIntfFont;
CreateRegionCopynull195     function CreateRegionCopy(SrcRGN: hRGN): hRGN; override;
DCClipRegionValidnull196     function DCClipRegionValid(DC: HDC): boolean; override;
CreateEmptyRegionnull197     function CreateEmptyRegion: hRGN; override;
198 
199     // images
200     procedure LoadPixbufFromLazResource(const ResourceName: string;
201       var Pixbuf: PGdkPixbuf);
InternalGetDIBitsnull202     function InternalGetDIBits(DC: HDC; Bitmap: HBitmap; StartScan, NumScans: UINT;
203       BitSize : Longint; Bits: Pointer; out BitInfo: BitmapInfo; Usage: UINT; DIB : Boolean): Integer;
RawImage_DescriptionFromDrawablenull204     function RawImage_DescriptionFromDrawable(out ADesc: TRawImageDescription; ADrawable: PGdkDrawable; ACustomAlpha: Boolean): boolean;
RawImage_DescriptionFromPixbufnull205     function RawImage_DescriptionFromPixbuf(out ADesc: TRawImageDescription; APixbuf: PGdkPixbuf): boolean;
RawImage_FromDrawablenull206     function RawImage_FromDrawable(out ARawImage: TRawImage; ADrawable, AAlpha: PGdkDrawable; ARect: PRect = nil): boolean;
RawImage_FromPixbufnull207     function RawImage_FromPixbuf(out ARawImage: TRawImage; APixbuf: PGdkPixbuf; ARect: PRect = nil): boolean;
RawImage_SetAlphanull208     function RawImage_SetAlpha(var ARawImage: TRawImage; AAlpha: PGdkPixmap; ARect: PRect = nil): boolean;
RawImage_AddMasknull209     function RawImage_AddMask(var ARawImage: TRawImage; AMask: PGdkBitmap; ARect: PRect = nil): boolean;
StretchCopyAreanull210     function StretchCopyArea(DestDC: HDC; X, Y, Width, Height: Integer;
211       SrcDC: HDC; XSrc, YSrc, SrcWidth, SrcHeight: Integer;
212       Mask: HBITMAP; XMask, YMask: Integer;
213       Rop: Cardinal): Boolean;
214 
215     // RC file
216     procedure SetRCFilename(const AValue: string);
217     procedure CheckRCFilename;
218     procedure ParseRCFile;
219 
220     // forms and dialogs
221     procedure BringFormToFront(Sender: TObject);
222     procedure UntransientWindow(GtkWindow: PGtkWindow);
223     // misc
GetCaptionnull224     function GetCaption(Sender : TObject) : String;
225     procedure WordWrap(DC: HDC; AText: PChar; MaxWidthInPixel: integer;
226       out Lines: PPChar; out LineCount: integer);
227 
228     procedure ResizeChild(Sender : TObject; {%H-}Left,{%H-}Top,{%H-}Width,{%H-}Height : Integer);
229     procedure RemoveCallbacks(Widget: PGtkWidget);
230 
231     // for gtk specific components:
232     procedure SetWidgetColor(const AWidget: PGtkWidget;
233                              const FGColor, BGColor: TColor;
234                              const Mask: tGtkStateEnum);
235     procedure SetCallbackDirect(const AMsg: LongInt; const AGTKObject: PGTKObject;
236                           const ALCLObject: TObject);
237     procedure SetCallback(const AMsg: LongInt; const AGTKObject: PGTKObject;
238                           const ALCLObject: TObject);
LCLtoGtkMessagePendingnull239     function  LCLtoGtkMessagePending: boolean;
240     procedure SendCachedGtkMessages;
241     // show, hide and invalidate
242     procedure SetVisible(Sender: TObject; const AVisible: Boolean);
243 
244     // Drag ImageLsit
DragImageList_BeginDragnull245     function DragImageList_BeginDrag(APixmap: PGdkPixmap; AMask: PGdkBitmap; AHotSpot: TPoint): Boolean;
246     procedure DragImageList_EndDrag;
DragImageList_DragMovenull247     function DragImageList_DragMove(X, Y: Integer): Boolean;
DragImageList_SetVisiblenull248     function DragImageList_SetVisible(NewVisible: Boolean): Boolean;
249 
250     procedure UpdateTransientWindows;
251     procedure SendCachedLCLMessages; override;
252 
CreateTimernull253     function CreateTimer(Interval: integer; TimerProc: TWSTimerProc) : THandle; override;
DestroyTimernull254     function DestroyTimer(TimerHandle: THandle) : boolean; override;
255     procedure DestroyLCLComponent(Sender: TObject);
256     // notebook
257 
258     procedure DCSetAntialiasing(CanvasHandle: HDC; AEnabled: Boolean); override;
DCGetPixelnull259     function  DCGetPixel(CanvasHandle: HDC; X, Y: integer): TGraphicsColor; override;
260     procedure DCSetPixel(CanvasHandle: HDC; X, Y: integer; AColor: TGraphicsColor); override;
261     procedure DCRedraw(CanvasHandle: HDC); override;
262     {used by 3rd party components eg. opengl implementation}
263     procedure FinishCreateHandle(const AWinControl: TWinControl;
264       Widget: PGtkWidget; const AParams: TCreateParams);
265 
266   private
267     {$IFDEF HASX}
268     FDesktopWidget: PGtkWidget;
269     FWSFrameRect: TRect;
270     {$ENDIF}
271     procedure Gtk2Create;
272     procedure Gtk2Destroy;
273 
274   protected
GetAppHandlenull275     function GetAppHandle: THandle; override;
276   public
277     constructor Create; override;
278     destructor Destroy; override;
279 
LCLPlatformnull280     function LCLPlatform: TLCLPlatform; override;
GetLCLCapabilitynull281     function GetLCLCapability(ACapability: TLCLCapability): PtrUInt; override;
282 
283     procedure AppInit(var ScreenInfo: TScreenInfo); override;
284     procedure AppBringToFront; override;
285     procedure AppMinimize; override;
286     procedure AppRestore; override;
AppRemoveStayOnTopFlagsnull287     function AppRemoveStayOnTopFlags(const ASystemTopAlso: Boolean = False): Boolean; override;
AppRestoreStayOnTopFlagsnull288     function AppRestoreStayOnTopFlags(const ASystemTopAlso: Boolean = False): Boolean; override;
289     procedure AppProcessMessages; override;
290     procedure AppWaitMessage; override;
291     procedure AppTerminate; override;
292     procedure AppSetTitle(const {%H-}ATitle: string); override;
293 
294     procedure _SetCallbackEx(const AMsg: LongInt; const AGTKObject: PGTKObject; const ALCLObject: TObject; Direct: Boolean);
295     procedure SetCallbackEx(const AMsg: LongInt; const AGTKObject: PGTKObject; const ALCLObject: TObject; Direct: Boolean);
296     procedure SetCommonCallbacks(const AGTKObject: PGTKObject; const ALCLObject: TObject);
297     procedure SetLabelCaption(const ALabel: PGtkLabel; const ACaption: String);
298     procedure SetSelectionMode(Sender: TObject; Widget: PGtkWidget;
299       MultiSelect, {%H-}ExtendedSelect: Boolean);
ForceLineBreaksnull300     function ForceLineBreaks(DC : hDC; Src: PChar; MaxWidthInPixels : Longint;
301                              ConvertAmpersandsToUnderScores: Boolean) : PChar;
302     procedure SetWidgetFont(const AWidget: PGtkWidget; const AFont: TFont);
303     {$I gtk2winapih.inc}
304     {$I gtk2lclintfh.inc}
305   public
306     {$IFDEF HASX}
CreateDummyWidgetFramenull307     function CreateDummyWidgetFrame(const ALeft, ATop, AWidth,
308       AHeight: integer): boolean;
GetDummyWidgetFramenull309     function GetDummyWidgetFrame: TRect;
310 
compositeManagerRunningnull311     function compositeManagerRunning: Boolean;
GetDesktopWidgetnull312     function GetDesktopWidget: PGtkWidget;
X11Raisenull313     //function X11Raise(AHandle: HWND): boolean; currently not used
314     function GetWindowManager: String;
IsCurrentDesktopnull315     function IsCurrentDesktop(AWindow: PGdkWindow): Boolean;
X11GetActiveWindownull316     function X11GetActiveWindow: HWND;
GetAlwaysOnTopX11null317     function GetAlwaysOnTopX11(AWindow: PGdkWindow): boolean;
318     procedure HideAllHints;
319     procedure RestoreAllHints;
320     {$ENDIF}
321     procedure StartFocusTimer;
322     property AppActive: Boolean read GetAppActive write SetAppActive;
323     property IsLibraryInstance: Boolean read FIsLibraryInstance;
324     property GtkIsTerminated: Boolean read FGtkTerminated;
325     property LastFocusIn: PGtkWidget read FLastFocusIn write FLastFocusIn;
326     property LastFocusOut: PGtkWidget read FLastFocusOut write FLastFocusOut;
327     property MultiThreadingEnabled: boolean read FMultiThreadingEnabled;
328     property KeyStateList: TFPList read FKeyStateList_;
329   end;
330 
331   {$I gtk2listslh.inc}
332 
333   { TGtkListStoreStringList }
334 
335   TGtkListStoreStringList = class(TStrings)
336   private
337     FChangeStamp: Integer;
338     FColumnIndex: Integer;
339     FGtkListStore: PGtkListStore;
340     FOwner: TWinControl;
341     FSorted: Boolean;
342     FStates: TGtkListStringsStates;
343     FCachedCount: Integer;
344     FCachedCapacity: Integer;
345     FCachedSize: Integer;
346     FCachedItems: PGtkTreeIter;
347     FUpdateCount: Integer;
348   protected
GetCountnull349     function GetCount: Integer; override;
Getnull350     function Get(Index: Integer): String; override;
GetObjectnull351     function GetObject(Index: Integer): TObject; override;
352     procedure Put(Index: Integer; const S: String); override;
353     procedure PutObject(Index: Integer; AnObject: TObject); override;
354     procedure SetSorted(Val: Boolean);
355     procedure UpdateItemCache;
356     procedure GrowCache;
357     procedure ShrinkCache;
358     procedure IncreaseChangeStamp;
359   public
360     constructor Create(AListStore: PGtkListStore;
361                        ColumnIndex: Integer; AOwner: TWinControl);
362     destructor Destroy; override;
Addnull363     function Add(const S: String): Integer; override;
364     procedure Assign(Source: TPersistent); override;
365     procedure Clear; override;
366     procedure Delete(Index: Integer); override;
Findnull367     function Find(const S: String; out Index: Integer): Boolean;
IndexOfnull368     function IndexOf(const S: String): Integer; override;
369     procedure Insert(Index: Integer; const S: String); override;
370     procedure Move(CurIndex, NewIndex: Integer); override;
371     procedure Sort;
IsEqualnull372     function IsEqual(List: TStrings): Boolean;
373     procedure BeginUpdate;
374     procedure EndUpdate;
375   public
376     property Sorted: Boolean read FSorted write SetSorted;
377     property Owner: TWinControl read FOwner;
378     property ChangeStamp: Integer read FChangeStamp;
379   end;
380 
381 var
382   GTK2WidgetSet: TGTK2WidgetSet;
383 
384 
385 // Gtk2FileDialogUtils
386 
387 procedure ExtractFilterList(const Filter: string;
388   out ListOfFileSelFilterEntry: TFPList; SplitMultiMask: boolean);
389 procedure FreeListOfFileSelFilterEntry(ListOfFileSelFilterEntry: TFPList);
390 
391 implementation
392 
393 uses
394   {%H-}Gtk2WSFactory{%H-},
395 {$ifdef Windows}
396   Gtk2Windows,
397 {$endif}
398   Gtk2WSStdCtrls,
399   Gtk2WSControls,
400   Gtk2WSCheckLst,
401   Gtk2WSPrivate,
402   Gtk2Themes,
403 ////////////////////////////////////////////////////
404   {%H-}Gtk2Debug{%H-};
405 
406 {$include gtk2widgetset.inc}
407 {$include gtk2winapi.inc}
408 {$include gtk2lclintf.inc}
409 
410 
411 {*************************************************************}
412 {                      TGtkListStoreStringList methods             }
413 {*************************************************************}
414 
415 {------------------------------------------------------------------------------
416   Method: TGtkListStoreStringList.Create
417   Params:
418   Returns:
419 
420  ------------------------------------------------------------------------------}
421 constructor TGtkListStoreStringList.Create(AListStore: PGtkListStore;
422   ColumnIndex: Integer; AOwner: TWinControl);
423 begin
424   inherited Create;
425   if AListStore = nil
426   then RaiseGDBException('TGtkListStoreStringList.Create Unspecified list store');
427 
428   FGtkListStore := AListStore;
429 
430   if (ColumnIndex < 0)
431   or (ColumnIndex >= gtk_tree_model_get_n_columns(GTK_TREE_MODEL(fGtkListStore)))
432   then RaiseGDBException('TGtkListStoreStringList.Create Invalid Column Index');
433   FColumnIndex := ColumnIndex;
434 
435   if AOwner = nil
436   then RaiseGDBException('TGtkListStoreStringList.Create Unspecified owner');
437   FOwner := AOwner;
438   FStates := [glsItemCacheNeedsUpdate, glsCountNeedsUpdate];
439 end;
440 
441 destructor TGtkListStoreStringList.Destroy;
442 begin
443   FGtkListStore := nil;
444   // don't destroy the widgets
445   ReAllocMem(FCachedItems, 0);
446   inherited Destroy;
447 end;
448 
Addnull449 function TGtkListStoreStringList.Add(const S: String): Integer;
450 begin
451   if FSorted then
452     Find(S, Result)
453   else
454     Result := Count;
455 
456   //DebugLn(['TGtkListStoreStringList.Add ',S,' Count=',Result]);
457   Insert(Result, S);
458 end;
459 
460 {------------------------------------------------------------------------------
461   Method: TGtkListStringList.SetSorted
462   Params:
463   Returns:
464 
465  ------------------------------------------------------------------------------}
466 procedure TGtkListStoreStringList.SetSorted(Val: Boolean);
467 var
468   i: Integer;
469 begin
470   if Val = FSorted then Exit;
471 
472   FSorted := Val;
473   if not FSorted then Exit;
474 
475   for i := 0 to Count - 2 do
476   begin
477     if DoCompareText(Strings[i], Strings[i + 1]) < 0 then
478     begin
479       Sort;
480       Break;
481     end;
482   end;
483 end;
484 
485 {------------------------------------------------------------------------------
486   procedure TGtkListStoreStringList.RemoveAllCallbacks;
487 
488  ------------------------------------------------------------------------------}
489 
490 procedure TGtkListStoreStringList.UpdateItemCache;
491 var
492   i: Integer;
493 begin
494   if not (glsItemCacheNeedsUpdate in FStates) then exit;
495 
496   //DebugLn(['TGtkListStoreStringList.UpdateItemCache ']); DumpStack;
497   FCachedSize := Count;
498   FCachedCapacity := Count;
499   ReAllocMem(FCachedItems, SizeOf(TGtkTreeIter) * FCachedCapacity);
500   if FGtkListStore <> nil then
501     for I := 0 to FCachedSize - 1 do
502       gtk_tree_model_iter_nth_child(GTK_TREE_MODEL(FGtkListStore),
503         @FCachedItems[i], nil, I);
504   Exclude(FStates, glsItemCacheNeedsUpdate);
505 end;
506 
507 procedure TGtkListStoreStringList.GrowCache;
508 begin
509   FCachedCapacity := ((FCachedCapacity * 5) div 4) + 10;
510   ReAllocMem(FCachedItems, SizeOf(TGtkTreeIter) * FCachedCapacity);
511 end;
512 
513 procedure TGtkListStoreStringList.ShrinkCache;
514 begin
515   FCachedCapacity := FCachedSize + 1;
516   ReAllocMem(FCachedItems, SizeOf(TGtkTreeIter) * FCachedCapacity);
517 end;
518 
519 procedure TGtkListStoreStringList.IncreaseChangeStamp;
520 begin
521   if FChangeStamp < High(FChangeStamp) then
522     Inc(FChangeStamp)
523   else
524     FChangeStamp := Low(FChangeStamp);
525 end;
526 
527 procedure TGtkListStoreStringList.PutObject(Index: Integer; AnObject: TObject);
528 var
529   ListItem: TGtkTreeIter;
530 begin
531   if (Index < 0) or (Index >= Count)
532   then begin
533     RaiseGDBException('TGtkListStoreStringList.PutObject Out of bounds.');
534     Exit;
535   end;
536 
537   if FGtkListStore = nil then Exit;
538 
539   UpdateItemCache;
540   ListItem := FCachedItems[Index];
541   gtk_list_store_set(FGtkListStore, @ListItem, [FColumnIndex + 1, Pointer(AnObject), -1]);
542   IncreaseChangeStamp;
543 end;
544 
545 {------------------------------------------------------------------------------
546   Method: TGtkListStoreStringList.Sort
547   Params:
548   Returns:
549 
550  ------------------------------------------------------------------------------}
551 procedure TGtkListStoreStringList.Sort;
552 var
553   sl: TStringList;
554   OldSorted: Boolean;
555 begin
556   BeginUpdate;
557   // sort internally (sorting in the widget would be slow and unpretty ;)
558   sl := TStringList.Create;
559   sl.Assign(Self);
560   sl.Sort;
561   OldSorted := Sorted;
562   FSorted := False;
563   Assign(sl);
564   FSorted := OldSorted;
565   sl.Free;
566   EndUpdate;
567 end;
568 
IsEqualnull569 function TGtkListStoreStringList.IsEqual(List: TStrings): Boolean;
570 var
571   i, Cnt: Integer;
572 begin
573   if List = Self then Exit(True);
574   if List = nil then Exit(False);
575 
576   Cnt := Count;
577   if (Cnt <> List.Count) then Exit(False);
578 
579   for i := 0 to Cnt - 1 do
580   begin
581     if Strings[i] <> List[i] then Exit(False);
582     if Objects[i] <> List.Objects[i] then Exit(False);
583   end;
584 
585   Result := True;
586 end;
587 
588 procedure TGtkListStoreStringList.BeginUpdate;
589 begin
590   Inc(FUpdateCount);
591 end;
592 
593 procedure TGtkListStoreStringList.EndUpdate;
594 begin
595   Dec(FUpdateCount);
596 end;
597 
598 {------------------------------------------------------------------------------
599   Method: TGtkListStoreStringList.Assign
600   Params:
601   Returns:
602 
603  ------------------------------------------------------------------------------}
604 procedure TGtkListStoreStringList.Assign(Source: TPersistent);
605 var
606   i, Cnt: Integer;
607   CmpList: TStrings;
608   OldSorted: Boolean;
609 begin
610   if (Source = Self) or (Source = nil) then Exit;
611 
612   if ((Source is TGtkListStoreStringList)
613   and (TGtkListStoreStringList(Source).FGtkListStore = FGtkListStore)) then
614     RaiseGDBException('TGtkListStoreStringList.Assign: There are 2 lists with the same FGtkListStore');
615 
616   BeginUpdate;
617   OldSorted := Sorted;
618   CmpList := nil;
619   try
620     if Source is TStrings then
621     begin
622       // clearing and resetting can change other properties of the widget,
623       // => don't change if the content is already the same
624       if Sorted then
625       begin
626         CmpList := TStringList.Create;
627         CmpList.Assign(TStrings(Source));
628         TStringList(CmpList).Sort;
629       end
630       else
631         CmpList := TStrings(Source);
632 
633       if IsEqual(CmpList) then Exit;
634 
635       Clear;
636       FSorted := False;
637       Cnt := TStrings(Source).Count;
638       for i := 0 to Cnt - 1 do
639       begin
640         AddObject(CmpList[i], CmpList.Objects[i]);
641         //DebugLn(['TGtkListStoreStringList.Assign ',i,' ',CmpList[i],' ',Count]);
642       end;
643       // ToDo: restore other settings
644 
645       // Do not call inherited Assign as it does things we do not want to happen
646     end
647     else
648       inherited Assign(Source);
649   finally
650     fSorted := OldSorted;
651     if CmpList <> Source
652     then CmpList.Free;
653 
654     EndUpdate;
655   end;
656 end;
657 
658 {------------------------------------------------------------------------------
659   Method: TGtkListStoreStringList.Get
660   Params:
661   Returns:
662 
663  ------------------------------------------------------------------------------}
TGtkListStoreStringList.Getnull664 function TGtkListStoreStringList.Get(Index: Integer): String;
665 var
666   Item: PChar;
667   ListItem: TGtkTreeIter;
668 begin
669   if (Index < 0) or (Index >= Count)
670   then begin
671     RaiseGDBException('TGtkListStoreStringList.Get Out of bounds.');
672     Exit;
673   end;
674 
675   UpdateItemCache;
676   ListItem := FCachedItems[Index];
677 
678   Item := nil;
679   gtk_tree_model_get(GTK_TREE_MODEL(FGtkListStore), @ListItem, [FColumnIndex, @Item, -1]);
680   if Item = nil then Exit('');
681 
682   Result := Item;
683   g_free(Item);
684 end;
685 
GetObjectnull686 function TGtkListStoreStringList.GetObject(Index: Integer): TObject;
687 var
688   ListItem: TGtkTreeIter;
689 begin
690   if (Index < 0) or (Index >= Count)
691   then begin
692     RaiseGDBException('TGtkListStoreStringList.GetObject Out of bounds.');
693     Exit(nil);
694   end;
695   if FGtkListStore = nil then Exit(nil);
696 
697   UpdateItemCache;
698   ListItem := FCachedItems[Index];
699   gtk_tree_model_get(FGtkListStore, @ListItem, [FColumnIndex + 1, @Result, -1]);
700 end;
701 
702 procedure TGtkListStoreStringList.Put(Index: Integer; const S: String);
703 var
704   ListItem: TGtkTreeIter;
705 begin
706   if (Index < 0) or (Index >= Count)
707   then begin
708     RaiseGDBException('TGtkListStoreStringList.Put Out of bounds.');
709     Exit;
710   end;
711   if FGtkListStore = nil then Exit;
712 
713   UpdateItemCache;
714   ListItem := FCachedItems[Index];
715   gtk_list_store_set(FGtkListStore, @ListItem, [FColumnIndex, PChar(S), -1]);
716   IncreaseChangeStamp;
717 end;
718 
719 {------------------------------------------------------------------------------
720   Method: TGtkListStoreStringList.GetCount
721   Params:
722   Returns:
723 
724  ------------------------------------------------------------------------------}
TGtkListStoreStringList.GetCountnull725 function TGtkListStoreStringList.GetCount: Integer;
726 begin
727   if (glsCountNeedsUpdate in FStates) then
728   begin
729     if FGtkListStore <> nil then
730       FCachedCount := gtk_tree_model_iter_n_children(GTK_TREE_MODEL(FGtkListStore), nil)
731     else
732       FCachedCount := 0;
733     Exclude(FStates, glsCountNeedsUpdate);
734   end;
735   Result := FCachedCount;
736 end;
737 
738 {------------------------------------------------------------------------------
739   Method: TGtkListStoreStringList.Clear
740   Params:
741   Returns:
742 
743  ------------------------------------------------------------------------------}
744 procedure TGtkListStoreStringList.Clear;
745 var
746   WidgetInfo: PWidgetInfo;
747 begin
748   //DebugLn(['TGtkListStoreStringList.Clear ']);
749   //while Count>0 do Delete(Count-1);
750 
751   //Lock the widget to avoid trigger events
752   //Note: Assign/Clear is called inside CreateHandle before Handle is set
753   if FOwner.HandleAllocated then
754   begin
755     WidgetInfo := GetWidgetInfo({%H-}Pointer(FOwner.Handle));
756     Inc(WidgetInfo^.ChangeLock);
757 
758     gtk_list_store_clear(FGtkListStore);
759 
760     //resize columns to optimal width. See issue #17837
761     //TODO: see if this is needed by TComboBox and others.
762     if FOwner is TListBox then
763       gtk_tree_view_columns_autosize(PGtkTreeView(WidgetInfo^.CoreWidget));
764 
765     Dec(WidgetInfo^.ChangeLock);
766     //Update the internal Index cache
767     PInteger(WidgetInfo^.UserData)^ := -1;
768   end;
769 
770   IncreaseChangeStamp;
771 
772   ReAllocMem(FCachedItems, 0);
773   FCachedCapacity := 0;
774   FCachedSize := 0;
775   Exclude(FStates, glsItemCacheNeedsUpdate);
776   FCachedCount := 0;
777   Exclude(FStates, glsCountNeedsUpdate);
778 end;
779 
780 {------------------------------------------------------------------------------
781   Method: TGtkListStoreStringList.Delete
782   Params:
783   Returns:
784 
785  ------------------------------------------------------------------------------}
786 procedure TGtkListStoreStringList.Delete(Index: Integer);
787 var
788   ListItem: TGtkTreeIter;
789   WidgetInfo: PWidgetInfo;
790 begin
791   if not (glsItemCacheNeedsUpdate in FStates) then
792     ListItem := FCachedItems[Index]
793   else
794     gtk_tree_model_iter_nth_child(FGtkListStore, @ListItem, nil, Index);
795 
796   //gtk_list_store_g
797   WidgetInfo := GetWidgetInfo({%H-}Pointer(FOwner.Handle));
798   //Lock the widget to avoid trigger events
799   Inc(WidgetInfo^.ChangeLock);
800   gtk_list_store_remove(FGtkListStore, @ListItem);
801   Dec(WidgetInfo^.ChangeLock);
802   IncreaseChangeStamp;
803 
804   if not (glsCountNeedsUpdate in FStates) then
805     Dec(FCachedCount);
806   if (not (glsItemCacheNeedsUpdate in FStates)) and (Index = Count) then
807   begin
808     // cache is valid and the last item was deleted -> just remove last item
809     Dec(FCachedSize);
810     if (FCachedSize < FCachedCapacity div 2) then
811       ShrinkCache;
812   end
813   else
814     Include(FStates, glsItemCacheNeedsUpdate);
815 
816   if FOwner is TCustomComboBox then
817   begin
818     TGtk2WSCustomComboBox.SetText(FOwner, '');
819     //Update the internal Index cache
820     PInteger(WidgetInfo^.UserData)^ := -1;
821   end;
822 end;
823 
TGtkListStoreStringList.Findnull824 function TGtkListStoreStringList.Find(const S: String; out Index: Integer): Boolean;
825 var
826   L, R, I: Integer;
827   CompareRes: Integer;
828 begin
829   Result := False;
830   // Use binary search.
831   L := 0;
832   R := Count - 1;
833   while (L <= R) do
834   begin
835     I := L + (R - L) div 2;
836     CompareRes := DoCompareText(S, Strings[I]);
837     if (CompareRes > 0) then
838       L := I + 1
839     else
840     begin
841       R := I - 1;
842       if (CompareRes = 0) then
843       begin
844         Result := True;
845         L := I; // forces end of while loop
846       end;
847     end;
848   end;
849   Index := L;
850 end;
851 
IndexOfnull852 function TGtkListStoreStringList.IndexOf(const S: String): Integer;
853 begin
854   Result := -1;
855   BeginUpdate;
856   if FSorted then
857   begin
858     //Binary Search
859     if not Find(S, Result) then
860       Result := -1;
861   end else
862     Result := inherited IndexOf(S);
863   EndUpdate;
864 end;
865 
866 {------------------------------------------------------------------------------
867   Method: TGtkListStoreStringList.Insert
868   Params:
869   Returns:
870 
871  ------------------------------------------------------------------------------}
872 procedure TGtkListStoreStringList.Insert(Index: Integer; const S: String);
873 var
874   li: TGtkTreeIter;
875   LCLIndex: PInteger;
876 begin
877   if (Index < 0) or (Index > Count)
878   then begin
879     RaiseGDBException('TGtkListStoreStringList.Insert: Index ' + IntToStr(Index) + ' out of bounds. Count=' + IntToStr(Count));
880     Exit;
881   end;
882 
883   if Owner = nil
884   then begin
885     RaiseGDBException('TGtkListStoreStringList.Insert Unspecified owner');
886     Exit;
887   end;
888 
889   BeginUpdate;
890   try
891     // this call is few times faster than gtk_list_store_insert, gtk_list_store_set
892     gtk_list_store_insert_with_values(FGtkListStore, @li, Index, FColumnIndex, PChar(S), -1);
893     IncreaseChangeStamp;
894 
895     //if the item is inserted before the selected item the
896     //internal index cache becomes out of sync
897     if (FOwner is TCustomComboBox) and FOwner.HandleAllocated then
898     begin
899       LCLIndex := PInteger(GetWidgetInfo({%H-}Pointer(FOwner.Handle))^.UserData);
900       if Index <= LCLIndex^ then
901         Inc(LCLIndex^);
902     end;
903 
904     // ToDo: connect callbacks
905 
906     if not (glsCountNeedsUpdate in FStates) then
907       Inc(FCachedCount);
908 
909     if (not (glsItemCacheNeedsUpdate in FStates)) and (Index = Count - 1) then
910     begin
911       // cache is valid and item was added as last
912       // Add item to cache (instead of updating the whole cache)
913       // This accelerates Assign.
914       if FCachedSize = FCachedCapacity then GrowCache;
915       FCachedItems[FCachedSize] := li;
916       Inc(FCachedSize);
917     end
918     else
919       Include(FStates, glsItemCacheNeedsUpdate);
920   finally
921     EndUpdate;
922   end;
923 end;
924 
925 procedure TGtkListStoreStringList.Move(CurIndex, NewIndex: Integer);
926 const
927   AState: Array[Boolean] of TCheckBoxState = (cbUnchecked, cbChecked);
928 var
929   AItemChecked: Boolean;
930 begin
931   if FOwner is TCheckListBox then
932     AItemChecked := TCheckListBox(FOwner).Checked[CurIndex];
933   inherited Move(CurIndex, NewIndex);
934   if FOwner is TCheckListBox then
935     TGtk2WSCustomCheckListBox.SetState(TCustomCheckListBox(FOwner),
936       NewIndex, AState[AItemChecked]);
937 
938 end;
939 
940 {$I gtk2listsl.inc}
941 
942 // Gtk2FileDialogUtils
943 
944 {------------------------------------------------------------------------------
945   Function: ExtractFilterList
946   Params: const Filter: string; var FilterIndex: integer;
947           var ListOfPFileSelFilterEntry: TStringList
948   Returns: -
949 
950   Converts a Delphi file filter of the form
951   'description1|mask1|description2|mask2|...'
952   into a TFPList of PFileSelFilterEntry(s).
953   Multi masks:
954     - multi masks like '*.pas;*.pp' are converted into multiple entries.
955     - if the masks are found in the description they are adjusted
956     - if the mask is not included in the description it will be concatenated
957     For example:
958       'Pascal files (*.pas;*.pp)|*.pas;*.lpr;*.pp;
959       is converted to three filter entries:
960         'Pascal files (*.pas)' + '*.pas'
961         'Pascal files (*.pp)'  + '*.pp'
962         'Pascal files (*.lpr)' + '*.lpr'
963  ------------------------------------------------------------------------------}
964 procedure ExtractFilterList(const Filter: string;
965   out ListOfFileSelFilterEntry: TFPList;
966   SplitMultiMask: boolean);
967 var
968   Masks: TStringList;
969   CurFilterIndex: integer;
970 
971   procedure ExtractMasks(const MultiMask: string);
972   var CurMaskStart, CurMaskEnd: integer;
973     s: string;
974   begin
975     if Masks=nil then
976       Masks:=TStringList.Create
977     else
978       Masks.Clear;
979     CurMaskStart:=1;
980     while CurMaskStart<=length(MultiMask) do begin
981       CurMaskEnd:=CurMaskStart;
982       if SplitMultiMask then begin
983         while (CurMaskEnd<=length(MultiMask)) and (MultiMask[CurMaskEnd]<>';')
984         do
985           inc(CurMaskEnd);
986       end else begin
987         CurMaskEnd:=length(MultiMask)+1;
988       end;
989       s:=Trim(copy(MultiMask,CurMaskStart,CurMaskEnd-CurMaskStart));
990       Masks.Add(s);
991       CurMaskStart:=CurMaskEnd+1;
992     end;
993   end;
994 
995   procedure AddEntry(const Desc, Mask: string);
996   var NewFilterEntry: TFileSelFilterEntry;
997   begin
998     NewFilterEntry:=TFileSelFilterEntry.Create(Desc,Mask);
999     NewFilterEntry.FilterIndex:=CurFilterIndex;
1000     ListOfFileSelFilterEntry.Add(NewFilterEntry);
1001   end;
1002 
1003   // remove all but one masks from description string
RemoveOtherMasksnull1004   function RemoveOtherMasks(const Desc: string; MaskIndex: integer): string;
1005   var i, StartPos, EndPos: integer;
1006   begin
1007     Result:=Desc;
1008     for i:=0 to Masks.Count-1 do begin
1009       if i=MaskIndex then continue;
1010       StartPos:=Pos(Masks[i],Result);
1011       EndPos:=StartPos+length(Masks[i]);
1012       if StartPos<1 then continue;
1013       while (StartPos>1) and (Result[StartPos-1] in [' ',#9,';']) do
1014         dec(StartPos);
1015       while (EndPos<=length(Result)) and (Result[EndPos] in [' ',#9]) do
1016         inc(EndPos);
1017       if (StartPos>1) and (Result[StartPos-1]='(')
1018       and (EndPos<=length(Result)) then begin
1019         if (Result[EndPos]=')') then begin
1020           dec(StartPos);
1021           inc(EndPos);
1022         end else if Result[EndPos]=';' then begin
1023           inc(EndPos);
1024         end;
1025       end;
1026       System.Delete(Result,StartPos,EndPos-StartPos);
1027     end;
1028   end;
1029 
1030   procedure AddEntries(const Desc: string; MultiMask: string);
1031   var i: integer;
1032     CurDesc: string;
1033   begin
1034     ExtractMasks(MultiMask);
1035     for i:=0 to Masks.Count-1 do begin
1036       CurDesc:=RemoveOtherMasks(Desc,i);
1037       if (Masks.Count>1) and (Pos(Masks[i],CurDesc)<1) then begin
1038         if (CurDesc='') or (CurDesc[length(CurDesc)]<>' ') then
1039           CurDesc:=CurDesc+' ';
1040         CurDesc:=CurDesc+'('+Masks[i]+')';
1041       end;
1042       //debugln('AddEntries ',CurDesc,' ',Masks[i]);
1043       AddEntry(CurDesc,Masks[i]);
1044     end;
1045     inc(CurFilterIndex);
1046   end;
1047 
1048 var
1049   CurDescStart, CurDescEnd, CurMultiMaskStart, CurMultiMaskEnd: integer;
1050   CurDesc, CurMultiMask: string;
1051 begin
1052   ListOfFileSelFilterEntry:=TFPList.Create;
1053   Masks:=nil;
1054   CurFilterIndex:=0;
1055   CurDescStart:=1;
1056   while CurDescStart<=length(Filter) do begin
1057     // extract next filter description
1058     CurDescEnd:=CurDescStart;
1059     while (CurDescEnd<=length(Filter)) and (Filter[CurDescEnd]<>'|') do
1060       inc(CurDescEnd);
1061     CurDesc:=copy(Filter,CurDescStart,CurDescEnd-CurDescStart);
1062     // extract next filter multi mask
1063     CurMultiMaskStart:=CurDescEnd+1;
1064     CurMultiMaskEnd:=CurMultiMaskStart;
1065     while (CurMultiMaskEnd<=length(Filter)) and (Filter[CurMultiMaskEnd]<>'|') do
1066       inc(CurMultiMaskEnd);
1067     CurMultiMask:=copy(Filter,CurMultiMaskStart,CurMultiMaskEnd-CurMultiMaskStart);
1068     if CurDesc='' then CurDesc:=CurMultiMask;
1069     // add filter(s)
1070     if (CurMultiMask<>'') or (CurDesc<>'') then
1071       AddEntries(CurDesc,CurMultiMask);
1072     // next filter
1073     CurDescStart:=CurMultiMaskEnd+1;
1074   end;
1075   Masks.Free;
1076 end;
1077 
1078 procedure FreeListOfFileSelFilterEntry(ListOfFileSelFilterEntry: TFPList);
1079 var
1080   i: Integer;
1081 begin
1082   if ListOfFileSelFilterEntry=nil then exit;
1083   for i:=0 to ListOfFileSelFilterEntry.Count-1 do
1084     TObject(ListOfFileSelFilterEntry[i]).Free;
1085   ListOfFileSelFilterEntry.Free;
1086 end;
1087 
1088 procedure InternalInit;
1089 var
1090   c: TClipboardType;
1091 begin
1092   gtk_handler_quark := g_quark_from_static_string('gtk-signal-handlers');
1093 
1094   MouseCaptureWidget := nil;
1095 
1096   // clipboard
1097   ClipboardSelectionData:=TFPList.Create;
1098   for c:=Low(TClipboardType) to High(TClipboardType) do begin
1099     ClipboardTypeAtoms[c]:=0;
1100     ClipboardHandler[c]:=nil;
1101     //ClipboardIgnoreLossCount[c]:=0;
1102     ClipboardTargetEntries[c]:=nil;
1103     ClipboardTargetEntryCnt[c]:=0;
1104   end;
1105 
1106   // charset encodings
1107   CharSetEncodingList := TList.Create;
1108   CreateDefaultCharsetEncodings;
1109 
1110   InitDesignSignalMasks;
1111 end;
1112 
1113 procedure InternalFinal;
1114 var i: integer;
1115   ced: PClipboardEventData;
1116   c: TClipboardType;
1117 begin
1118   // clipboard
1119   for i:=0 to ClipboardSelectionData.Count-1 do begin
1120     ced:=PClipboardEventData(ClipboardSelectionData[i]);
1121     FreeMem(ced^.Data.Data);
1122     Dispose(ced);
1123   end;
1124   for c:=Low(TClipboardType) to High(TClipboardType) do
1125     FreeClipboardTargetEntries(c);
1126   FreeAndNil(ClipboardSelectionData);
1127 
1128   // charset encodings
1129   if CharSetEncodingList<>nil then begin
1130     ClearCharSetEncodings;
1131     FreeAndNil(CharSetEncodingList);
1132   end;
1133 end;
1134 
1135 
1136 initialization
1137   InternalInit;
1138 
1139 finalization
1140   InternalFinal;
1141 
1142 end.
1143 
1144