mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-13 04:29:23 +02:00
437 lines
15 KiB
ObjectPascal
437 lines
15 KiB
ObjectPascal
{
|
|
/***************************************************************************
|
|
GTKINT.pp - GTKInterface Object
|
|
-------------------
|
|
|
|
Initial Revision : Thu July 1st CST 1999
|
|
|
|
|
|
***************************************************************************/
|
|
|
|
*****************************************************************************
|
|
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 GtkInt;
|
|
|
|
{$mode objfpc}
|
|
{$LONGSTRINGS ON}
|
|
|
|
interface
|
|
|
|
{$ifdef Trace}
|
|
{$ASSERTIONS ON}
|
|
{$endif}
|
|
|
|
|
|
{$I gtkdefines.inc}
|
|
|
|
uses
|
|
{$IFDEF WIN32}
|
|
// use windows unit first,
|
|
// if not, Rect and Point are taken from the windows unit instead of classes.
|
|
Windows,
|
|
{$ENDIF}
|
|
{$IFDEF UNIX}
|
|
// use unix units first,
|
|
// if not, TSize is taken from the unix unit instead of types.
|
|
ctypes, baseunix, unix,
|
|
{$ENDIF}
|
|
{$IFDEF TraceGdiCalls}
|
|
LineInfo,
|
|
{$ENDIF}
|
|
// rtl+fcl
|
|
Types, Classes, SysUtils,
|
|
// LazUtils
|
|
FPCAdds, LazUTF8,
|
|
// gtk
|
|
{$IFDEF gtk2}
|
|
glib2, gdk2pixbuf, gdk2, gtk2, Pango, gtk2proc,
|
|
{$ifdef HasGdk2X}
|
|
gdk2x,
|
|
{$endif}
|
|
{$ELSE}
|
|
glib, gdk, gtk, gdkpixbuf,
|
|
{$ENDIF}
|
|
// Target OS specific
|
|
{$ifdef HasX}
|
|
x, xlib,
|
|
{$endif}
|
|
Math, // after gtk to get the correct Float type
|
|
// LCL
|
|
LCLPlatformDef, InterfaceBase,
|
|
FileUtil, Translations, ExtDlgs, Dialogs, Controls, Forms, LCLStrConsts,
|
|
LMessages, LCLProc, LCLIntf, LCLType, DynHashArray, GraphType, GraphMath,
|
|
Graphics, Menus, Maps, LazLoggerBase, LazFileUtils, LazStringUtils, Themes,
|
|
// widgetset
|
|
GtkDebug, GtkFontCache, gtkDef, GtkProc, gtkMsgQueue, GtkExtra, WSLCLClasses;
|
|
|
|
type
|
|
|
|
{ TGTKWidgetSet }
|
|
|
|
TGTKWidgetSet = class(TWidgetSet)
|
|
private
|
|
FMultiThreadingEnabled: boolean;
|
|
FocusTimer: cardinal;
|
|
FAppActive: Boolean;
|
|
FLastFocusIn: PGtkWidget;
|
|
FLastFocusOut: PGtkWidget;
|
|
function GetAppActive: Boolean;
|
|
procedure SetAppActive(const AValue: Boolean);
|
|
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}
|
|
|
|
{$Ifdef GTK2}
|
|
FDefaultFontDesc: PPangoFontDescription;
|
|
{$Endif}
|
|
FDefaultFont: TGtkIntfFont;
|
|
FStockSystemFont: HFONT;
|
|
FExtUTF8OutCache: Pointer;
|
|
FExtUTF8OutCacheSize: integer;
|
|
FGlobalCursor: HCursor;
|
|
|
|
FDCManager: TDeviceContextMemManager;
|
|
FDockImage: PGtkWidget;
|
|
FDragImageList: PGtkWidget;
|
|
FDragImageListIcon: PGtkWidget;
|
|
FDragHotStop: TPoint;
|
|
|
|
function CreateThemeServices: TThemeServices; override;
|
|
function GetDeviceContextClass: TGtkDeviceContextClass; virtual; abstract;
|
|
public
|
|
procedure InitStockItems; virtual;
|
|
procedure FreeStockItems; virtual;
|
|
procedure InitSystemColors;
|
|
procedure InitSystemBrushes; virtual;
|
|
procedure FreeSystemBrushes; virtual;
|
|
procedure PassCmdLineOptions; override;
|
|
|
|
{$ifdef Unix}
|
|
procedure InitSynchronizeSupport;
|
|
procedure ProcessChildSignal;
|
|
procedure PrepareSynchronize(AObject: TObject);
|
|
{$endif}
|
|
|
|
procedure HandlePipeEvent(AData: PtrInt; AFlags: dword);
|
|
|
|
// styles
|
|
procedure FreeAllStyles; virtual;
|
|
function GetCompStyle(Sender : TObject) : Longint; virtual;
|
|
|
|
// create and destroy
|
|
function CreateAPIWidget(AWinControl: TWinControl): PGtkWidget;
|
|
function OldCreateStatusBarPanel(StatusBar: TObject; Index: integer): PGtkWidget;
|
|
function CreateSimpleClientAreaWidget(Sender: TObject;
|
|
NotOnParentsClientArea: boolean): PGtkWidget;
|
|
procedure DestroyEmptySubmenu(Sender: TObject);virtual;
|
|
procedure DestroyConnectedWidget(Widget: PGtkWidget;
|
|
CheckIfDestroying: boolean);virtual;
|
|
function RecreateWnd(Sender: TObject): Integer; virtual;
|
|
|
|
// clipboard
|
|
procedure SetClipboardWidget(TargetWidget: PGtkWidget);virtual;
|
|
|
|
// device contexts
|
|
function IsValidDC(const DC: HDC): Boolean;virtual;
|
|
function NewDC: TGtkDeviceContext;virtual;
|
|
function FindDCWithGDIObject(GDIObject: PGdiObject): TGtkDeviceContext;virtual;
|
|
procedure DisposeDC(aDC: TGtkDeviceContext);virtual;
|
|
function CreateDCForWidget(AWidget: PGtkWidget; AWindow: PGdkWindow;
|
|
AWithChildWindows: Boolean; ADoubleBuffer: PgdkDrawable = nil): HDC;
|
|
function GetDoubleBufferedDC(Handle: HWND): HDC;
|
|
|
|
// GDIObjects
|
|
function IsValidGDIObject(const AGDIObj: HGDIOBJ): Boolean; virtual;
|
|
function IsValidGDIObjectType(const GDIObject: HGDIOBJ;
|
|
const GDIType: TGDIType): Boolean;virtual;
|
|
function NewGDIObject(const GDIType: TGDIType): PGdiObject;virtual;
|
|
procedure DisposeGDIObject(GdiObject: PGdiObject);virtual;
|
|
function ReleaseGDIObject(GdiObject: PGdiObject): boolean;virtual;
|
|
procedure ReferenceGDIObject(GdiObject: PGdiObject);virtual;
|
|
function CreateDefaultBrush: PGdiObject;virtual;
|
|
function CreateDefaultFont: PGdiObject;virtual;
|
|
function CreateDefaultPen: PGdiObject;virtual;
|
|
function CreateDefaultGDIBitmap: PGdiObject;virtual;
|
|
procedure UpdateDCTextMetric(DC: TGtkDeviceContext); virtual;
|
|
{$Ifdef GTK2}
|
|
function GetDefaultFontDesc(IncreaseReferenceCount: boolean): PPangoFontDescription;
|
|
{$Endif}
|
|
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; var BitInfo: BitmapInfo; Usage: UINT; DIB : Boolean): Integer;virtual;
|
|
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);virtual;
|
|
procedure CheckRCFilename;virtual;
|
|
procedure ParseRCFile;virtual;
|
|
|
|
// forms and dialogs
|
|
procedure BringFormToFront(Sender: TObject);
|
|
procedure UntransientWindow(GtkWindow: PGtkWindow);
|
|
// misc
|
|
function GetCaption(Sender : TObject) : String; virtual;
|
|
procedure WordWrap(DC: HDC; AText: PChar; MaxWidthInPixel: integer;
|
|
var Lines: PPChar; var LineCount: integer);
|
|
|
|
procedure ResizeChild(Sender : TObject; Left,Top,Width,Height : Integer);virtual;
|
|
procedure RemoveCallbacks(Widget: PGtkWidget); virtual;
|
|
|
|
// for gtk specific components:
|
|
procedure SetLabelCaption(const ALabel: PGtkLabel; const ACaption: String
|
|
{$IFDEF Gtk1}
|
|
; const AComponent: TComponent = nil;
|
|
const ASignalWidget: PGTKWidget = nil;
|
|
const ASignal: PChar = nil{$ENDIF}); virtual; abstract;
|
|
procedure SetWidgetColor(const AWidget: PGtkWidget;
|
|
const FGColor, BGColor: TColor;
|
|
const Mask: tGtkStateEnum);
|
|
procedure SetWidgetFont(const AWidget : PGtkWidget;const AFONT : tFont); virtual; abstract;
|
|
procedure SetCallbackEx(const AMsg: LongInt; const AGTKObject: PGTKObject;
|
|
const ALCLObject: TObject; Direct: boolean); virtual;
|
|
procedure SetCallbackDirect(const AMsg: LongInt; const AGTKObject: PGTKObject;
|
|
const ALCLObject: TObject);
|
|
procedure SetCallback(const AMsg: LongInt; const AGTKObject: PGTKObject;
|
|
const ALCLObject: TObject);
|
|
procedure SetCommonCallbacks(const AGTKObject: PGTKObject; const ALCLObject: TObject); virtual;
|
|
function LCLtoGtkMessagePending: boolean;virtual;
|
|
procedure SendCachedGtkMessages;virtual;
|
|
// show, hide and invalidate
|
|
procedure SetVisible(Sender: TObject; const AVisible: Boolean); virtual;
|
|
|
|
// 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;
|
|
|
|
public
|
|
function LCLPlatform: TLCLPlatform; override;
|
|
// Application
|
|
procedure AppInit(var ScreenInfo: TScreenInfo); override;
|
|
procedure AppProcessMessages; override;
|
|
procedure AppWaitMessage; override;
|
|
procedure AppTerminate; override;
|
|
procedure AppMinimize; override;
|
|
procedure AppRestore; override;
|
|
procedure AppBringToFront; override;
|
|
procedure AppSetTitle(const ATitle: string); override;
|
|
// notebook
|
|
procedure AddDummyNoteBookPage(NoteBookWidget: PGtkNoteBook);virtual;
|
|
public
|
|
constructor Create; override;
|
|
destructor Destroy; override;
|
|
procedure SendCachedLCLMessages; 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;
|
|
procedure SetDesigning(AComponent: TComponent); override;
|
|
|
|
// helper routines needed by interface methods
|
|
// |-forms
|
|
procedure UpdateTransientWindows; virtual;
|
|
// |-listbox
|
|
procedure SetSelectionMode(Sender: TObject; Widget: PGtkWidget;
|
|
MultiSelect, ExtendedSelect: boolean); virtual;
|
|
function ForceLineBreaks(DC : hDC; Src: PChar; MaxWidthInPixels : Longint;
|
|
ConvertAmpersandsToUnderScores: Boolean) : PChar;
|
|
|
|
// create and destroy
|
|
function CreateTimer(Interval: integer; TimerProc: TWSTimerProc) : TLCLHandle; override;
|
|
function DestroyTimer(TimerHandle: TLCLHandle) : boolean; override;
|
|
procedure DestroyLCLComponent(Sender: TObject);virtual;
|
|
|
|
// for gtk controls not part of the LCL:
|
|
procedure FinishCreateHandle(const AWinControl: TWinControl; Widget: PGtkWidget; const AParams: TCreateParams);
|
|
|
|
{$I gtkwinapih.inc}
|
|
{$I gtklclintfh.inc}
|
|
|
|
public
|
|
|
|
// special methods and properties to track app activation / deactivation
|
|
procedure StartFocusTimer;
|
|
property AppActive: Boolean read GetAppActive write SetAppActive;
|
|
property LastFocusIn: PGtkWidget read FLastFocusIn write FLastFocusIn;
|
|
property LastFocusOut: PGtkWidget read FLastFocusOut write FLastFocusOut;
|
|
|
|
property RCFilename: string read FRCFilename write SetRCFilename;
|
|
property MultiThreadingEnabled: boolean read FMultiThreadingEnabled;
|
|
end;
|
|
|
|
{$I gtklistslh.inc}
|
|
{$I gtkfiledialogutilsh.inc}
|
|
|
|
var
|
|
GTKWidgetSet: TGTKWidgetSet;
|
|
|
|
implementation
|
|
|
|
uses
|
|
////////////////////////////////////////////////////
|
|
// I M P O R T A N T
|
|
////////////////////////////////////////////////////
|
|
// To get as little as possible circles,
|
|
// uncomment only those units with implementation
|
|
////////////////////////////////////////////////////
|
|
// GtkWSActnList,
|
|
GtkWSButtons,
|
|
GtkWSCalendar,
|
|
GtkWSCheckLst,
|
|
GtkWSComCtrls,
|
|
GtkWSControls,
|
|
// GtkWSDbCtrls,
|
|
// GtkWSDBGrids,
|
|
GtkWSDialogs,
|
|
// GtkWSEditBtn,
|
|
GtkWSExtCtrls,
|
|
GtkWSExtDlgs,
|
|
// GtkWSFileCtrl,
|
|
GtkWSForms,
|
|
GtkWSGrids,
|
|
// GtkWSImgList,
|
|
// GtkWSMaskEdit,
|
|
GtkWSMenus,
|
|
GtkWSPairSplitter,
|
|
GtkWSSpin,
|
|
GtkWSStdCtrls,
|
|
// GtkWSToolwin,
|
|
////////////////////////////////////////////////////
|
|
GtkWSPrivate,
|
|
GtkThemes,
|
|
Buttons, StdCtrls, PairSplitter,
|
|
GTKWinApiWindow, ComCtrls, Calendar, Spin,
|
|
ExtCtrls, FileCtrl, LResources, gtkglobals,
|
|
LazUtilities;
|
|
|
|
{$I gtklistsl.inc}
|
|
{$I gtkfiledialogutils.inc}
|
|
{$I gtkwidgetset.inc}
|
|
{$I gtkwinapi.inc}
|
|
{$I gtklclintf.inc}
|
|
|
|
|
|
procedure InternalInit;
|
|
var
|
|
c: TClipboardType;
|
|
begin
|
|
gtk_handler_quark := g_quark_from_static_string('gtk-signal-handlers');
|
|
|
|
MouseCaptureWidget := nil;
|
|
MouseCaptureType := mctGTK;
|
|
|
|
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
|
|
{$IFDEF Gtk1}
|
|
SystemCharSetIsUTF8:=not NeedRTLAnsi;
|
|
{$ENDIF}
|
|
|
|
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]);
|
|
if ced^.Data.Data<>nil then FreeMem(ced^.Data.Data);
|
|
Dispose(ced);
|
|
end;
|
|
for c:=Low(TClipboardType) to High(TClipboardType) do
|
|
FreeClipboardTargetEntries(c);
|
|
ClipboardSelectionData.Free;
|
|
ClipboardSelectionData:=nil;
|
|
|
|
// charset encodings
|
|
if CharSetEncodingList<>nil then begin
|
|
ClearCharSetEncodings;
|
|
CharSetEncodingList.Free;
|
|
CharSetEncodingList:=nil;
|
|
end;
|
|
end;
|
|
|
|
|
|
initialization
|
|
{$IFDEF GTK1}
|
|
{$I gtkimages.lrs}
|
|
{$ENDIF}
|
|
InternalInit;
|
|
|
|
finalization
|
|
InternalFinal;
|
|
|
|
end.
|