lazarus/lcl/interfaces/qt5/qtobjects.pas

5295 lines
144 KiB
ObjectPascal

{
*****************************************************************************
* QtObjects.pas *
* -------------- *
* *
* *
*****************************************************************************
*****************************************************************************
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 qtobjects;
{$mode objfpc}{$H+}
interface
{$I qtdefines.inc}
uses
// Bindings
qt5,
// Free Pascal
Classes, SysUtils, Types,
// LCL
LCLType, LCLIntf, LCLProc, LazUTF8, Menus, Graphics, ClipBrd, ExtCtrls,
Interfacebase, maps;
type
// forward declarations
TQActions = Array of QActionH;
TQtImage = class;
TQtFontMetrics = class;
TQtFontInfo = class;
TQtTimer = class;
TRop2OrCompositionSupport = (rocNotSupported, rocSupported, rocUndefined);
{ TQtObject }
TQtObject = class(TObject)
private
FUpdateCount: Integer;
FInEventCount: Integer;
FReleaseInEvent: Boolean;
public
FDeleteLater: Boolean;
FEventHook: QObject_hookH;
FDestroyedHook: QObject_hookH;
TheObject: QObjectH;
constructor Create; virtual; overload;
destructor Destroy; override;
procedure Release; virtual;
public
procedure AttachEvents; virtual;
procedure DetachEvents; virtual;
function EventFilter(Sender: QObjectH; Event: QEventH): Boolean; cdecl; virtual; abstract;
procedure Destroyed; cdecl; virtual;
procedure BeginEventProcessing;
procedure EndEventProcessing;
function InEvent: Boolean;
public
procedure BeginUpdate; virtual;
procedure EndUpdate; virtual;
function InUpdate: Boolean;
end;
{ TQtResource }
TQtResource = class(TObject)
public
Owner: TObject;
FShared: Boolean;
FSelected: Boolean;
end;
{ TQtActionGroup }
TQtActionGroup = class(TObject)
private
FActions: TQActions;
FGroupIndex: integer;
FHandle: QActionGroupH;
function getEnabled: boolean;
function getExclusive: boolean;
function getVisible: boolean;
procedure setEnabled(const AValue: boolean);
procedure setExclusive(const AValue: boolean);
procedure setVisible(const AValue: boolean);
public
constructor Create(const AParent: QObjectH = nil);
destructor Destroy; override;
function addAction(action: QActionH): QActionH; overload;
function addAction(text: WideString): QActionH; overload;
function addAction(icon: QIconH; text: WideString): QActionH; overload;
procedure removeAction(action: QActionH);
function actions: TQActions;
function checkedAction: QActionH;
procedure setDisabled(ADisabled: Boolean);
property Enabled: boolean read getEnabled write setEnabled;
property Exclusive: boolean read getExclusive write setExclusive;
property GroupIndex: integer read FGroupIndex write FGroupIndex;
property Handle: QActionGroupH read FHandle;
property Visible: boolean read getVisible write setVisible;
end;
{ TQtAction }
TQtAction = class(TObject)
private
FIcon: QIconH;
public
FHandle: QActionH;
MenuItem: TMenuItem;
public
constructor Create(const AHandle: QActionH);
destructor Destroy; override;
public
procedure SlotTriggered({%H-}checked: Boolean = False); cdecl;
public
procedure setChecked(p1: Boolean);
procedure setCheckable(p1: Boolean);
procedure setEnabled(p1: Boolean);
procedure setIcon(const AIcon: QIconH);
procedure setImage(const AImage: TQtImage);
procedure setVisible(p1: Boolean);
end;
{ TQtImage }
TQtImage = class(TObject)
private
FData: PByte;
FDataOwner: Boolean;
FHandle: QImageH;
public
constructor Create;
constructor Create(vHandle: QImageH); overload;
constructor Create(AData: PByte; width: Integer; height: Integer; format: QImageFormat; const ADataOwner: Boolean = False); overload;
constructor Create(AData: PByte; width: Integer; height: Integer; bytesPerLine: Integer; format: QImageFormat; const ADataOwner: Boolean = False); overload;
destructor Destroy; override;
function AsIcon(AMode: QIconMode = QIconNormal; AState: QIconState = QIconOff): QIconH;
function AsPixmap(flags: QtImageConversionFlags = QtAutoColor): QPixmapH;
function AsBitmap(flags: QtImageConversionFlags = QtAutoColor): QBitmapH;
procedure CopyFrom(AImage: QImageH; x, y, w, h: integer);
public
function height: Integer;
function width: Integer;
function depth: Integer;
function dotsPerMeterX: Integer;
function dotsPerMeterY: Integer;
function bits: PByte;
function numBytes: Integer;
function bytesPerLine: Integer;
procedure invertPixels(InvertMode: QImageInvertMode = QImageInvertRgb);
function getFormat: QImageFormat;
property Handle: QImageH read FHandle;
end;
{ TQtFont }
TQtFont = class(TQtResource)
private
FDefaultFont: QFontH;
FMetrics: TQtFontMetrics;
FFontInfo: TQtFontInfo;
function GetFontInfo: TQtFontInfo;
function GetMetrics: TQtFontMetrics;
function GetDefaultFont: QFontH;
public
FHandle: QFontH;
Angle: Integer;
public
constructor Create(CreateHandle: Boolean); virtual;
constructor Create(AFromFont: QFontH); virtual;
destructor Destroy; override;
public
function getPointSize: Integer;
function getPixelSize: Integer;
function getWeight: Integer;
function getItalic: Boolean;
function getBold: Boolean;
function getUnderline: Boolean;
function getStrikeOut: Boolean;
function getFamily: WideString;
function getStyleStategy: QFontStyleStrategy;
procedure setPointSize(p1: Integer);
procedure setPixelSize(p1: Integer);
procedure setWeight(p1: Integer);
procedure setBold(p1: Boolean);
procedure setItalic(b: Boolean);
procedure setUnderline(p1: Boolean);
procedure setStrikeOut(p1: Boolean);
procedure setRawName(p1: string);
procedure setFamily(p1: string);
procedure setStyleStrategy(s: QFontStyleStrategy);
procedure family(retval: PWideString);
function fixedPitch: Boolean;
property FontInfo: TQtFontInfo read GetFontInfo;
property Metrics: TQtFontMetrics read GetMetrics;
end;
{ TQtFontMetrics }
TQtFontMetrics = class(TObject)
private
public
FHandle: QFontMetricsH;
public
constructor Create(Parent: QFontH); virtual;
destructor Destroy; override;
public
function height: Integer;
function width(p1: PWideString): Integer; overload;
function width(p1: PWideString; ALen: Integer): Integer; overload;
function ascent: Integer;
function descent: Integer;
function leading: Integer;
function maxWidth: Integer;
procedure boundingRect(retval: PRect; r: PRect; flags: Integer; text: PWideString; tabstops: Integer = 0; tabarray: PInteger = nil);
function charWidth(str: WideString; pos: Integer): Integer;
function averageCharWidth: Integer;
function elidedText(const AText: WideString;
const AMode: QtTextElideMode; const AWidth: Integer;
const AFlags: Integer = 0): WideString;
end;
{ TQtFontInfo }
TQtFontInfo = class(TObject)
private
function GetBold: Boolean;
function GetExactMatch: Boolean;
function GetFamily: WideString;
function GetFixedPitch: Boolean;
function GetFontStyle: QFontStyle;
function GetFontStyleHint: QFontStyleHint;
function GetItalic: Boolean;
function GetOverLine: Boolean;
function GetPixelSize: Integer;
function GetPointSize: Integer;
function GetRawMode: Boolean;
function GetStrikeOut: Boolean;
function GetUnderline: Boolean;
function GetWeight: Integer;
public
FHandle: QFontInfoH;
public
constructor Create(AFont: QFontH); virtual;
destructor Destroy; override;
public
property Bold: Boolean read GetBold;
property Italic: Boolean read GetItalic;
property ExactMatch: Boolean read GetExactMatch;
property Family: WideString read GetFamily;
property FixedPitch: Boolean read GetFixedPitch;
property Overline: Boolean read GetOverLine;
property PointSize: Integer read GetPointSize;
property PixelSize: Integer read GetPixelSize;
property RawMode: Boolean read GetRawMode;
property StrikeOut: Boolean read GetStrikeOut;
property Style: QFontStyle read GetFontStyle;
property StyleHint: QFontStyleHint read GetFontStyleHint;
property Underline: Boolean read GetUnderline;
property Weight: Integer read GetWeight;
end;
{ TQtBrush }
TQtBrush = class(TQtResource)
private
FRadialGradient: QRadialGradientH;
function getStyle: QtBrushStyle;
procedure setStyle(style: QtBrushStyle);
public
FHandle: QBrushH;
constructor Create(CreateHandle: Boolean); virtual;
constructor CreateWithRadialGradient(ALogBrush: TLogRadialGradient);
destructor Destroy; override;
function getColor: PQColor;
function GetLBStyle(out AStyle: LongWord; out AHatch: PtrUInt): Boolean;
procedure setColor(AColor: PQColor);
procedure setTexture(pixmap: QPixmapH);
procedure setTextureImage(image: QImageH);
property Style: QtBrushStyle read getStyle write setStyle;
end;
{ TQtPen }
TQtPen = class(TQtResource)
private
FIsExtPen: Boolean;
public
FHandle: QPenH;
constructor Create(CreateHandle: Boolean); virtual;
destructor Destroy; override;
public
function getCapStyle: QtPenCapStyle;
function getColor: TQColor;
function getCosmetic: Boolean;
function getJoinStyle: QtPenJoinStyle;
function getWidth: Integer;
function getStyle: QtPenStyle;
function getDashPattern: TQRealArray;
procedure setCapStyle(pcs: QtPenCapStyle);
procedure setColor(p1: TQColor);
procedure setCosmetic(b: Boolean);
procedure setJoinStyle(pcs: QtPenJoinStyle);
procedure setStyle(AStyle: QtPenStyle);
procedure setBrush(brush: QBrushH);
procedure setWidth(p1: Integer);
procedure setDashPattern(APattern: PDWord; ALength: DWord);
property IsExtPen: Boolean read FIsExtPen write FIsExtPen;
end;
{ TQtRegion }
TQtRegion = class(TQtResource)
private
FPolygon: QPolygonH;
function GetIsPolyRegion: Boolean;
public
FHandle: QRegionH;
constructor Create(CreateHandle: Boolean); virtual; overload;
constructor Create(CreateHandle: Boolean; X1,Y1,X2,Y2: Integer;
Const RegionType: QRegionRegionType = QRegionRectangle); virtual; overload;
constructor Create(CreateHandle: Boolean; Poly: QPolygonH;
Const Fill: QtFillRule = QtWindingFill); virtual; overload;
destructor Destroy; override;
function containsPoint(X,Y: Integer): Boolean;
function containsRect(R: TRect): Boolean;
function intersects(R: TRect): Boolean; overload;
function intersects(Rgn: QRegionH): Boolean; overload;
function GetRegionType: integer;
function getBoundingRect: TRect;
function numRects: Integer;
procedure translate(dx, dy: Integer);
property IsPolyRegion: Boolean read GetIsPolyRegion;
property Polygon: QPolygonH read FPolygon;
end;
// NOTE: PQtDCData was a pointer to a structure with QPainter information
// about current state, currently this functionality is implemented
// using native functions qpainter_save and qpainter_restore. If in
// future it needs to save/restore aditional information, PQtDCData
// should point to a structure holding the additional information.
// see SaveDC and RestoreDC for more information.
// for example: what about textcolor, it's currently not saved....
{
TQtDCData = record
end;
PQtDCData = ^TQtDCData;
}
PQtDCData = pointer;
{ TQtDeviceContext }
TQtDeviceContext = class(TObject)
private
FPenTextInternal: boolean;
FSupportRasterOps: TRop2OrCompositionSupport;
FSupportComposition: TRop2OrCompositionSupport;
FRopMode: Integer;
FPenPos: TQtPoint;
FOwnPainter: Boolean;
FUserDC: boolean;
SelFont: TQtFont;
SelBrush: TQtBrush;
SelPen: TQtPen;
FMetrics: TQtFontMetrics;
function GetMetrics: TQtFontMetrics;
function GetRop: Integer;
function DeviceSupportsComposition: Boolean;
function DeviceSupportsRasterOps: Boolean;
function R2ToQtRasterOp(AValue: Integer): QPainterCompositionMode;
procedure SetRop(const AValue: Integer);
public
{ public fields }
Widget: QPainterH;
Parent: QWidgetH;
ParentPixmap: QPixmapH;
vBrush: TQtBrush;
vFont: TQtFont;
vImage: TQtImage;
vPen: TQtPen;
vRegion: TQtRegion;
vBackgroundBrush: TQtBrush;
vClipRect: PRect; // is the cliprect paint event give to us
vClipRectDirty: boolean; // false=paint cliprect is still valid
vTextColor: TColorRef;
vMapMode: Integer;
public
{ Our own functions }
constructor Create(AWidget: QWidgetH; const APaintEvent: Boolean = False); virtual;
constructor CreatePrinterContext(ADevice: QPrinterH); virtual;
constructor CreateFromPainter(APainter: QPainterH);
destructor Destroy; override;
procedure CreateObjects;
procedure DestroyObjects;
function CreateDCData: PQtDCDATA;
function RestoreDCData(var {%H-}DCData: PQtDCData): boolean;
procedure DebugClipRect(const msg: string);
procedure setImage(AImage: TQtImage);
procedure CorrectCoordinates(var ARect: TRect);
function GetLineLastPixelPos(PrevPos, NewPos: TPoint): TPoint;
procedure SetTextPen;
public
{ Qt functions }
procedure qDrawPlainRect(x, y, w, h: integer; AColor: PQColor = nil;
lineWidth: Integer = 1; FillBrush: QBrushH = nil);
procedure qDrawShadeRect(x, y, w, h: integer; Palette: QPaletteH = nil; Sunken: Boolean = False;
lineWidth: Integer = 1; midLineWidth: Integer = 0; FillBrush: QBrushH = nil);
procedure qDrawWinPanel(x, y, w, h: integer;
ATransparent: boolean;
Palette: QPaletteH = nil; Sunken: Boolean = False;
lineWidth: Integer = 1; FillBrush: QBrushH = nil);
procedure drawPoint(x1: Integer; y1: Integer);
procedure drawRect(x1: Integer; y1: Integer; w: Integer; h: Integer);
procedure drawRectF(x1: double; y1: double; w: double; h: double);
procedure drawRoundRect(x, y, w, h, rx, ry: Integer);
procedure drawText(x: Integer; y: Integer; s: PWideString); overload;
procedure drawText(x,y,w,h,flags: Integer; s:PWideString); overload;
procedure drawLine(x1: Integer; y1: Integer; x2: Integer; y2: Integer);
procedure drawLineF(x1: double; y1: double; x2: double; y2: double);
procedure drawEllipse(x: Integer; y: Integer; w: Integer; h: Integer);
procedure drawPixmap(p: PQtPoint; pm: QPixmapH; sr: PRect);
procedure drawPolyLine(P: PPoint; NumPts: Integer);
procedure drawPolygon(P: PPoint; NumPts: Integer; FillRule: QtFillRule = QtOddEvenFill);
procedure eraseRect(ARect: PRect);
procedure fillRect(ARect: PRect; ABrush: QBrushH); overload;
procedure fillRect(x, y, w, h: Integer; ABrush: QBrushH); overload;
procedure fillRect(x, y, w, h: Integer); overload;
function getBKMode: Integer;
procedure getBrushOrigin(retval: PPoint);
function getClipping: Boolean;
function getCompositionMode: QPainterCompositionMode;
procedure setCompositionMode(mode: QPainterCompositionMode);
procedure getPenPos(retval: PPoint);
function getWorldTransform: QTransformH;
procedure setBrushOrigin(x, y: Integer);
procedure setPenPos(x, y: Integer);
function font: TQtFont;
procedure setFont(AFont: TQtFont);
function brush: TQtBrush;
procedure setBrush(ABrush: TQtBrush);
function BackgroundBrush: TQtBrush;
function GetBkColor: TColorRef;
function pen: TQtPen;
function setPen(APen: TQtPen): TQtPen;
function SetBkColor(Color: TColorRef): TColorRef;
function SetBkMode(BkMode: Integer): Integer;
function getDepth: integer;
function getDeviceSize: TPoint;
function getRegionType(ARegion: QRegionH): integer;
function getClipRegion: TQtRegion;
function preferFloatingPointDrawingFunctions: boolean; {when screen is scaled we use drawLineF, drawRectF etc.}
procedure setClipping(const AValue: Boolean);
procedure setClipRect(const ARect: TRect);
procedure setClipRegion(ARegion: QRegionH; AOperation: QtClipOperation = QtReplaceClip);
procedure setRegion(ARegion: TQtRegion);
procedure drawImage(targetRect: PRect; image: QImageH; sourceRect: PRect;
mask: QImageH; maskRect: PRect; flags: QtImageConversionFlags = QtAutoColor);
function PaintEngine: QPaintEngineH;
procedure rotate(a: Double);
procedure setRenderHint(AHint: QPainterRenderHint; AValue: Boolean);
procedure save;
procedure restore;
procedure translate(dx: Double; dy: Double);
property Metrics: TQtFontMetrics read GetMetrics;
property Rop2: Integer read GetRop write SetRop;
property UserDC: boolean read FUserDC write FUserDC; {if context is created from GetDC() and it's not default DC.}
property PenTextInternal: boolean read FPenTextInternal write FPenTextInternal; {optimization for ExtTextOut}
end;
{ TQtPixmap }
TQtPixmap = class(TObject)
protected
FHandle: QPixmapH;
public
constructor Create(p1: PSize); virtual;
destructor Destroy; override;
public
property Handle: QPixmapH read FHandle;
function getHeight: Integer;
function getWidth: Integer;
procedure grabWidget(AWidget: QWidgetH; x: Integer = 0; y: Integer = 0; w: Integer = -1; h: Integer = -1);
procedure grabWindow(p1: PtrUInt; x: Integer = 0; y: Integer = 0; w: Integer = -1; h: Integer = -1);
procedure toImage(retval: QImageH);
class procedure fromImage(retval: QPixmapH; image: QImageH; flags: QtImageConversionFlags = QtAutoColor);
end;
{ TQtIcon }
TQtIcon = class(TObject)
protected
FHandle: QIconH;
public
constructor Create;
destructor Destroy; override;
procedure addPixmap(pixmap: QPixmapH; mode: QIconMode = QIconNormal; state: QIconState = QIconOff);
property Handle: QIconH read FHandle;
end;
{ TQtCursor }
TQtCursor = class(TObject)
protected
FHandle: QCursorH;
public
constructor Create;
constructor Create(pixmap: QPixmapH; hotX: Integer = -1; hotY: Integer = -1);
constructor Create(shape: QtCursorShape);
destructor Destroy; override;
property Handle: QCursorH read FHandle;
end;
{ TQtButtonGroup }
TQtButtonGroup = class(TObject)
private
public
Handle: QButtonGroupH;
constructor Create(AParent: QObjectH); virtual;
destructor Destroy; override;
public
procedure AddButton(AButton: QAbstractButtonH); overload;
procedure AddButton(AButton: QAbstractButtonH; Id: Integer); overload;
function ButtonFromId(id: Integer): QAbstractButtonH;
procedure RemoveButton(AButton: QAbstractButtonH);
function GetExclusive: Boolean;
procedure SetExclusive(AExclusive: Boolean);
procedure SignalButtonClicked(AButton: QAbstractButtonH); cdecl;
end;
{ TQtClipboard }
TQtClipboard = class(TQtObject)
private
FLockClip: Boolean;
FClipDataChangedHook: QClipboard_hookH;
{$IFDEF HASX11}
FClipSelectionChangedHook: QClipboard_hookH;
FSelTimer: TQtTimer; // timer for keyboard X11 selection
FSelFmtCount: Integer;
FLockX11Selection: Integer;
class var FX11Delay: boolean; {small delay to stop freezing clipboard under x11 in some circumstances. eg gtk2/gtk3 platform theme dialogs.}
{$ENDIF}
FClipChanged: Boolean;
FClipBoardFormats: TStringList;
FOnClipBoardRequest: Array[TClipBoardType] of TClipboardRequestEvent;
function IsClipboardChanged: Boolean;
public
constructor Create; override;
destructor Destroy; override;
procedure AttachEvents; override;
procedure DetachEvents; override;
function EventFilter(Sender: QObjectH; Event: QEventH): Boolean; cdecl; override;
function Clipboard: QClipboardH; inline;
function getMimeData(AMode: QClipboardMode): QMimeDataH;
procedure setMimeData(AMimeData: QMimeDataH; AMode: QClipboardMode);
procedure Clear(AMode: QClipboardMode);
function FormatToMimeType(AFormat: TClipboardFormat): String;
function RegisterFormat(AMimeType: String): TClipboardFormat;
function GetData(ClipboardType: TClipboardType; FormatID: TClipboardFormat;
Stream: TStream): boolean;
function GetFormats(ClipboardType: TClipboardType; var Count: integer;
var List: PClipboardFormat): boolean;
function GetOwnerShip(ClipboardType: TClipboardType; OnRequestProc: TClipboardRequestEvent;
FormatCount: integer; Formats: PClipboardFormat): boolean;
procedure signalDataChanged; cdecl;
{$IFDEF HASX11}
procedure BeginX11SelectionLock;
procedure EndX11SelectionLock;
function InX11SelectionLock: Boolean;
procedure signalSelectionChanged; cdecl;
class procedure X11DelayTimeOut; cdecl;
procedure selectionTimer;
{$ENDIF}
end;
{ TQtPrinter }
TQtPrinter = class(TObject)
protected
FHandle: QPrinterH;
FPrinterContext: TQtDeviceContext;
private
FPrinterActive: Boolean;
FPrintQuality: QPrinterPrinterMode;
function GetDuplexMode: QPrinterDuplexMode;
function GetHandle: QPrinterH;
function getPrinterContext: TQtDeviceContext;
function getCollateCopies: Boolean;
function getColorMode: QPrinterColorMode;
function getCreator: WideString;
function getDevType: Integer;
function getDocName: WideString;
function getDoubleSidedPrinting: Boolean;
function getFontEmbedding: Boolean;
function getFullPage: Boolean;
function getOutputFormat: QPrinterOutputFormat;
function getPaperSource: QPrinterPaperSource;
function getPrintProgram: WideString;
function getPrintRange: QPrinterPrintRange;
procedure setCollateCopies(const AValue: Boolean);
procedure setColorMode(const AValue: QPrinterColorMode);
procedure setCreator(const AValue: WideString);
procedure setDocName(const AValue: WideString);
procedure setDoubleSidedPrinting(const AValue: Boolean);
procedure SetDuplexMode(AValue: QPrinterDuplexMode);
procedure setFontEmbedding(const AValue: Boolean);
procedure setFullPage(const AValue: Boolean);
procedure setOutputFormat(const AValue: QPrinterOutputFormat);
procedure setPaperSource(const AValue: QPrinterPaperSource);
procedure setPrinterName(const AValue: WideString);
function getPrinterName: WideString;
procedure setOutputFileName(const AValue: WideString);
function getOutputFileName: WideString;
procedure setOrientation(const AValue: QPrinterOrientation);
function getOrientation: QPrinterOrientation;
procedure setPageSize(const AValue: QPagedPaintDevicePageSize);
function getPageSize: QPagedPaintDevicePageSize;
procedure setPageOrder(const AValue: QPrinterPageOrder);
function getPageOrder: QPrinterPageOrder;
procedure setPrintProgram(const AValue: WideString);
procedure setPrintRange(const AValue: QPrinterPrintRange);
procedure setResolution(const AValue: Integer);
function getResolution: Integer;
function getNumCopies: Integer;
procedure setNumCopies(const AValue: Integer);
function getPrinterState: QPrinterPrinterState;
public
constructor Create; virtual; overload;
constructor Create(AMode: QPrinterPrinterMode); virtual; overload;
destructor Destroy; override;
function DefaultPrinter: WideString;
function GetAvailablePrinters(Lst: TStrings): Boolean;
procedure beginDoc;
procedure endDoc;
function NewPage: Boolean;
function Abort: Boolean;
procedure setFromPageToPage(Const AFromPage, AToPage: Integer);
function fromPage: Integer;
function toPage: Integer;
function PaintEngine: QPaintEngineH;
function PageRect: TRect; overload;
function PaperRect: TRect; overload;
function PageRect(AUnits: QPrinterUnit): TRect; overload;
function PaperRect(AUnits: QPrinterUnit): TRect; overload;
function PrintEngine: QPrintEngineH;
function GetPaperSize(AUnits: QPrinterUnit): TSize;
procedure SetPaperSize(ASize: TSize; AUnits: QPrinterUnit);
function SupportedResolutions: TPtrIntArray;
property Collate: Boolean read getCollateCopies write setCollateCopies;
property ColorMode: QPrinterColorMode read getColorMode write setColorMode;
property Creator: WideString read getCreator write setCreator;
property DeviceType: Integer read getDevType;
property DocName: WideString read getDocName write setDocName;
property DoubleSidedPrinting: Boolean read getDoubleSidedPrinting write setDoubleSidedPrinting;
property Duplex: QPrinterDuplexMode read GetDuplexMode write SetDuplexMode;
property FontEmbedding: Boolean read getFontEmbedding write setFontEmbedding;
property FullPage: Boolean read getFullPage write setFullPage;
property Handle: QPrinterH read GetHandle;
property NumCopies: Integer read getNumCopies write setNumCopies;
property Orientation: QPrinterOrientation read getOrientation write setOrientation;
property OutputFormat: QPrinterOutputFormat read getOutputFormat write setOutputFormat;
property OutputFileName: WideString read getOutputFileName write setOutputFileName;
property PageOrder: QPrinterPageOrder read getPageOrder write setPageOrder;
property PageSize: QPagedPaintDevicePageSize read getPageSize write setPageSize;
property PaperSource: QPrinterPaperSource read getPaperSource write setPaperSource;
property PrinterContext: TQtDeviceContext read getPrinterContext;
property PrinterName: WideString read getPrinterName write setPrinterName;
property PrinterActive: Boolean read FPrinterActive;
property PrintRange: QPrinterPrintRange read getPrintRange write setPrintRange;
property PrinterState: QPrinterPrinterState read getPrinterState;
property PrintProgram: WideString read getPrintProgram write setPrintProgram;
property PrintQuality: QPrinterPrinterMode read FPrintQuality;
property Resolution: Integer read getResolution write setResolution;
end;
{ TQtTimer }
TQtTimer = class(TQtObject)
private
FTimerHook: QTimer_hookH;
FCallbackFunc: TWSTimerProc;
FId: Integer;
FAppObject: QObjectH;
function getTimerEnabled: Boolean;
procedure setTimerEnabled(const AValue: Boolean);
public
constructor CreateTimer(Interval: integer; const TimerFunc: TWSTimerProc; App: QObjectH); virtual;
destructor Destroy; override;
procedure AttachEvents; override;
procedure DetachEvents; override;
procedure signalTimeout; cdecl;
property TimerEnabled: Boolean read getTimerEnabled write setTimerEnabled;
property TimerID: Integer read FId;
public
function EventFilter(Sender: QObjectH; Event: QEventH): Boolean; cdecl; override;
end;
{ TQtStringList }
TQtStringList = class(TStrings)
private
FHandle: QStringListH;
FOwnHandle: Boolean;
protected
function Get(Index: Integer): string; override;
function GetCount: Integer; override;
public
constructor Create;
constructor Create(Source: QStringListH);
destructor Destroy; override;
procedure Clear; override;
procedure Delete(Index: Integer); override;
procedure Insert(Index: Integer; const S: string); override;
property Handle: QStringListH read FHandle;
end;
{ TQtWidgetPalette }
TQtWidgetPalette = class(TObject)
private
procedure initializeSysColors;
function ColorChangeNeeded(const AColor: TQColor;
const ATextRole: Boolean): Boolean;
protected
FForceColor: Boolean;
FInReload: Boolean;
FWidget: QWidgetH;
FWidgetRole: QPaletteColorRole;
FTextRole: QPaletteColorRole;
FDefaultColor: TQColor;
FCurrentColor: TQColor;
FDefaultTextColor: TQColor;
FCurrentTextColor: TQColor;
FDisabledColor: TQColor;
FDisabledTextColor: TQColor;
FHandle: QPaletteH;
public
constructor Create(AWidgetColorRole: QPaletteColorRole;
AWidgetTextColorRole: QPaletteColorRole; AWidget: QWidgetH);
destructor Destroy; override;
procedure ReloadPaletteBegin; // used in QEventPaletteChange !
procedure ReloadPaletteEnd; // used in QEventPaletteChange !
procedure setColor(const AColor: PQColor);
procedure setTextColor(const AColor: PQColor);
property Handle: QPaletteH read FHandle;
property CurrentColor: TQColor read FCurrentColor;
property CurrentTextColor: TQColor read FCurrentTextColor;
property DefaultColor: TQColor read FDefaultColor;
property DefaultTextColor: TQColor read FDefaultTextColor;
property DisabledColor: TQColor read FDisabledColor;
property DisabledTextColor: TQColor read FDisabledTextColor;
property InReload: Boolean read FInReload;
property ForceColor: Boolean read FForceColor write FForceColor;
end;
{TQtObjectDump}
TQtObjectDump = class(TObject) // helper class to dump complete children tree
private
FRoot: QObjectH;
FObjList: TFPList;
FList: TStrings;
procedure Iterator(ARoot: QObjectH);
procedure AddToList(AnObject: QObjectH);
public
constructor Create(AnObject: QObjectH);
destructor Destroy; override;
procedure DumpObject;
function findWidgetByName(const AName: WideString): QWidgetH;
function IsWidget(AnObject: QObjectH): Boolean;
function GetObjectName(AnObject: QObjectH): WideString;
function InheritsQtClass(AnObject: QObjectH; AQtClass: Ansistring): Boolean;
property List: TStrings read FList;
property ObjList: TFPList read FObjList;
end;
{ TQtGDIObjects }
TQtGDIObjects = class(TObject)
private
{$IFDEF DebugQTGDIObjects}
FMaxCount: Int64;
FInvalidCount: Int64;
{$ENDIF}
FCount: PtrInt;
FSavedHandlesList: TMap;
public
constructor Create;
destructor Destroy; override;
procedure AddGDIObject(AObject: TObject);
procedure RemoveGDIObject(AObject: TObject);
function IsValidGDIObject(AGDIObject: PtrUInt): Boolean;
property Count: PtrInt read FCount;
end;
const
LCLQt_Destroy = QEventType(Ord(QEventUser) + $1000);
procedure TQColorToColorRef(const AColor: TQColor; out AColorRef: TColorRef);
procedure ColorRefToTQColor(const AColorRef: TColorRef; var AColor:TQColor);
function EqualTQColor(const Color1, Color2: TQColor): Boolean;
procedure DebugRegion(const msg: string; Rgn: QRegionH);
function CheckGDIObject(const AGDIObject: HGDIOBJ; const AMethodName: String; AParamName: String = ''): Boolean;
function CheckBitmap(const ABitmap: HBITMAP; const AMethodName: String; AParamName: String = ''): Boolean;
function QtDefaultPrinter: TQtPrinter;
function Clipboard: TQtClipboard;
function QtDefaultContext: TQtDeviceContext;
function QtScreenContext: TQtDeviceContext;
procedure AssignQtFont(FromFont: QFontH; ToFont: QFontH);
function IsFontEqual(AFont1, AFont2: TQtFont): Boolean;
var
QtGDIObjects: TQtGDIObjects = nil;
implementation
uses
Controls, LazUtilities, qtproc;
const
ClipbBoardTypeToQtClipboard: array[TClipboardType] of QClipboardMode =
(
{ctPrimarySelection } QClipboardSelection,
{ctSecondarySelection} QClipboardSelection,
{ctClipboard } QClipboardClipboard
);
const
Rop2CompSupported: Array[Boolean] of TRop2OrCompositionSupport =
(rocNotSupported, rocSupported);
const
SQTWSPrefix = 'TQTWidgetSet.';
{$IFDEF HASX11}
// defined here to reduce includes (qtint)
LCLQt_ClipboardPrimarySelection = QEventType(Ord(QEventUser) + $1004);
{$ENDIF}
var
FClipboard: TQtClipboard = nil;
FDefaultContext: TQtDeviceContext = nil;
FScreenContext: TQtDeviceContext = nil;
FPrinter: TQtPrinter = nil;
{------------------------------------------------------------------------------
Name: CheckGDIObject
Params: GDIObject - Handle to a GDI Object (TQTFont, ...)
AMethodName - Method name
AParamName - Param name
Returns: If the GDIObject is valid
Remark: All handles for GDI objects must be pascal objects so we can
distinguish between them
------------------------------------------------------------------------------}
function CheckGDIObject(const AGDIObject: HGDIOBJ; const AMethodName: String;
AParamName: String): Boolean;
begin
{$note CheckGDIObject TODO: make TQTImage a TQtResource}
Result := (TObject(AGDIObject) is TQtResource) or (TObject(AGDIObject) is TQtImage);
if Result then Exit;
if Pos('.', AMethodName) = 0 then
DebugLn(SQTWSPrefix + AMethodName + ' Error - invalid GDIObject ' +
AParamName + ' = ' + DbgS(AGDIObject) + '!')
else
DebugLn(AMethodName + ' Error - invalid GDIObject ' + AParamName + ' = ' +
DbgS(AGDIObject) + '!');
end;
{------------------------------------------------------------------------------
Name: CheckBitmap
Params: Bitmap - Handle to a bitmap (TQTBitmap)
AMethodName - Method name
AParamName - Param name
Returns: If the bitmap is valid
------------------------------------------------------------------------------}
function CheckBitmap(const ABitmap: HBITMAP; const AMethodName: String;
AParamName: String): Boolean;
begin
Result := TObject(ABitmap) is TQTImage;
if Result then Exit;
if Pos('.', AMethodName) = 0 then
DebugLn(SQTWSPrefix + AMethodName + ' Error - invalid bitmap ' +
AParamName + ' = ' + DbgS(ABitmap) + '!')
else
DebugLn(AMethodName + ' Error - invalid bitmap ' + AParamName + ' = ' +
DbgS(ABitmap) + '!');
end;
function QtDefaultContext: TQtDeviceContext;
begin
if FDefaultContext = nil then
FDefaultContext := TQtDeviceContext.Create(nil, False);
Result := FDefaultContext;
end;
function QtScreenContext: TQtDeviceContext;
begin
if FScreenContext = nil then
FScreenContext := TQtDeviceContext.Create(QApplication_desktop(), False);
Result := FScreenContext;
end;
procedure AssignQtFont(FromFont: QFontH; ToFont: QFontH);
var
FntFam: WideString;
begin
QFont_family(FromFont, @FntFam);
QFont_setFamily(ToFont, @FntFam);
if QFont_pixelSize(FromFont) > 0 then
QFont_setPixelSize(ToFont, QFont_pixelSize(FromFont))
else
QFont_setPointSize(ToFont, QFont_pointSize(FromFont));
QFont_setWeight(ToFont, QFont_weight(FromFont));
QFont_setBold(ToFont, QFont_bold(FromFont));
QFont_setItalic(ToFont, QFont_italic(FromFont));
QFont_setUnderline(ToFont, QFont_underline(FromFont));
QFont_setStrikeOut(ToFont, QFont_strikeOut(FromFont));
QFont_setStyle(ToFont, QFont_style(FromFont));
QFont_setStyleStrategy(ToFont, QFont_styleStrategy(FromFont));
end;
function IsFontEqual(AFont1, AFont2: TQtFont): Boolean;
var
AInfo1, AInfo2: TQtFontInfo;
begin
Result := False;
if (AFont1 = nil) or (AFont2 = nil) then
exit;
if (AFont1.FHandle = nil) or (AFont2.FHandle = nil) then
exit;
AInfo1 := AFont1.FontInfo;
AInfo2 := AFont2.FontInfo;
if (AInfo1 = nil) or (AInfo2 = nil) then
exit;
Result := (AInfo1.Family = AInfo2.Family) and (AInfo1.Bold = AInfo2.Bold) and
(AInfo1.Italic = AInfo2.Italic) and (AInfo1.FixedPitch = AInfo2.FixedPitch) and
(AInfo1.Underline = AInfo2.Underline) and (AInfo1.Overline = AInfo2.OverLine) and
(AInfo1.PixelSize = AInfo2.PixelSize) and (AInfo1.PointSize = AInfo2.PointSize) and
(AInfo1.StrikeOut = AInfo2.StrikeOut) and (AInfo1.Weight = AInfo2.Weight) and
(AInfo1.RawMode = AInfo2.RawMode) and (AInfo1.Style = AInfo2.Style) and
(AInfo1.StyleHint = AInfo2.StyleHint);
end;
{ TQtFontInfo }
function TQtFontInfo.GetBold: Boolean;
begin
Result := QFontInfo_bold(FHandle);
end;
function TQtFontInfo.GetExactMatch: Boolean;
begin
Result := QFontInfo_exactMatch(FHandle);
end;
function TQtFontInfo.GetFamily: WideString;
begin
QFontInfo_family(FHandle, @Result);
end;
function TQtFontInfo.GetFixedPitch: Boolean;
begin
Result := QFontInfo_fixedPitch(FHandle);
end;
function TQtFontInfo.GetFontStyle: QFontStyle;
begin
Result := QFontInfo_style(FHandle);
end;
function TQtFontInfo.GetFontStyleHint: QFontStyleHint;
begin
Result := QFontInfo_styleHint(FHandle);
end;
function TQtFontInfo.GetItalic: Boolean;
begin
Result := QFontInfo_italic(FHandle);
end;
function TQtFontInfo.GetOverLine: Boolean;
begin
Result := QFontInfo_overline(FHandle);
end;
function TQtFontInfo.GetPixelSize: Integer;
begin
Result := QFontInfo_pixelSize(FHandle);
end;
function TQtFontInfo.GetPointSize: Integer;
begin
Result := QFontInfo_pointSize(FHandle);
end;
function TQtFontInfo.GetRawMode: Boolean;
begin
Result := QFontInfo_rawMode(FHandle);
end;
function TQtFontInfo.GetStrikeOut: Boolean;
begin
Result := QFontInfo_strikeOut(FHandle);
end;
function TQtFontInfo.GetUnderline: Boolean;
begin
Result := QFontInfo_underline(FHandle);
end;
function TQtFontInfo.GetWeight: Integer;
begin
Result := QFontInfo_weight(FHandle);
end;
constructor TQtFontInfo.Create(AFont: QFontH);
begin
FHandle := QFontInfo_create(AFont);
end;
destructor TQtFontInfo.Destroy;
begin
QFontInfo_destroy(FHandle);
inherited Destroy;
end;
{ TQtObject }
constructor TQtObject.Create;
begin
FDeleteLater := False;
FEventHook := nil;
FUpdateCount := 0;
FInEventCount := 0;
FReleaseInEvent := False;
end;
destructor TQtObject.Destroy;
begin
if TheObject <> nil then
begin
DetachEvents;
if FDeleteLater then
QObject_deleteLater(TheObject)
else
QObject_destroy(TheObject);
TheObject := nil;
end;
inherited Destroy;
end;
procedure TQtObject.Release;
begin
if InEvent then
begin
FDeleteLater := True;
FReleaseInEvent := True;
end else
Free;
end;
procedure TQtObject.AttachEvents;
begin
FEventHook := QObject_hook_create(TheObject);
QObject_hook_hook_events(FEventHook, @EventFilter);
FDestroyedHook := QObject_hook_create(TheObject);
QObject_hook_hook_destroyed(FDestroyedHook, @Destroyed);
end;
procedure TQtObject.DetachEvents;
begin
if FEventHook <> nil then
begin
QObject_hook_destroy(FEventHook);
FEventHook := nil;
end;
if FDestroyedHook <> nil then
begin
QObject_hook_destroy(FDestroyedHook);
FDestroyedHook := nil;
end;
end;
procedure TQtObject.Destroyed; cdecl;
begin
end;
procedure TQtObject.BeginEventProcessing;
begin
inc(FInEventCount);
end;
procedure TQtObject.EndEventProcessing;
begin
if FInEventCount > 0 then
dec(FInEventCount);
if (FInEventCount = 0) and FReleaseInEvent then
Free;
end;
function TQtObject.InEvent: Boolean;
begin
Result := FInEventCount > 0;
end;
procedure TQtObject.BeginUpdate;
begin
inc(FUpdateCount);
end;
procedure TQtObject.EndUpdate;
begin
if FUpdateCount > 0 then
dec(FUpdateCount);
end;
function TQtObject.InUpdate: Boolean;
begin
Result := FUpdateCount > 0;
end;
{ TQtAction }
{------------------------------------------------------------------------------
Method: TQtAction.Create
Constructor for the class.
------------------------------------------------------------------------------}
constructor TQtAction.Create(const AHandle: QActionH);
begin
FHandle := AHandle;
FIcon := nil;
end;
{------------------------------------------------------------------------------
Method: TQtAction.Destroy
Destructor for the class.
------------------------------------------------------------------------------}
destructor TQtAction.Destroy;
begin
if FIcon <> nil then
QIcon_destroy(FIcon);
if FHandle <> nil then
QAction_destroy(FHandle);
inherited Destroy;
end;
{------------------------------------------------------------------------------
Method: TQtAction.SlotTriggered
Callback for menu item click
------------------------------------------------------------------------------}
procedure TQtAction.SlotTriggered(checked: Boolean); cdecl;
begin
if Assigned(MenuItem) and Assigned(MenuItem.OnClick) then
MenuItem.OnClick(Self.MenuItem);
end;
{------------------------------------------------------------------------------
Method: TQtAction.setChecked
Checks or unchecks a menu entry
To mimic the behavior LCL should have we added code to handle
setCheckable automatically
------------------------------------------------------------------------------}
procedure TQtAction.setChecked(p1: Boolean);
begin
if p1 then setCheckable(True)
else setCheckable(False);
QAction_setChecked(FHandle, p1);
end;
{------------------------------------------------------------------------------
Method: TQtAction.setCheckable
Set's if a menu can be checked. Is false by default
------------------------------------------------------------------------------}
procedure TQtAction.setCheckable(p1: Boolean);
begin
QAction_setCheckable(FHandle, p1);
end;
{------------------------------------------------------------------------------
Method: TQtAction.setEnabled
------------------------------------------------------------------------------}
procedure TQtAction.setEnabled(p1: Boolean);
begin
QAction_setEnabled(FHandle, p1);
end;
procedure TQtAction.setIcon(const AIcon: QIconH);
begin
QAction_setIcon(FHandle, AIcon);
end;
procedure TQtAction.setImage(const AImage: TQtImage);
begin
if FIcon <> nil then
begin
QIcon_destroy(FIcon);
FIcon := nil;
end;
if AImage <> nil then
FIcon := AImage.AsIcon()
else
FIcon := QIcon_create();
setIcon(FIcon);
end;
{------------------------------------------------------------------------------
Method: TQtAction.setVisible
------------------------------------------------------------------------------}
procedure TQtAction.setVisible(p1: Boolean);
begin
QAction_setVisible(FHandle, p1);
end;
{ TQtImage }
constructor TQtImage.Create;
begin
FHandle := QImage_create();
FData := nil;
FDataOwner := False;
QtGDIObjects.AddGDIObject(Self);
end;
{------------------------------------------------------------------------------
Method: TQtImage.Create
Constructor for the class.
------------------------------------------------------------------------------}
constructor TQtImage.Create(vHandle: QImageH);
begin
FHandle := vHandle;
FData := nil;
FDataOwner := False;
QtGDIObjects.AddGDIObject(Self);
end;
{------------------------------------------------------------------------------
Method: TQtImage.Create
Constructor for the class.
------------------------------------------------------------------------------}
constructor TQtImage.Create(AData: PByte; width: Integer; height: Integer;
format: QImageFormat; const ADataOwner: Boolean = False);
begin
FData := AData;
FDataOwner := ADataOwner;
if FData = nil then
begin
FHandle := QImage_create(width, height, format);
QImage_fill(FHandle, 0);
end
else
begin
FHandle := QImage_create(FData, width, height, format);
if format = QImageFormat_Mono then
begin
QImage_setColorCount(FHandle, 2);
{$IFDEF DARWIN}
//rgba
QImage_SetColor(FHandle, 0, $000000FF);
{$ELSE}
//argb
QImage_SetColor(FHandle, 0, $FF000000);
{$ENDIF}
QImage_SetColor(FHandle, 1, $FFFFFFFF);
end;
end;
QtGDIObjects.AddGDIObject(Self);
end;
constructor TQtImage.Create(AData: PByte; width: Integer; height: Integer;
bytesPerLine: Integer; format: QImageFormat; const ADataOwner: Boolean);
begin
FData := AData;
FDataOwner := ADataOwner;
if FData = nil then
FHandle := QImage_create(width, height, format)
else
begin
FHandle := QImage_create(FData, width, height, bytesPerLine, format);
if format = QImageFormat_Mono then
begin
QImage_setColorCount(FHandle, 2);
{$IFDEF DARWIN}
// rgba
QImage_SetColor(FHandle, 0, $000000FF);
{$ELSE}
// argb
QImage_SetColor(FHandle, 0, $FF000000);
{$ENDIF}
QImage_SetColor(FHandle, 1, $FFFFFFFF);
end;
end;
QtGDIObjects.AddGDIObject(Self);
end;
{------------------------------------------------------------------------------
Method: TQtImage.Destroy
Params: None
Returns: Nothing
Destructor for the class.
------------------------------------------------------------------------------}
destructor TQtImage.Destroy;
begin
{$ifdef VerboseQt}
WriteLn('TQtImage.Destroy Handle:', dbgs(Handle));
{$endif}
QtGDIObjects.RemoveGDIObject(Self);
if FHandle <> nil then
QImage_destroy(FHandle);
if (FDataOwner) and (FData <> nil) then
FreeMem(FData);
inherited Destroy;
end;
function TQtImage.AsIcon(AMode: QIconMode = QIconNormal; AState: QIconState = QIconOff): QIconH;
var
APixmap: QPixmapH;
begin
APixmap := AsPixmap;
Result := QIcon_create();
if Result <> nil then
QIcon_addPixmap(Result, APixmap, AMode, AState);
QPixmap_destroy(APixmap);
end;
function TQtImage.AsPixmap(flags: QtImageConversionFlags = QtAutoColor): QPixmapH;
begin
Result := QPixmap_create();
QPixmap_fromImage(Result, FHandle, flags);
end;
function TQtImage.AsBitmap(flags: QtImageConversionFlags = QtAutoColor): QBitmapH;
begin
Result := QBitmap_create();
QBitmap_fromImage(Result, FHandle, flags);
end;
procedure TQtImage.CopyFrom(AImage: QImageH; x, y, w, h: integer);
begin
QImage_copy(AImage, FHandle, x, y, w, h);
end;
{------------------------------------------------------------------------------
Method: TQtImage.height
Params: None
Returns: The height of the image
------------------------------------------------------------------------------}
function TQtImage.height: Integer;
begin
Result := QImage_height(FHandle);
end;
{------------------------------------------------------------------------------
Method: TQtImage.width
Params: None
Returns: The width of the image
------------------------------------------------------------------------------}
function TQtImage.width: Integer;
begin
Result := QImage_width(FHandle);
end;
function TQtImage.depth: Integer;
begin
Result := QImage_depth(FHandle);
end;
function TQtImage.dotsPerMeterX: Integer;
begin
Result := QImage_dotsPerMeterX(FHandle);
end;
function TQtImage.dotsPerMeterY: Integer;
begin
Result := QImage_dotsPerMeterY(FHandle);
end;
{------------------------------------------------------------------------------
Method: TQtImage.bits
Params: None
Returns: The internal array of bits of the image
------------------------------------------------------------------------------}
function TQtImage.bits: PByte;
begin
Result := QImage_constBits(FHandle);
end;
{------------------------------------------------------------------------------
Method: TQtImage.numBytes
Params: None
Returns: The number of bytes the image occupies in memory
------------------------------------------------------------------------------}
function TQtImage.numBytes: Integer;
begin
Result := QImage_numBytes(FHandle);
end;
function TQtImage.bytesPerLine: Integer;
begin
Result := QImage_bytesPerLine(FHandle);
end;
procedure TQtImage.invertPixels(InvertMode: QImageInvertMode = QImageInvertRgb);
begin
QImage_invertPixels(FHandle, InvertMode);
end;
function TQtImage.getFormat: QImageFormat;
begin
Result := QImage_format(FHandle);
end;
{ TQtFont }
function TQtFont.GetMetrics: TQtFontMetrics;
begin
if FMetrics = nil then
begin
if FHandle = nil then
FMetrics := TQtFontMetrics.Create(getDefaultFont)
else
FMetrics := TQtFontMetrics.Create(FHandle);
end;
Result := FMetrics;
end;
function TQtFont.GetFontInfo: TQtFontInfo;
begin
if not Assigned(FFontInfo) and Assigned(FHandle) then
FFontInfo := TQtFontInfo.Create(FHandle);
Result := FFontInfo;
end;
{------------------------------------------------------------------------------
Function: TQtFont.GetDefaultFont
Params: None
Returns: QFontH
If our Widget is nil then we have to ask for default application font.
------------------------------------------------------------------------------}
function TQtFont.GetDefaultFont: QFontH;
begin
if FDefaultFont = nil then
begin
FDefaultFont := QFont_create();
QApplication_font(FDefaultFont);
end;
Result := FDefaultFont;
end;
{------------------------------------------------------------------------------
Function: TQtFont.Create
Params: None
Returns: Nothing
------------------------------------------------------------------------------}
constructor TQtFont.Create(CreateHandle: Boolean);
begin
{$ifdef VerboseQt}
WriteLn('TQtFont.Create CreateHandle: ', dbgs(CreateHandle));
{$endif}
if CreateHandle then
FHandle := QFont_create
else
FHandle := nil;
FShared := False;
FMetrics := nil;
FDefaultFont := nil;
FFontInfo := nil;
QtGDIObjects.AddGDIObject(Self);
end;
constructor TQtFont.Create(AFromFont: QFontH);
begin
{$ifdef VerboseQt}
WriteLn('TQtFont.Create AFromFont: ', dbgs(AFromFont));
{$endif}
FHandle := QFont_create(AFromFont);
FShared := False;
FMetrics := nil;
FDefaultFont := nil;
GetFontInfo;
QtGDIObjects.AddGDIObject(Self);
end;
{------------------------------------------------------------------------------
Function: TQtFont.Destroy
Params: None
Returns: Nothing
------------------------------------------------------------------------------}
destructor TQtFont.Destroy;
begin
{$ifdef VerboseQt}
WriteLn('TQtFont.Destroy');
{$endif}
QtGDIObjects.RemoveGDIObject(Self);
if FMetrics <> nil then
FMetrics.Free;
if FFontInfo <> nil then
FFontInfo.Free;
if not FShared and (FHandle <> nil) then
QFont_destroy(FHandle);
if FDefaultFont <> nil then
QFont_destroy(FDefaultFont);
inherited Destroy;
end;
function TQtFont.getPointSize: Integer;
begin
if FHandle = nil then
Result := QFont_pointSize(getDefaultFont)
else
Result := QFont_pointSize(FHandle);
end;
procedure TQtFont.setPointSize(p1: Integer);
begin
if p1 > 0 then
QFont_setPointSize(FHandle, p1);
end;
function TQtFont.getPixelSize: Integer;
begin
if FHandle = nil then
Result := QFont_pixelSize(getDefaultFont)
else
Result := QFont_pixelSize(FHandle);
end;
procedure TQtFont.setPixelSize(p1: Integer);
begin
if p1 > 0 then
QFont_setPixelSize(FHandle, p1);
end;
function TQtFont.getWeight: Integer;
begin
if FHandle = nil then
Result := QFont_weight(getDefaultFont)
else
Result := QFont_weight(FHandle);
end;
function TQtFont.getItalic: Boolean;
begin
if FHandle = nil then
Result := QFont_italic(getDefaultFont)
else
Result := QFont_italic(FHandle);
end;
function TQtFont.getBold: Boolean;
begin
if FHandle = nil then
Result := QFont_bold(getDefaultFont)
else
Result := QFont_bold(FHandle);
end;
function TQtFont.getUnderline: Boolean;
begin
if FHandle = nil then
Result := QFont_underline(getDefaultFont)
else
Result := QFont_underline(FHandle);
end;
function TQtFont.getStrikeOut: Boolean;
begin
if FHandle = nil then
Result := QFont_strikeOut(getDefaultFont)
else
Result := QFont_strikeOut(FHandle);
end;
function TQtFont.getFamily: WideString;
begin
if FHandle = nil then
QFont_family(getDefaultFont, @Result)
else
QFont_family(FHandle, @Result);
end;
function TQtFont.getStyleStategy: QFontStyleStrategy;
begin
if FHandle = nil then
Result := QFont_styleStrategy(getDefaultFont)
else
Result := QFont_styleStrategy(FHandle);
end;
procedure TQtFont.setWeight(p1: Integer);
begin
QFont_setWeight(FHandle, p1);
end;
procedure TQtFont.setBold(p1: Boolean);
begin
QFont_setBold(FHandle, p1);
end;
procedure TQtFont.setItalic(b: Boolean);
begin
QFont_setItalic(FHandle, b);
end;
procedure TQtFont.setUnderline(p1: Boolean);
begin
QFont_setUnderline(FHandle, p1);
end;
procedure TQtFont.setStrikeOut(p1: Boolean);
begin
QFont_setStrikeOut(FHandle, p1);
end;
procedure TQtFont.setRawName(p1: string);
var
Str: WideString;
begin
Str := {%H-}p1;
QFont_setRawName(FHandle, @Str);
end;
procedure TQtFont.setFamily(p1: string);
var
Str: WideString;
begin
Str := {%H-}p1;
QFont_setFamily(FHandle, @Str);
end;
procedure TQtFont.setStyleStrategy(s: QFontStyleStrategy);
begin
QFont_setStyleStrategy(FHandle, s);
end;
procedure TQtFont.family(retval: PWideString);
begin
if FHandle = nil then
QFont_family(getDefaultFont, retval)
else
QFont_family(FHandle, retval);
end;
function TQtFont.fixedPitch: Boolean;
begin
if FHandle = nil then
Result := QFont_fixedPitch(getDefaultFont)
else
Result := QFont_fixedPitch(FHandle);
end;
{ TQtFontMetrics }
constructor TQtFontMetrics.Create(Parent: QFontH);
begin
FHandle := QFontMetrics_create(Parent);
end;
destructor TQtFontMetrics.Destroy;
begin
QFontMetrics_destroy(FHandle);
FHandle := nil;
inherited Destroy;
end;
function TQtFontMetrics.height: Integer;
begin
Result := QFontMetrics_height(FHandle);
end;
function TQtFontMetrics.width(p1: PWideString): Integer;
begin
Result := QFontMetrics_width(FHandle, p1);
end;
function TQtFontMetrics.width(p1: PWideString; ALen: Integer): Integer;
begin
Result := QFontMetrics_width(FHandle, p1, ALen);
end;
function TQtFontMetrics.ascent: Integer;
begin
Result := QFontMetrics_ascent(FHandle);
end;
function TQtFontMetrics.descent: Integer;
begin
Result := QFontMetrics_descent(FHandle);
end;
function TQtFontMetrics.leading: Integer;
begin
Result := QFontMetrics_leading(FHandle);
end;
function TQtFontMetrics.maxWidth: Integer;
begin
Result := QFontMetrics_maxWidth(FHandle);
end;
procedure TQtFontMetrics.boundingRect(retval: PRect; r: PRect; flags: Integer; text: PWideString; tabstops: Integer = 0; tabarray: PInteger = nil);
begin
QFontMetrics_boundingRect(FHandle, retval, r, flags, text, tabstops, tabarray);
end;
function TQtFontMetrics.charWidth(str: WideString; pos: Integer): Integer;
begin
Result := QFontMetrics_charWidth(FHandle, @str, pos);
end;
function TQtFontMetrics.averageCharWidth: Integer;
begin
Result := QFontMetrics_averageCharWidth(FHandle);
end;
function TQtFontMetrics.elidedText(const AText: WideString;
const AMode: QtTextElideMode; const AWidth: Integer;
const AFlags: Integer = 0): WideString;
begin
QFontMetrics_elidedText(FHandle, @Result, @AText, AMode, AWidth, AFlags);
end;
{ TQtBrush }
{------------------------------------------------------------------------------
Function: TQtBrush.Create
Params: None
Returns: Nothing
------------------------------------------------------------------------------}
constructor TQtBrush.Create(CreateHandle: Boolean);
begin
// Creates the widget
{$ifdef VerboseQt}
WriteLn('TQtBrush.Create CreateHandle: ', dbgs(CreateHandle));
{$endif}
if CreateHandle then
FHandle := QBrush_create
else
FHandle := nil;
FShared := False;
FSelected := False;
QtGDIObjects.AddGDIObject(Self);
end;
constructor TQtBrush.CreateWithRadialGradient(ALogBrush: TLogRadialGradient);
var
i: Integer;
lColor: TQColor;
lR, lG, lB, lA: Double;
begin
FRadialGradient := QRadialGradient_create(
ALogBrush.radCenterX, ALogBrush.radCenterY, ALogBrush.radCenterY,
ALogBrush.radFocalX, ALogBrush.radFocalY);
for i := 0 to Length(ALogBrush.radStops) - 1 do
begin
lR := ALogBrush.radStops[i].radColorR / $FFFF;
lG := ALogBrush.radStops[i].radColorG / $FFFF;
lB := ALogBrush.radStops[i].radColorB / $FFFF;
lA := ALogBrush.radStops[i].radColorA / $FFFF;
QColor_fromRgbF(@lColor, lR, lG, lB, lA);
QGradient_setColorAt(FRadialGradient, ALogBrush.radStops[i].radPosition, @lColor);
end;
FHandle := QBrush_create(FRadialGradient);
end;
{------------------------------------------------------------------------------
Function: TQtBrush.Destroy
Params: None
Returns: Nothing
------------------------------------------------------------------------------}
destructor TQtBrush.Destroy;
begin
{$ifdef VerboseQt}
WriteLn('TQtBrush.Destroy');
{$endif}
QtGDIObjects.RemoveGDIObject(Self);
if not FShared and (FHandle <> nil) and not FSelected then
QBrush_destroy(FHandle);
inherited Destroy;
end;
function TQtBrush.getColor: PQColor;
begin
Result := QBrush_Color(FHandle);
end;
function TQtBrush.GetLBStyle(out AStyle: LongWord; out AHatch: PtrUInt
): Boolean;
begin
Result := FHandle <> nil;
if not Result then
exit;
AStyle := BS_SOLID;
if Style in [QtHorPattern, QtVerPattern, QtCrossPattern,
QtBDiagPattern, QtFDiagPattern, QtDiagCrossPattern] then
AStyle := BS_HATCHED
else
AHatch := 0;
case Style of
QtNoBrush: AStyle := BS_NULL;
QtHorPattern: AHatch := HS_HORIZONTAL;
QtVerPattern: AHatch := HS_VERTICAL;
QtCrossPattern: AHatch := HS_CROSS;
QtBDiagPattern: AHatch := HS_BDIAGONAL;
QtFDiagPattern: AHatch := HS_FDIAGONAL;
QtDiagCrossPattern: AHatch := HS_DIAGCROSS;
QtTexturePattern: AStyle := BS_PATTERN;
end;
end;
procedure TQtBrush.setColor(AColor: PQColor);
begin
QBrush_setColor(FHandle, AColor);
end;
function TQtBrush.getStyle: QtBrushStyle;
begin
Result := QBrush_style(FHandle);
end;
{------------------------------------------------------------------------------
Function: TQtBrush.setStyle
Params: None
Returns: Nothing
------------------------------------------------------------------------------}
procedure TQtBrush.setStyle(style: QtBrushStyle);
begin
QBrush_setStyle(FHandle, style);
end;
procedure TQtBrush.setTexture(pixmap: QPixmapH);
begin
QBrush_setTexture(FHandle, pixmap);
end;
procedure TQtBrush.setTextureImage(image: QImageH);
var
TempImage: QImageH;
begin
// workaround thurther deletion of original image
// When image is deleted its data will be deleted too
// If image has been created with predefined data then it will be owner of it
// => it will Free owned data => brush will be invalid
// as workaround we are copying an original image so qt create new image with own data
TempImage := QImage_create();
QImage_copy(image, TempImage, 0, 0, QImage_width(image), QImage_height(image));
QBrush_setTextureImage(FHandle, TempImage);
QImage_destroy(TempImage);
end;
{ TQtPen }
{------------------------------------------------------------------------------
Function: TQtPen.Create
Params: None
Returns: Nothing
------------------------------------------------------------------------------}
constructor TQtPen.Create(CreateHandle: Boolean);
begin
{$ifdef VerboseQt}
WriteLn('TQtPen.Create CreateHandle: ', dbgs(CreateHandle));
{$endif}
if CreateHandle then
FHandle := QPen_create
else
FHandle := nil;
FShared := False;
FIsExtPen := False;
QtGDIObjects.AddGDIObject(Self);
end;
{------------------------------------------------------------------------------
Function: TQtPen.Destroy
Params: None
Returns: Nothing
------------------------------------------------------------------------------}
destructor TQtPen.Destroy;
begin
{$ifdef VerboseQt}
WriteLn('TQtPen.Destroy');
{$endif}
QtGDIObjects.RemoveGDIObject(Self);
if not FShared and (FHandle <> nil) then
QPen_destroy(FHandle);
inherited Destroy;
end;
function TQtPen.getCapStyle: QtPenCapStyle;
begin
Result := QPen_capStyle(FHandle);
end;
function TQtPen.getWidth: Integer;
begin
Result := QPen_width(FHandle);
end;
function TQtPen.getStyle: QtPenStyle;
begin
Result := QPen_style(FHandle);
end;
function TQtPen.getDashPattern: TQRealArray;
begin
QPen_dashPattern(FHandle, @Result);
end;
{------------------------------------------------------------------------------
Function: TQtPen.setBrush
Params: None
Returns: Nothing
------------------------------------------------------------------------------}
procedure TQtPen.setBrush(brush: QBrushH);
begin
QPen_setBrush(FHandle, brush);
end;
{------------------------------------------------------------------------------
Function: TQtPen.setStyle
Params: None
Returns: Nothing
------------------------------------------------------------------------------}
procedure TQtPen.setStyle(AStyle: QtPenStyle);
begin
QPen_setStyle(FHandle, AStyle);
end;
{------------------------------------------------------------------------------
Function: TQtPen.setWidth
Params: None
Returns: Nothing
------------------------------------------------------------------------------}
procedure TQtPen.setWidth(p1: Integer);
begin
QPen_setWidth(FHandle, p1);
end;
procedure TQtPen.setDashPattern(APattern: PDWord; ALength: DWord);
var
QtPattern: TQRealArray;
i: integer;
begin
QtPattern := nil;
SetLength(QtPattern, ALength);
for i := 0 to ALength - 1 do
QtPattern[i] := APattern[i];
QPen_setDashPattern(FHandle, @QtPattern);
end;
procedure TQtPen.setJoinStyle(pcs: QtPenJoinStyle);
begin
QPen_setJoinStyle(FHandle, pcs);
end;
function TQtPen.getColor: TQColor;
begin
QPen_color(FHandle, @Result);
end;
function TQtPen.getCosmetic: Boolean;
begin
Result := QPen_isCosmetic(FHandle);
end;
function TQtPen.getJoinStyle: QtPenJoinStyle;
begin
Result := QPen_joinStyle(FHandle);
end;
procedure TQtPen.setCapStyle(pcs: QtPenCapStyle);
begin
QPen_setCapStyle(FHandle, pcs);
end;
{------------------------------------------------------------------------------
Function: TQtPen.setColor
Params: p1: TQColor
Returns: Nothing
Setting pen color.
------------------------------------------------------------------------------}
procedure TQtPen.setColor(p1: TQColor);
begin
QPen_setColor(FHandle, @p1);
end;
procedure TQtPen.setCosmetic(b: Boolean);
begin
QPen_setCosmetic(FHandle, b);
end;
{ TQtRegion }
{------------------------------------------------------------------------------
Function: TQtRegion.Create
Params: CreateHandle: Boolean
Returns: Nothing
------------------------------------------------------------------------------}
constructor TQtRegion.Create(CreateHandle: Boolean);
begin
{$ifdef VerboseQt}
WriteLn('TQtRegion.Create CreateHandle: ', dbgs(CreateHandle));
{$endif}
FPolygon := nil;
// Creates the widget
if CreateHandle then
FHandle := QRegion_create()
else
FHandle := nil;
QtGDIObjects.AddGDIObject(Self);
end;
{------------------------------------------------------------------------------
Function: TQtRegion.Create (CreateRectRgn)
Params: CreateHandle: Boolean; X1,Y1,X2,Y2:Integer
Returns: Nothing
------------------------------------------------------------------------------}
constructor TQtRegion.Create(CreateHandle: Boolean; X1,Y1,X2,Y2:Integer;
Const RegionType: QRegionRegionType = QRegionRectangle);
var
W, H: Integer;
begin
{$ifdef VerboseQt}
WriteLn('TQtRegion.Create CreateHandle: ', dbgs(CreateHandle));
{$endif}
FPolygon := nil;
// Creates the widget
// Note that QRegion_create expects a width and a height,
// and not a X2, Y2 bottom-right point
if CreateHandle then
begin
W := X2 - X1;
H := Y2 - Y1;
if W < 0 then
W := 0;
if H < 0 then
H := 0;
FHandle := QRegion_create(X1, Y1, W, H, RegionType);
end else
FHandle := nil;
QtGDIObjects.AddGDIObject(Self);
end;
constructor TQtRegion.Create(CreateHandle: Boolean; Poly: QPolygonH;
Const Fill: QtFillRule = QtWindingFill);
begin
{$ifdef VerboseQt}
WriteLn('TQtRegion.Create polyrgn CreateHandle: ', dbgs(CreateHandle));
{$endif}
FPolygon := nil;
if CreateHandle then
begin
FPolygon := QPolygon_create(Poly);
FHandle := QRegion_create(FPolygon, Fill);
end else
FHandle := nil;
QtGDIObjects.AddGDIObject(Self);
end;
{------------------------------------------------------------------------------
Function: TQtRegion.Destroy
Params: None
Returns: Nothing
------------------------------------------------------------------------------}
destructor TQtRegion.Destroy;
begin
{$ifdef VerboseQt}
WriteLn('TQtRegion.Destroy');
{$endif}
QtGDIObjects.RemoveGDIObject(Self);
if FPolygon <> nil then
QPolygon_destroy(FPolygon);
if FHandle <> nil then
QRegion_destroy(FHandle);
inherited Destroy;
end;
function TQtRegion.GetIsPolyRegion: Boolean;
begin
Result := FPolygon <> nil;
end;
function TQtRegion.containsPoint(X, Y: Integer): Boolean;
var
P: TQtPoint;
begin
P.X := X;
P.Y := Y;
Result := QRegion_contains(FHandle, PQtPoint(@P));
end;
function TQtRegion.containsRect(R: TRect): Boolean;
begin
Result := QRegion_contains(FHandle, PRect(@R));
end;
function TQtRegion.intersects(R: TRect): Boolean;
begin
Result := QRegion_intersects(FHandle, PRect(@R));
end;
function TQtRegion.intersects(Rgn: QRegionH): Boolean;
begin
Result := QRegion_intersects(FHandle, Rgn);
end;
function TQtRegion.GetRegionType: integer;
begin
try
if not IsPolyRegion and QRegion_isEmpty(FHandle) then
Result := NULLREGION
else
begin
if IsPolyRegion or (QRegion_numRects(FHandle) > 1) then
Result := COMPLEXREGION
else
Result := SIMPLEREGION;
end;
except
Result := ERROR;
end;
end;
function TQtRegion.getBoundingRect: TRect;
begin
if IsPolyRegion then
QPolygon_boundingRect(FPolygon, @Result)
else
QRegion_boundingRect(FHandle, @Result);
end;
function TQtRegion.numRects: Integer;
begin
Result := QRegion_numRects(FHandle);
end;
procedure TQtRegion.translate(dx, dy: Integer);
begin
QRegion_translate(FHandle, dx, dy);
end;
{ TQtDeviceContext }
{------------------------------------------------------------------------------
Function: TQtDeviceContext.Create
Params: None
Returns: Nothing
------------------------------------------------------------------------------}
constructor TQtDeviceContext.Create(AWidget: QWidgetH; const APaintEvent: Boolean = False);
var
W: Integer;
H: Integer;
begin
{$ifdef VerboseQt}
WriteLn('TQtDeviceContext.Create (',
' WidgetHandle: ', dbghex(PtrInt(AWidget)),
' FromPaintEvent:',BoolToStr(APaintEvent),' )');
{$endif}
{NOTE FOR QT DEVELOPERS: Whenever you call TQtDeviceContext.Create() outside
of TQtWidgetSet.BeginPaint() SET APaintEvent TO FALSE !}
FPenTextInternal := True;
FUserDC := False;
Parent := nil;
ParentPixmap := nil;
FMetrics := nil;
SelFont := nil;
SelBrush := nil;
SelPen := nil;
if AWidget = nil then
begin
ParentPixmap := QPixmap_Create(10, 10);
Widget := QPainter_Create(QPaintDeviceH(ParentPixmap));
end else
begin
Parent := AWidget;
if not APaintEvent then
begin
{avoid paints on null pixmaps !}
W := QWidget_width(Parent);
H := QWidget_height(Parent);
if W <= 0 then W := 1;
if H <= 0 then H := 1;
ParentPixmap := QPixmap_Create(W, H);
Widget := QPainter_create(QPaintDeviceH(ParentPixmap));
end else
Widget := QPainter_create(QWidget_to_QPaintDevice(Parent));
end;
{$IFDEF USEQT4COMPATIBILEPAINTER}
QPainter_setRenderHint(Widget, QPainterQt4CompatiblePainting);
{$ENDIF}
FRopMode := R2_COPYPEN;
FOwnPainter := True;
CreateObjects;
FPenPos.X := 0;
FPenPos.Y := 0;
end;
constructor TQtDeviceContext.CreatePrinterContext(ADevice: QPrinterH);
begin
FPenTextInternal := True;
FUserDC := False;
SelFont := nil;
SelBrush := nil;
SelPen := nil;
FMetrics := nil;
Parent := nil;
Widget := QPainter_Create(ADevice);
{$IFDEF USEQT4COMPATIBILEPAINTER}
QPainter_setRenderHint(Widget, QPainterQt4CompatiblePainting);
{$ENDIF}
FRopMode := R2_COPYPEN;
FOwnPainter := True;
CreateObjects;
FPenPos.X := 0;
FPenPos.Y := 0;
end;
constructor TQtDeviceContext.CreateFromPainter(APainter: QPainterH);
begin
FPenTextInternal := True;
FUserDC := False;
SelFont := nil;
SelBrush := nil;
SelPen := nil;
FMetrics := nil;
FRopMode := R2_COPYPEN;
Widget := APainter;
Parent := nil;
FOwnPainter := False;
CreateObjects;
end;
{------------------------------------------------------------------------------
Function: TQtDeviceContext.Destroy
Params: None
Returns: Nothing
------------------------------------------------------------------------------}
destructor TQtDeviceContext.Destroy;
begin
{$ifdef VerboseQt}
WriteLn('TQtDeviceContext.Destroy');
{$endif}
if (vClipRect <> nil) then
dispose(vClipRect);
if FMetrics <> nil then
FreeThenNil(FMetrics);
DestroyObjects;
if (Widget <> nil) and FOwnPainter then
begin
QPainter_destroy(Widget);
Widget := nil;
end;
if ParentPixmap <> nil then
begin
QPixmap_destroy(ParentPixmap);
ParentPixmap := nil;
end;
inherited Destroy;
end;
procedure TQtDeviceContext.CreateObjects;
begin
FSupportComposition := rocUndefined;
FSupportRasterOps := rocUndefined;
vFont := TQtFont.Create(False);
vFont.Owner := Self;
vBrush := TQtBrush.Create(False);
vBrush.Owner := Self;
vBrush.FShared := True;
vPen := TQtPen.Create(False);
vPen.Owner := Self;
vPen.FShared := True;
vRegion := TQtRegion.Create(False);
vRegion.Owner := Self;
vBackgroundBrush := TQtBrush.Create(False);
vBackgroundBrush.Owner := Self;
vBackgroundBrush.FShared := True;
vTextColor := ColorToRGB(clWindowText);
vMapMode := MM_TEXT;
end;
procedure TQtDeviceContext.DestroyObjects;
begin
// vFont creates widget and copies font into it => we should destroy it
//vFont.Widget := nil;
FreeAndNil(vFont);
//WriteLn('Destroying brush: ', PtrUInt(vBrush), ' ', ClassName, ' ', PtrUInt(Self));
//vBrush.FHandle := nil;
FreeAndNil(vBrush);
// vPen.FHandle := nil;
FreeAndNil(vPen);
if Assigned(vRegion) and Assigned(vRegion.FHandle) then
begin
QRegion_destroy(vRegion.FHandle);
vRegion.FHandle := nil;
end;
FreeAndNil(vRegion);
// vBackgroundBrush.FHandle := nil;
FreeAndNil(vBackgroundBrush);
end;
{------------------------------------------------------------------------------
Function: TQtDeviceContext.DebugClipRect
Params: None
Returns: Nothing
------------------------------------------------------------------------------}
procedure TQtDeviceContext.DebugClipRect(const msg: string);
var
Rgn: QRegionH;
ok: boolean;
begin
ok := getClipping;
Write(Msg, 'DC: HasClipping=', ok);
if Ok then
begin
Rgn := QRegion_Create;
QPainter_ClipRegion(Widget, Rgn);
DebugRegion('', Rgn);
QRegion_Destroy(Rgn);
end
else
WriteLn;
end;
{------------------------------------------------------------------------------
Function: TQtDeviceContext.setImage
Params: None
Returns: Nothing
This function will destroy the previous DC handle and generate
a new one based on an image. This is necessary because when painting
is being done to a TBitmap, LCL will create a completely abstract DC,
using GetDC(0), and latter use SelectObject to associate that DC
with the Image.
------------------------------------------------------------------------------}
procedure TQtDeviceContext.setImage(AImage: TQtImage);
begin
{$ifdef VerboseQt}
writeln('TQtDeviceContext.setImage() ');
{$endif}
vImage := AImage;
QPainter_destroy(Widget);
Widget := QPainter_Create(vImage.FHandle);
{$IFDEF USEQT4COMPATIBILEPAINTER}
QPainter_setRenderHint(Widget, QPainterQt4CompatiblePainting);
{$ENDIF}
end;
{------------------------------------------------------------------------------
Function: TQtDeviceContext.CorrectCoordinates
Params: None
Returns: Nothing
If you draw an image with negative coordinates
(for example x: -50 y: -50 w: 100 h: 100), the result is not well
defined in Qt, and could well be: (x: 0 y: 0 w: 100 h: 100)
This method corrects the coordinates, cutting the result, so we draw:
(x: 0 y: 0 w: 50 h: 50)
------------------------------------------------------------------------------}
procedure TQtDeviceContext.CorrectCoordinates(var ARect: TRect);
begin
if ARect.Left < 0 then ARect.Left := 0;
if ARect.Top < 0 then ARect.Top := 0;
{ if ARect.Right > MaxRight then ARect.Right := MaxRight;
if ARect.Bottom > MaxBottom then ARect.Bottom := MaxBottom;}
end;
function TQtDeviceContext.GetLineLastPixelPos(PrevPos, NewPos: TPoint): TPoint;
begin
Result := NewPos;
if NewPos.X > PrevPos.X then
dec(Result.X)
else
if NewPos.X < PrevPos.X then
inc(Result.X);
if NewPos.Y > PrevPos.Y then
dec(Result.Y)
else
if NewPos.Y < PrevPos.Y then
inc(Result.Y);
end;
procedure TQtDeviceContext.qDrawPlainRect(x, y, w, h: integer; AColor: PQColor = nil;
lineWidth: Integer = 1; FillBrush: QBrushH = nil);
begin
if AColor = nil then
AColor := BackgroundBrush.getColor;
// stop asserts from qtlib
{issue #36411. Seem that assert triggered in Qt4 < 4.7 only.
if (w < x) or (h < y) then
exit;
}
q_DrawPlainRect(Widget, x, y, w, h, AColor, lineWidth, FillBrush);
end;
procedure TQtDeviceContext.qDrawShadeRect(x, y, w, h: integer; Palette: QPaletteH = nil; Sunken: Boolean = False;
lineWidth: Integer = 1; midLineWidth: Integer = 0; FillBrush: QBrushH = nil);
var
AppPalette: QPaletteH;
begin
if (w < 0) or (h < 0) then
exit;
AppPalette := nil;
if Palette = nil then
begin
if Parent = nil then
begin
AppPalette := QPalette_create();
QGuiApplication_palette(AppPalette);
// QApplication_palette(AppPalette);
Palette := AppPalette;
end else
Palette := QWidget_palette(Parent);
end;
q_DrawShadeRect(Widget, x, y, w, h, Palette, Sunken, lineWidth, midLineWidth, FillBrush);
if AppPalette <> nil then
begin
QPalette_destroy(AppPalette);
Palette := nil;
end;
end;
procedure TQtDeviceContext.qDrawWinPanel(x, y, w, h: integer;
ATransparent: boolean; Palette: QPaletteH; Sunken: Boolean;
lineWidth: Integer; FillBrush: QBrushH);
var
i: integer;
AppPalette: QPaletteH;
begin
if (w < 0) or (h < 0) then
exit;
AppPalette := nil;
if Palette = nil then
begin
if Parent = nil then
begin
AppPalette := QPalette_create();
QGUIApplication_palette(AppPalette);
Palette := AppPalette;
end else
Palette := QWidget_palette(Parent);
end;
// since q_DrawWinPanel doesnot supports lineWidth we should do it ourself
for i := 1 to lineWidth - 1 do
begin
q_DrawWinPanel(Widget, x, y, w, h, Palette, Sunken);
inc(x);
inc(y);
dec(w, 2);
dec(h, 2);
end;
if lineWidth > 1 then
q_DrawWinPanel(Widget, x, y, w, h, Palette, Sunken, FillBrush)
else
begin
// issue #26491, draw opaque TCustomPanel if csOpaque is setted up in control style
// otherwise use brush and painter backgroundmode settings.
if not ATransparent and (FillBrush = nil) and Assigned(Parent) then
q_DrawShadePanel(Widget, x, y, w, h, Palette, Sunken, 1, QPalette_background(Palette))
else
q_DrawShadePanel(Widget, x, y, w, h, Palette, Sunken, 1, FillBrush);
end;
if AppPalette <> nil then
begin
QPalette_destroy(AppPalette);
Palette := nil;
end;
end;
{------------------------------------------------------------------------------
Function: TQtDeviceContext.CreateDCData
Params: None
Returns: Nothing
------------------------------------------------------------------------------}
function TQtDeviceContext.CreateDCData: PQtDCDATA;
begin
{$ifdef VerboseQt}
writeln('TQtDeviceContext.CreateDCData() ');
{$endif}
QPainter_save(Widget);
Result := nil; // doesn't matter;
end;
{------------------------------------------------------------------------------
Function: TQtDeviceContext.RestoreDCData
Params: DCData, dummy in current implementation
Returns: true if QPainter state was successfuly restored
------------------------------------------------------------------------------}
function TQtDeviceContext.RestoreDCData(var DCData: PQtDCData):boolean;
begin
{$ifdef VerboseQt}
writeln('TQtDeviceContext.RestoreDCData() ');
{$endif}
QPainter_restore(Widget);
Result := True;
end;
function TQtDeviceContext.DeviceSupportsComposition: Boolean;
var
Engine: QPaintEngineH;
AType: QPaintEngineType;
begin
Result := (Widget <> nil) and QPainter_isActive(Widget);
if not Result then
exit;
Result := FSupportComposition = rocSupported;
if (FSupportComposition <> rocUndefined) then
exit;
Engine := QPainter_paintEngine(Widget);
if Engine <> nil then
begin
AType := QPaintEngine_type(Engine);
Result := not (AType in
[QPaintEngineX11, QPaintEngineWindows,
QPaintEngineQuickDraw, QPaintEngineCoreGraphics,
QPaintEngineQWindowSystem]);
FSupportComposition := Rop2CompSupported[Result];
end;
end;
function TQtDeviceContext.DeviceSupportsRasterOps: Boolean;
var
Engine: QPaintEngineH;
AType: QPaintEngineType;
begin
Result := (Widget <> nil) and QPainter_isActive(Widget);
if not Result then
exit;
Result := FSupportRasterOps = rocSupported;
if (FSupportRasterOps <> rocUndefined) then
exit;
Engine := QPainter_paintEngine(Widget);
if Engine <> nil then
begin
AType := QPaintEngine_type(Engine);
Result := not (AType in
[QPaintEngineQuickDraw, QPaintEngineCoreGraphics,
QPaintEngineQWindowSystem]);
FSupportRasterOps := Rop2CompSupported[Result];
end;
end;
{------------------------------------------------------------------------------
Function: TQtDeviceContext.R2ToQtRasterOp
Params: Raster ops binary operator
Returns: QPainterCompositionMode
------------------------------------------------------------------------------}
function TQtDeviceContext.R2ToQtRasterOp(AValue: Integer): QPainterCompositionMode;
begin
Result := QPainterCompositionMode_SourceOver;
if not DeviceSupportsRasterOps then
exit;
(*
IMPLEMENTED = +
NOT IMPLEMENTED = -
NOT SURE HOWTO IMPLEMENT = ?
+SRCCOPY = $00CC0020; { dest = source }
+SRCPAINT = $00EE0086; { dest = source OR dest }
+SRCAND = $008800C6; { dest = source AND dest }
+SRCINVERT = $00660046; { dest = source XOR dest }
+SRCERASE = $00440328; { dest = source AND (NOT dest ) }
+NOTSRCCOPY = $00330008; { dest = (NOT source) }
+NOTSRCERASE = $001100A6; { dest = (NOT src) AND (NOT dest) }
-MERGECOPY = $00C000CA; { dest = (source AND pattern) }
+MERGEPAINT = $00BB0226; { dest = (NOT source) OR dest }
-PATCOPY = $00F00021; { dest = pattern }
-PATPAINT = $00FB0A09; { dest = DPSnoo }
-PATINVERT = $005A0049; { dest = pattern XOR dest }
+DSTINVERT = $00550009; { dest = (NOT dest) }
?BLACKNESS = $00000042; { dest = BLACK }
?WHITENESS = $00FF0062; { dest = WHITE }
*)
case AValue of
BLACKNESS,
R2_BLACK: if DeviceSupportsComposition then
Result := QPainterCompositionMode_Clear;
SRCCOPY,
R2_COPYPEN: Result := QPainterCompositionMode_SourceOver; // default
MERGEPAINT,
R2_MASKNOTPEN: Result := QPainterRasterOp_NotSourceAndDestination;
SRCAND,
R2_MASKPEN: Result := QPainterRasterOp_SourceAndDestination;
SRCERASE,
R2_MASKPENNOT: Result := QPainterRasterOp_SourceAndNotDestination;
R2_MERGENOTPEN: Result := QPainterCompositionMode_SourceOver; // unsupported
SRCPAINT,
R2_MERGEPEN: Result := QPainterRasterOp_SourceOrDestination;
R2_MERGEPENNOT: Result := QPainterCompositionMode_SourceOver; // unsupported
R2_NOP: if DeviceSupportsComposition then
Result := QPainterCompositionMode_Destination;
R2_NOT: if DeviceSupportsComposition then
Result := QPainterCompositionMode_SourceOut; // unsupported
NOTSRCCOPY,
R2_NOTCOPYPEN: Result := QPainterRasterOp_NotSource;
PATPAINT,
R2_NOTMASKPEN: Result := QPainterRasterOp_NotSourceOrNotDestination;
NOTSRCERASE,
R2_NOTMERGEPEN: Result := QPainterRasterOp_NotSourceAndNotDestination;
DSTINVERT,
R2_NOTXORPEN: Result := QPainterRasterOp_NotSourceXorDestination;
WHITENESS,
R2_WHITE: if DeviceSupportsComposition then
Result := QPainterCompositionMode_Screen;
SRCINVERT,
R2_XORPEN: Result := QPainterRasterOp_SourceXorDestination;
end;
end;
function TQtDeviceContext.GetRop: Integer;
begin
Result := FRopMode;
end;
function TQtDeviceContext.GetMetrics: TQtFontMetrics;
begin
Result := Font.Metrics;
end;
{------------------------------------------------------------------------------
Function: TQtDeviceContext.SetTextPen
Params: None
Returns: Nothing
------------------------------------------------------------------------------}
procedure TQtDeviceContext.SetTextPen;
var
TxtColor: TQColor;
begin
{$ifdef VerboseQt}
writeln('TQtDeviceContext.RestoreTextColor() ');
{$endif}
TxtColor := Default(TQColor);
ColorRefToTQColor(vTextColor, TxtColor);
QPainter_setPen(Widget, PQColor(@txtColor));
end;
procedure TQtDeviceContext.SetRop(const AValue: Integer);
var
QtROPMode: QPainterCompositionMode;
begin
FRopMode := AValue;
QtRopMode := R2ToQtRasterOp(AValue);
if QPainter_compositionMode(Widget) <> QtRopMode then
QPainter_setCompositionMode(Widget, QtROPMode);
end;
{------------------------------------------------------------------------------
Function: TQtDeviceContext.drawRect
Params: None
Returns: Nothing
Draws a rectangle. Helper function of winapi.Rectangle
------------------------------------------------------------------------------}
procedure TQtDeviceContext.drawRect(x1: Integer; y1: Integer; w: Integer;
h: Integer);
begin
{$ifdef VerboseQt}
writeln('TQtDeviceContext.drawRect() x1: ',x1,' y1: ',y1,' w: ',w,' h: ',h);
{$endif}
QPainter_drawRect(Widget, x1, y1, w, h);
end;
procedure TQtDeviceContext.drawRectF(x1: double; y1: double; w: double;
h: double);
var
R: QRectFH;
begin
R := QRectF_Create(x1 + 0.5, y1 + 0.5, w, h);
QPainter_drawRect(Widget, R);
QRectF_Destroy(R);
end;
procedure TQtDeviceContext.drawRoundRect(x, y, w, h, rx, ry: Integer);
begin
QPainter_drawRoundedRect(Widget, x, y, w, h, rx, ry);
end;
{------------------------------------------------------------------------------
Function: TQtDeviceContext.drawText
Params: None
Returns: Nothing
Draws a Text. Helper function of winapi.TextOut
Qt does not draw the text starting at Y position and downwards, like LCL.
Instead, Y becomes the baseline for the text and it's drawn upwards.
To get a correct behavior we need to sum the text's height to the Y coordinate.
------------------------------------------------------------------------------}
procedure TQtDeviceContext.drawText(x: Integer; y: Integer; s: PWideString);
var
APen: QPenH;
begin
{$ifdef VerboseQt}
Write('TQtDeviceContext.drawText TargetX: ', X, ' TargetY: ', Y);
{$endif}
// First translate and then rotate, that makes the
// correct rotation effect that we want
if Font.Angle <> 0 then
begin
Translate(x, y);
Rotate(-0.1 * Font.Angle);
end;
// what about Metrics.descent and Metrics.leading ?
y := y + Metrics.ascent;
if FPenTextInternal then
begin
APen := QPen_create(QPainter_pen(Widget));
SetTextPen;
end;
// The ascent is only applied here, because it also needs
// to be rotated
if Font.Angle <> 0 then
QPainter_drawText(Widget, 0, Metrics.ascent, s)
else
QPainter_drawText(Widget, x, y, s);
if FPenTextInternal then
begin
QPainter_setPen(Widget, APen);
QPen_destroy(APen);
end;
// Restore previous angle
if Font.Angle <> 0 then
begin
y := y - Metrics.ascent;
Rotate(0.1 * Font.Angle);
Translate(-x, -y);
end;
{$ifdef VerboseQt}
WriteLn(' Font metrics height: ', Metrics.height, ' Angle: ',
Round(0.1 * Font.Angle));
{$endif}
end;
{------------------------------------------------------------------------------
Function: TQtDeviceContext.DrawText
Params: None
Returns: Nothing
------------------------------------------------------------------------------}
procedure TQtDeviceContext.drawText(x, y, w, h, flags: Integer; s: PWideString);
var
APen: QPenH;
begin
{$ifdef VerboseQt}
Write('TQtDeviceContext.drawText x: ', X, ' Y: ', Y,' w: ',w,' h: ',h);
{$endif}
// First translate and then rotate, that makes the
// correct rotation effect that we want
if Font.Angle <> 0 then
begin
Translate(x, y);
Rotate(-0.1 * Font.Angle);
end;
if FPenTextInternal then
begin
APen := QPen_create(QPainter_pen(Widget));
SetTextPen;
end;
if Font.Angle <> 0 then
QPainter_DrawText(Widget, 0, 0, w, h, Flags, s)
else
QPainter_DrawText(Widget, x, y, w, h, Flags, s);
if FPenTextInternal then
begin
QPainter_setPen(Widget, APen);
QPen_destroy(APen);
end;
// Restore previous angle
if Font.Angle <> 0 then
begin
Rotate(0.1 * Font.Angle);
Translate(-x, -y);
end;
end;
{------------------------------------------------------------------------------
Function: TQtDeviceContext.drawLine
Params: None
Returns: Nothing
Draws a Text. Helper function for winapi.LineTo
------------------------------------------------------------------------------}
procedure TQtDeviceContext.drawLine(x1: Integer; y1: Integer; x2: Integer; y2: Integer);
begin
{$ifdef VerboseQt}
Write('TQtDeviceContext.drawLine x1: ', X1, ' Y1: ', Y1,' x2: ',x2,' y2: ',y2);
{$endif}
QPainter_drawLine(Widget, x1, y1, x2, y2);
end;
procedure TQtDeviceContext.drawLineF(x1: double; y1: double; x2: double;
y2: double);
var
APt1, APt2: TQtPointF;
begin
APt1.x := x1 + 0.5;
APt1.y := y1 + 0.5;
APt2.x := x2 + 0.5;
APt2.y := y2 + 0.5;
QPainter_drawLine(Widget, PQtPointF(@APt1), PQtPointF(@APt2));
end;
{------------------------------------------------------------------------------
Function: TQtDeviceContext.drawEllipse
Params: None
Returns: Nothing
Draws a ellipse. Helper function for winapi.Ellipse
------------------------------------------------------------------------------}
procedure TQtDeviceContext.drawEllipse(x: Integer; y: Integer; w: Integer; h: Integer);
begin
QPainter_drawEllipse(Widget, x, y, w, h);
end;
procedure TQtDeviceContext.drawPixmap(p: PQtPoint; pm: QPixmapH; sr: PRect);
begin
QPainter_drawPixmap(Widget, p, pm, sr);
end;
procedure TQtDeviceContext.drawPolyLine(P: PPoint; NumPts: Integer);
var
QtPoints: PQtPoint;
i: integer;
LastPoint: TPoint;
begin
GetMem(QtPoints, NumPts * SizeOf(TQtPoint));
for i := 0 to NumPts - 2 do
QtPoints[i] := QtPoint(P[i].x, P[i].y);
LastPoint := P[NumPts - 1];
if NumPts > 1 then
LastPoint := GetLineLastPixelPos(P[NumPts - 2], LastPoint);
QtPoints[NumPts - 1] := QtPoint(LastPoint.X, LastPoint.Y);
QPainter_drawPolyline(Widget, QtPoints, NumPts);
FreeMem(QtPoints);
end;
procedure TQtDeviceContext.drawPolygon(P: PPoint; NumPts: Integer;
FillRule: QtFillRule);
var
QtPoints: PQtPoint;
i: integer;
LastPoint: TPoint;
begin
GetMem(QtPoints, NumPts * SizeOf(TQtPoint));
for i := 0 to NumPts - 2 do
QtPoints[i] := QtPoint(P[i].x, P[i].y);
LastPoint := P[NumPts - 1];
if NumPts > 1 then
LastPoint := GetLineLastPixelPos(P[NumPts - 2], LastPoint);
QtPoints[NumPts - 1] := QtPoint(LastPoint.X, LastPoint.Y);
QPainter_drawPolygon(Widget, QtPoints, NumPts, FillRule);
FreeMem(QtPoints);
end;
procedure TQtDeviceContext.eraseRect(ARect: PRect);
begin
QPainter_eraseRect(Widget, ARect);
end;
procedure TQtDeviceContext.fillRect(ARect: PRect; ABrush: QBrushH);
begin
{$ifdef VerboseQt}
Write('TQtDeviceContext.fillRect() from PRect');
{$endif}
QPainter_fillRect(Widget, ARect, ABrush);
end;
procedure TQtDeviceContext.fillRect(x, y, w, h: Integer; ABrush: QBrushH);
begin
{$ifdef VerboseQt}
Write('TQtDeviceContext.fillRect() x: ',x,' y: ',y,' w: ',w,' h: ',h);
{$endif}
QPainter_fillRect(Widget, x, y, w, h, ABrush);
end;
procedure TQtDeviceContext.fillRect(x, y, w, h: Integer);
begin
fillRect(x, y, w, h, BackgroundBrush.FHandle);
end;
function TQtDeviceContext.getBKMode: Integer;
begin
if QPainter_BackgroundMode(Widget) = QtOpaqueMode then
Result := OPAQUE
else
Result := TRANSPARENT;
end;
{------------------------------------------------------------------------------
Function: TQtDeviceContext.drawPoint
Params: x1,y1 : Integer
Returns: Nothing
Draws a point. Helper function of winapi. DrawFocusRect
------------------------------------------------------------------------------}
procedure TQtDeviceContext.drawPoint(x1: Integer; y1: Integer);
begin
{$ifdef VerboseQt}
Write('TQtDeviceContext.drawPoint() x1: ',x1,' y1: ',y1);
{$endif}
QPainter_drawPoint(Widget, x1, y1);
end;
{------------------------------------------------------------------------------
Function: TQtDeviceContext.setBrushOrigin
Params: None
Returns: Nothing
------------------------------------------------------------------------------}
procedure TQtDeviceContext.setBrushOrigin(x, y: Integer);
begin
{$ifdef VerboseQt}
Write('TQtDeviceContext.setBrushOrigin() x: ',x,' y: ',y);
{$endif}
QPainter_setBrushOrigin(Widget, x, y);
end;
{------------------------------------------------------------------------------
Function: TQtDeviceContext.brushOrigin
Params: None
Returns: Nothing
------------------------------------------------------------------------------}
procedure TQtDeviceContext.getBrushOrigin(retval: PPoint);
var
QtPoint: TQtPoint;
begin
{$ifdef VerboseQt}
Write('TQtDeviceContext.brushOrigin() ');
{$endif}
QPainter_brushOrigin(Widget, @QtPoint);
retval^.x := QtPoint.x;
retval^.y := QtPoint.y;
end;
function TQtDeviceContext.getClipping: Boolean;
begin
Result := QPainter_hasClipping(Widget);
end;
function TQtDeviceContext.getCompositionMode: QPainterCompositionMode;
begin
Result := QPainter_compositionMode(Widget);
end;
procedure TQtDeviceContext.getPenPos(retval: PPoint);
begin
retval^.x := FPenPos.x;
retval^.y := FPenPos.y;
end;
function TQtDeviceContext.getWorldTransform: QTransformH;
begin
Result := QPainter_worldTransform(Widget);
end;
procedure TQtDeviceContext.setPenPos(x, y: Integer);
begin
FPenPos.X := x;
FPenPos.Y := y;
end;
{------------------------------------------------------------------------------
Function: TQtDeviceContext.font
Params: None
Returns: The current font object of the DC
------------------------------------------------------------------------------}
function TQtDeviceContext.font: TQtFont;
begin
{$ifdef VerboseQt}
Write('TQtDeviceContext.font()');
{$endif}
if SelFont = nil then
begin
if vFont <> nil then
begin
if vFont.FHandle <> nil then
begin
QFont_destroy(vFont.FHandle);
vFont.FHandle := nil;
end;
end;
Result := vFont;
end
else
Result := SelFont;
end;
{------------------------------------------------------------------------------
Function: TQtDeviceContext.setFont
Params: None
Returns: Nothing
------------------------------------------------------------------------------}
procedure TQtDeviceContext.setFont(AFont: TQtFont);
var
QFnt: QFontH;
begin
{$ifdef VerboseQt}
Write('TQtDeviceContext.setFont() ');
{$endif}
SelFont := AFont;
if (AFont.FHandle <> nil) and (Widget <> nil) then
begin
QFnt := QFont_Create(AFont.FHandle);
QPainter_setFont(Widget, QFnt);
QFont_destroy(QFnt);
vFont.Angle := AFont.Angle;
end;
end;
{------------------------------------------------------------------------------
Function: TQtDeviceContext.brush
Params: None
Returns: The current brush object of the DC
------------------------------------------------------------------------------}
function TQtDeviceContext.brush: TQtBrush;
begin
{$ifdef VerboseQt}
Write('TQtDeviceContext.brush() ');
{$endif}
if vBrush <> nil then
vBrush.FHandle := QPainter_brush(Widget);
if SelBrush = nil then
Result := vBrush
else
Result := SelBrush;
end;
{------------------------------------------------------------------------------
Function: TQtDeviceContext.setBrush
Params: None
Returns: Nothing
------------------------------------------------------------------------------}
procedure TQtDeviceContext.setBrush(ABrush: TQtBrush);
begin
{$ifdef VerboseQt}
Write('TQtDeviceContext.setBrush() ');
{$endif}
if SelBrush <> nil then
SelBrush.FSelected := False;
SelBrush := ABrush;
if SelBrush <> nil then
SelBrush.FSelected := True;
if (ABrush.FHandle <> nil) and (Widget <> nil) then
QPainter_setBrush(Widget, ABrush.FHandle);
end;
function TQtDeviceContext.BackgroundBrush: TQtBrush;
begin
{$ifdef VerboseQt}
Write('TQtDeviceContext.backgroundBrush() ');
{$endif}
vBackgroundBrush.FHandle := QPainter_background(Widget);
result := vBackGroundBrush;
end;
function TQtDeviceContext.GetBkColor: TColorRef;
var
TheBrush: QBrushH;
TheColor: TQColor;
begin
TheBrush := QPainter_background(Widget);
TheColor := QBrush_color(TheBrush)^;
TQColorToColorRef(TheColor, Result);
end;
{------------------------------------------------------------------------------
Function: TQtDeviceContext.pen
Params: None
Returns: The current pen object of the DC
------------------------------------------------------------------------------}
function TQtDeviceContext.pen: TQtPen;
begin
{$ifdef VerboseQt}
Write('TQtDeviceContext.pen() ');
{$endif}
if vPen <> nil then
vPen.FHandle := QPainter_pen(Widget);
if SelPen = nil then
Result := vPen
else
Result := SelPen;
end;
{------------------------------------------------------------------------------
Function: TQtDeviceContext.setPen
Params: None
Returns: Nothing
------------------------------------------------------------------------------}
function TQtDeviceContext.setPen(APen: TQtPen): TQtPen;
begin
{$ifdef VerboseQt}
Write('TQtDeviceContext.setPen() ');
{$endif}
Result := pen;
SelPen := APen;
if (APen <> nil) and (APen.FHandle <> nil) and (Widget <> nil) then
QPainter_setPen(Widget, APen.FHandle);
end;
procedure TQColorToColorRef(const AColor: TQColor; out AColorRef: TColorRef);
begin
AColorRef := ((AColor.r shr 8) and $FF) or
(AColor.g and $FF00) or
((AColor.b shl 8) and $FF0000);
end;
procedure ColorRefToTQColor(const AColorRef: TColorRef; var AColor:TQColor);
begin
QColor_fromRgb(@AColor, Red(AColorRef),Green(AColorRef),Blue(AColorRef));
end;
function EqualTQColor(const Color1, Color2: TQColor): Boolean;
begin
Result := (Color1.r = Color2.r) and
(Color1.g = Color2.g) and
(Color1.b = Color2.b);
end;
procedure DebugRegion(const msg: string; Rgn: QRegionH);
var
R: TRect;
ok: boolean;
begin
Write(Msg);
ok := QRegion_isEmpty(Rgn);
QRegion_BoundingRect(Rgn, @R);
WriteLn(' Empty=',Ok,' Rect=', dbgs(R));
end;
function QtDefaultPrinter: TQtPrinter;
begin
if FPrinter = nil then
FPrinter := TQtPrinter.Create;
Result := FPrinter;
end;
function Clipboard: TQtClipboard;
begin
if FClipboard = nil then
FClipboard := TQtClipboard.Create;
Result := FClipboard;
end;
function TQtDeviceContext.SetBkColor(Color: TColorRef): TColorRef;
var
NColor: TQColor;
begin
{$ifdef VerboseQt}
Write('TQtDeviceContext.setBKColor() ');
{$endif}
Result := GetBkColor;
ColorRefToTQColor(ColorToRGB(TColor(Color)), NColor{%H-});
BackgroundBrush.setColor(@NColor);
end;
function TQtDeviceContext.SetBkMode(BkMode: Integer): Integer;
var
Mode: QtBGMode;
begin
{$ifdef VerboseQt}
Write('TQtDeviceContext.setBKMode() ');
{$endif}
Result := 0;
if Widget <> nil then
begin
Mode := QPainter_BackgroundMode(Widget);
if Mode = QtOpaqueMode then
Result := OPAQUE
else
Result := TRANSPARENT;
if BkMode = OPAQUE then
Mode := QtOpaqueMode
else
Mode := QtTransparentMode;
QPainter_SetBackgroundMode(Widget, Mode);
end;
end;
function TQtDeviceContext.getDepth: integer;
begin
Result := QPaintDevice_depth(QPainter_device(Widget));
end;
function TQtDeviceContext.getDeviceSize: TPoint;
var
device: QPaintDeviceH;
begin
device := QPainter_device(Widget);
Result.x := QPaintDevice_width(device);
Result.y := QPaintDevice_height(device);
end;
{------------------------------------------------------------------------------
Function: TQtDeviceContext.getRegionType
Params: QRegionH
Returns: Region type
------------------------------------------------------------------------------}
function TQtDeviceContext.getRegionType(ARegion: QRegionH): integer;
begin
try
if QRegion_isEmpty(ARegion) then
Result := NULLREGION
else
begin
if QRegion_numRects(ARegion) = 1 then
Result := SIMPLEREGION
else
Result := COMPLEXREGION;
end;
except
Result := ERROR;
end;
end;
procedure TQtDeviceContext.setCompositionMode(mode: QPainterCompositionMode);
begin
QPainter_setCompositionMode(Widget, mode);
end;
{------------------------------------------------------------------------------
Function: TQtDeviceContext.region
Params: None
Returns: The current clip region
------------------------------------------------------------------------------}
function TQtDeviceContext.getClipRegion: TQtRegion;
begin
{$ifdef VerboseQt}
Write('TQtDeviceContext.region() ');
{$endif}
if vRegion.FHandle <> nil then
begin
QRegion_destroy(vRegion.FHandle);
vRegion.FHandle := nil;
end;
if vRegion.FHandle = nil then
vRegion.FHandle := QRegion_Create();
QPainter_clipRegion(Widget, vRegion.FHandle);
Result := vRegion;
end;
function TQtDeviceContext.preferFloatingPointDrawingFunctions: boolean;
const
AEpsilon: double = 0.01;
var
APixelRatio: QReal;
AWindow: QWindowH;
AWidget: QWidgetH;
AScreen: QScreenH;
begin
Result := False;
if Assigned(Parent) then
begin
AWindow := QWidget_windowHandle(Parent);
if AWindow = nil then
begin
AWidget := QWidget_topLevelWidget(Parent);
AWindow := QWidget_windowHandle(AWidget);
if AWindow = nil then
exit;
end;
AScreen := QWindow_screen(AWindow);
if AScreen = nil then
exit;
APixelRatio := QScreen_devicePixelRatio(AScreen);
if Abs(APixelRatio - 1.00) > AEpsilon then
exit(True);
end;
end;
procedure TQtDeviceContext.setClipping(const AValue: Boolean);
begin
QPainter_setClipping(Widget, AValue);
end;
procedure TQtDeviceContext.setClipRect(const ARect: TRect);
begin
QPainter_setClipRect(Widget, @ARect);
end;
procedure TQtDeviceContext.setClipRegion(ARegion: QRegionH;
AOperation: QtClipOperation = QtReplaceClip);
begin
{X11 and mac does not like QtNoClip & empty region.It makes disaster}
if (AOperation = QtNoClip) and QRegion_isEmpty(ARegion) and
(QPaintEngine_type(PaintEngine) in [QPaintEngineX11,QPaintEngineQuickDraw,
QPaintEngineCoreGraphics,QPaintEngineMacPrinter]) then
setClipping(False)
else
QPainter_SetClipRegion(Widget, ARegion, AOperation);
end;
{------------------------------------------------------------------------------
Function: TQtDeviceContext.setRegion
Params: None
Returns: Nothing
------------------------------------------------------------------------------}
procedure TQtDeviceContext.setRegion(ARegion: TQtRegion);
begin
{$ifdef VerboseQt}
Write('TQtDeviceContext.setRegion() ');
{$endif}
if (ARegion.FHandle <> nil) and (Widget <> nil) then
setClipRegion(ARegion.FHandle);
end;
{------------------------------------------------------------------------------
Function: TQtDeviceContext.drawImage
Params: None
Returns: Nothing
------------------------------------------------------------------------------}
procedure TQtDeviceContext.drawImage(targetRect: PRect;
image: QImageH; sourceRect: PRect;
mask: QImageH; maskRect: PRect; flags: QtImageConversionFlags = QtAutoColor);
var
LocalRect: TRect;
APixmap, ATemp: QPixmapH;
AMask: QBitmapH;
ScaledImage: QImageH;
TempScaledImage: QImageH;
ScaledMask: QImageH;
NewRect: TRect;
ARenderHint: Boolean;
ATransformation: QtTransformationMode;
ARenderHints: QPainterRenderHints;
{$IFDEF DARWIN}
BMacPrinter: boolean;
{$ENDIF}
function NeedScaling: boolean;
var
R: TRect;
TgtW, TgtH,
ClpW, ClpH: integer;
begin
if not getClipping or EqualRect(LocalRect, sourceRect^) then
exit(False);
R := getClipRegion.getBoundingRect;
TgtW := LocalRect.Right - LocalRect.Left;
TgtH := LocalRect.Bottom - LocalRect.Top;
ClpW := R.Right - R.Left;
ClpH := R.Bottom - R.Top;
Result := PtInRect(R, Point(R.Left + 1, R.Top + 1)) and
(ClpW <= TgtW) and (ClpH <= TgtH);
end;
begin
{$ifdef VerboseQt}
Write('TQtDeviceContext.drawImage() ');
{$endif}
ScaledImage := nil;
LocalRect := targetRect^;
{$IFDEF DARWIN}
BMacPrinter := (PaintEngine <> nil) and (QPaintEngine_type(PaintEngine) = QPaintEngineMacPrinter);
{$ENDIF}
if mask <> nil then
begin
if NeedScaling then
begin
ScaledImage := QImage_create();
TempScaledImage := QImage_Create();
QImage_copy(Image, TempScaledImage, 0, 0, QImage_width(Image), QImage_height(Image));
QImage_scaled(TempScaledImage, ScaledImage, LocalRect.Right - LocalRect.Left,
LocalRect.Bottom - LocalRect.Top);
NewRect := sourceRect^;
NewRect.Right := (LocalRect.Right - LocalRect.Left) + sourceRect^.Left;
NewRect.Bottom := (LocalRect.Bottom - LocalRect.Top) + sourceRect^.Top;
QImage_destroy(TempScaledImage);
end;
// TODO: check maskRect
APixmap := QPixmap_create();
try
if ScaledImage <> nil then
QPixmap_fromImage(APixmap, ScaledImage, flags)
else
QPixmap_fromImage(APixmap, image, flags);
ATemp := QPixmap_create();
try
// QBitmap_fromImage raises assertion in the qt library
if ScaledImage <> nil then
begin
ScaledMask := QImage_create();
TempScaledImage := QImage_create();
QImage_copy(Mask, TempScaledImage, 0, 0, QImage_width(Mask), QImage_height(Mask));
QImage_scaled(TempScaledImage, ScaledMask, LocalRect.Right - LocalRect.Left,
LocalRect.Bottom - LocalRect.Top);
QPixmap_fromImage(ATemp, ScaledMask, flags);
QImage_destroy(TempScaledImage);
QImage_destroy(ScaledMask);
end else
QPixmap_fromImage(ATemp, mask, flags);
AMask := QBitmap_create(ATemp);
try
QPixmap_setMask(APixmap, AMask);
{$IFDEF DARWIN}
ScaledMask := QImage_create();
QPixmap_toImage(APixmap, ScaledMask);
if ScaledImage <> nil then
QPainter_drawImage(Widget, PRect(@LocalRect), image, @NewRect, flags)
else
QPainter_drawImage(Widget, PRect(@LocalRect), image, sourceRect, flags);
QImage_destroy(ScaledMask);
{$ELSE}
if ScaledImage <> nil then
QPainter_drawPixmap(Widget, PRect(@LocalRect), APixmap, @NewRect)
else
QPainter_drawPixmap(Widget, PRect(@LocalRect), APixmap, sourceRect);
{$ENDIF}
finally
QBitmap_destroy(AMask);
end;
finally
QPixmap_destroy(ATemp);
end;
finally
QPixmap_destroy(APixmap);
end;
if ScaledImage <> nil then
QImage_destroy(ScaledImage);
end else
begin
{$note TQtDeviceContext.drawImage workaround - possible qt4 bug with QPainter & RGB32 images.}
{Workaround: we must convert image to ARGB32 , since we can get strange
results with RGB32 images on Linux and Win32 if DstRect <> sourceRect.
Explanation: Look at #11713 linux & win screenshoots.
Note: This is slower operation than QImage_scaled() we used before.
Issue #25590 - check if we are RGB32 and mask is nil, so make conversion
too.}
if (not EqualRect(LocalRect, sourceRect^) or (Mask = nil)) and
(QImage_format(Image) = QImageFormat_RGB32) then
begin
ScaledImage := QImage_create();
try
QImage_convertToFormat(Image, ScaledImage, QImageFormat_ARGB32);
if NeedScaling then
begin
TempScaledImage := QImage_create();
QImage_scaled(ScaledImage, TempScaledImage, LocalRect.Right - LocalRect.Left,
LocalRect.Bottom - LocalRect.Top);
NewRect := sourceRect^;
NewRect.Right := (LocalRect.Right - LocalRect.Left) + sourceRect^.Left;
NewRect.Bottom := (LocalRect.Bottom - LocalRect.Top) + sourceRect^.Top;
QPainter_drawImage(Widget, PRect(@LocalRect), TempScaledImage, @NewRect, flags);
QImage_destroy(TempScaledImage);
end else
QPainter_drawImage(Widget, PRect(@LocalRect), ScaledImage, sourceRect, flags);
finally
QImage_destroy(ScaledImage);
end;
end else
begin
if NeedScaling then
begin
ScaledImage := QImage_create();
TempScaledImage := QImage_create();
try
QImage_copy(Image, TempScaledImage, 0, 0, QImage_width(Image), QImage_height(Image));
{use smooth transformation when scaling image. issue #29883
check if antialiasing is on, if not then don''t call smoothTransform. issue #330011}
ARenderHints := QPainter_renderHints(Widget);
if (ARenderHints and QPainterAntialiasing <> 0) or (ARenderHints and QPainterSmoothPixmapTransform <> 0) or
(ARenderHints and QPainterHighQualityAntialiasing <> 0) then
ATransformation := QtSmoothTransformation
else
ATransformation := QtFastTransformation;
QImage_scaled(TempScaledImage, ScaledImage, LocalRect.Right - LocalRect.Left,
LocalRect.Bottom - LocalRect.Top, QtIgnoreAspectRatio, ATransformation);
NewRect := sourceRect^;
NewRect.Right := (LocalRect.Right - LocalRect.Left) + sourceRect^.Left;
NewRect.Bottom := (LocalRect.Bottom - LocalRect.Top) + sourceRect^.Top;
QPainter_drawImage(Widget, PRect(@LocalRect), ScaledImage, @NewRect, flags);
finally
QImage_destroy(ScaledImage);
QImage_destroy(TempScaledImage);
end;
end else
begin
{smooth a bit. issue #29883
check if antialiasing is on, if not then don''t call smoothTransform. issue #330011}
ARenderHints := QPainter_renderHints(Widget);
ARenderHint := (ARenderHints and QPainterAntialiasing <> 0) or (ARenderHints and QPainterSmoothPixmapTransform <> 0) or
(ARenderHints and QPainterHighQualityAntialiasing <> 0);
if ARenderHint and (QImage_format(image) = QImageFormat_ARGB32) and (flags = QtAutoColor) and
not EqualRect(LocalRect, sourceRect^) then
QPainter_setRenderHint(Widget, QPainterSmoothPixmapTransform, True);
{$IFDEF DARWIN}
if BMacPrinter then
begin
ScaledImage := QImage_create();
QImage_convertToFormat(Image, ScaledImage, QImageFormat_ARGB32_Premultiplied);
QPainter_drawImage(Widget, PRect(@LocalRect), ScaledImage, sourceRect, flags);
QImage_destroy(ScaledImage);
end else
{$ENDIF}
QPainter_drawImage(Widget, PRect(@LocalRect), image, sourceRect, flags);
if ARenderHint then
QPainter_setRenderHint(Widget, QPainterSmoothPixmapTransform, not ARenderHint);
end;
end;
end;
end;
function TQtDeviceContext.PaintEngine: QPaintEngineH;
begin
Result := QPainter_paintEngine(Widget);
end;
{------------------------------------------------------------------------------
Function: TQtDeviceContext.rotate
Params: None
Returns: Nothing
Rotates the coordinate system
------------------------------------------------------------------------------}
procedure TQtDeviceContext.rotate(a: Double);
begin
{$ifdef VerboseQt}
Write('TQtDeviceContext.rotate() ');
{$endif}
QPainter_rotate(Widget, a);
end;
procedure TQtDeviceContext.setRenderHint(AHint: QPainterRenderHint; AValue: Boolean);
begin
QPainter_setRenderHint(Widget, AHint, AValue);
end;
{------------------------------------------------------------------------------
Function: TQtDeviceContext.save
Params: None
Returns: Nothing
Saves the state of the canvas
------------------------------------------------------------------------------}
procedure TQtDeviceContext.save;
begin
{$ifdef VerboseQt}
Write('TQtDeviceContext.save() ');
{$endif}
QPainter_save(Widget);
end;
{------------------------------------------------------------------------------
Function: TQtDeviceContext.restore
Params: None
Returns: Nothing
Restores the state of the canvas
------------------------------------------------------------------------------}
procedure TQtDeviceContext.restore;
begin
{$ifdef VerboseQt}
Write('TQtDeviceContext.restore() ');
{$endif}
QPainter_restore(Widget);
end;
{------------------------------------------------------------------------------
Function: TQtDeviceContext.translate
Params: None
Returns: Nothing
Tranlates the coordinate system
------------------------------------------------------------------------------}
procedure TQtDeviceContext.translate(dx: Double; dy: Double);
begin
{$ifdef VerboseQt}
WriteLn('TQtDeviceContext.translate() ');
{$endif}
QPainter_translate(Widget, dx, dy);
end;
{ TQtPixmap }
constructor TQtPixmap.Create(p1: PSize);
begin
FHandle := QPixmap_create(p1);
end;
destructor TQtPixmap.Destroy;
begin
if FHandle <> nil then
QPixmap_destroy(FHandle);
inherited Destroy;
end;
function TQtPixmap.getHeight: Integer;
begin
Result := QPixmap_height(Handle);
end;
function TQtPixmap.getWidth: Integer;
begin
Result := QPixmap_width(Handle);
end;
procedure TQtPixmap.grabWidget(AWidget: QWidgetH; x: Integer = 0; y: Integer = 0; w: Integer = -1; h: Integer = -1);
begin
QPixmap_grabWidget(FHandle, AWidget, x, y, w, h);
end;
procedure TQtPixmap.grabWindow(p1: PtrUInt; x: Integer; y: Integer; w: Integer; h: Integer);
begin
QPixmap_grabWindow(FHandle, p1, x, y, w, h);
end;
procedure TQtPixmap.toImage(retval: QImageH);
begin
QPixmap_toImage(FHandle, retval);
end;
class procedure TQtPixmap.fromImage(retval: QPixmapH; image: QImageH; flags: QtImageConversionFlags = QtAutoColor);
begin
QPixmap_fromImage(retval, image, flags);
end;
{ TQtButtonGroup }
constructor TQtButtonGroup.Create(AParent: QObjectH);
begin
inherited Create;
Handle := QButtonGroup_create(AParent);
end;
destructor TQtButtonGroup.Destroy;
begin
QButtonGroup_destroy(Handle);
inherited Destroy;
end;
procedure TQtButtonGroup.AddButton(AButton: QAbstractButtonH); overload;
begin
QButtonGroup_addButton(Handle, AButton);
end;
procedure TQtButtonGroup.AddButton(AButton: QAbstractButtonH; id: Integer); overload;
begin
QButtonGroup_addButton(Handle, AButton, id);
end;
function TQtButtonGroup.ButtonFromId(id: Integer): QAbstractButtonH;
begin
Result := QButtonGroup_button(Handle, id);
end;
procedure TQtButtonGroup.RemoveButton(AButton: QAbstractButtonH);
begin
QButtonGroup_removeButton(Handle, AButton);
end;
procedure TQtButtonGroup.SetExclusive(AExclusive: Boolean);
begin
QButtonGroup_setExclusive(Handle, AExclusive);
end;
function TQtButtonGroup.GetExclusive: Boolean;
begin
Result := QButtonGroup_exclusive(Handle);
end;
procedure TQtButtonGroup.SignalButtonClicked(AButton: QAbstractButtonH); cdecl;
begin
{todo}
end;
{ TQtClipboard }
constructor TQtClipboard.Create;
var
ClipboardType: TClipboardType;
begin
inherited Create;
FLockClip := False;
for ClipboardType := Low(TClipBoardType) to High(TClipBoardType) do
FOnClipBoardRequest[ClipBoardType] := nil;
FClipBoardFormats := TStringList.Create;
FClipBoardFormats.Add('foo'); // 0 is reserved
TheObject := QGUIApplication_clipBoard;
{$IFDEF HASX11}
FX11Delay := false;
FLockX11Selection := 0;
FSelTimer := TQtTimer.CreateTimer(10, @selectionTimer, TheObject);
{$ENDIF}
AttachEvents;
end;
destructor TQtClipboard.Destroy;
begin
DetachEvents;
{$IFDEF HASX11}
if FSelTimer <> nil then
FSelTimer.Free;
{$ENDIF}
FClipBoardFormats.Free;
// This is global QApplication object so do NOT destroy it !!
TheObject := nil;
inherited Destroy;
end;
procedure TQtClipboard.AttachEvents;
begin
inherited AttachEvents;
FClipDataChangedHook := QClipboard_hook_create(TheObject);
QClipboard_hook_hook_dataChanged(FClipDataChangedHook, @signalDataChanged);
{$IFDEF HASX11}
FClipSelectionChangedHook := QClipboard_hook_create(TheObject);
QClipboard_hook_hook_selectionChanged(FClipSelectionChangedHook,
@signalSelectionChanged);
{$ENDIF}
end;
procedure TQtClipboard.DetachEvents;
begin
if Assigned(FClipDataChangedHook) then
QClipboard_hook_destroy(FClipDataChangedHook);
FClipDataChangedHook := nil;
{$IFDEF HASX11}
if Assigned(FClipSelectionChangedHook) then
QClipboard_hook_destroy(FClipSelectionChangedHook);
FClipSelectionChangedHook := nil;
{$ENDIF}
inherited DetachEvents;
end;
procedure TQtClipboard.signalDataChanged; cdecl;
begin
{$IFDEF VERBOSE_QT_CLIPBOARD}
writeln('signalDataChanged()');
{$ENDIF}
FClipChanged := IsClipboardChanged;
end;
{$IFDEF HASX11}
procedure TQtClipboard.BeginX11SelectionLock;
begin
inc(FLockX11Selection);
end;
procedure TQtClipboard.EndX11SelectionLock;
begin
dec(FLockX11Selection);
if (FLockX11Selection = 0) and not FX11Delay then
begin
FX11Delay := True;
QTimer_singleShot(10, @X11DelayTimeOut);
end;
end;
class procedure TQtClipboard.X11DelayTimeOut; cdecl;
begin
FX11Delay := False;
end;
function TQtClipboard.InX11SelectionLock: Boolean;
begin
Result := FLockX11Selection > 0;
end;
procedure TQtClipboard.signalSelectionChanged; cdecl;
var
TempMimeData: QMimeDataH;
WStr: WideString;
Clip: TClipBoard;
begin
{$IFDEF VERBOSE_QT_CLIPBOARD}
writeln('signalSelectionChanged() OWNER?=', QClipboard_ownsSelection(Self.clipboard),
' FOnClipBoardRequest ? ',FOnClipBoardRequest[ctPrimarySelection] <> nil);
{$ENDIF}
if InX11SelectionLock then
exit;
TempMimeData := getMimeData(QClipboardSelection);
if (TempMimeData <> nil) and
(QMimeData_hasText(TempMimeData) or QMimeData_hasHtml(TempMimeData) or
QMimeData_hasURLS(TempMimeData)) then
begin
QMimeData_text(TempMimeData, @WStr);
// do not touch LCL's selection if shift is down
// since in that case event is tracked via FSelTimer
// until shift depressed.
if QGUIApplication_keyboardModifiers() and QtShiftModifier <> 0 then
exit;
// do complete primaryselection cleanup at LCL side
// so it asks for clip from qt (no matter is it owner or not).
BeginUpdate;
Clip := Clipbrd.Clipboard(ctPrimarySelection);
Clip.OnRequest := nil;
FOnClipBoardRequest[ctPrimarySelection] := nil;
Clip.AsText := UTF16ToUTF8(WStr);
EndUpdate;
end;
end;
procedure TQtClipboard.selectionTimer;
var
RptEvent: QLCLMessageEventH;
begin
if FOnClipBoardRequest[ctPrimarySelection] = nil then
begin
FSelTimer.TimerEnabled := False;
exit;
end;
if QGUIApplication_keyboardModifiers() and QtShiftModifier = 0 then
begin
FSelTimer.TimerEnabled := False;
RptEvent := QLCLMessageEvent_create(LCLQt_ClipboardPrimarySelection,
PtrUInt(Ord(ctPrimarySelection)), PtrUInt(FSelFmtCount), 0, 0);
QCoreApplication_postEvent(ClipBoard, RptEvent);
end;
end;
{$ENDIF}
function TQtClipboard.IsClipboardChanged: Boolean;
var
TempMimeData: QMimeDataH;
Str: WideString;
Str2: WideString;
begin
Result := not FLockClip;
if FLockClip then
exit;
// FLockClip: here we know that our clipboard is not changed by LCL Clipboard
FLockClip := True;
try
TempMimeData := getMimeData(QClipboardClipboard);
if (TempMimeData <> nil) and
(QMimeData_hasText(TempMimeData) or QMimeData_hasHtml(TempMimeData) or
QMimeData_hasURLS(TempMimeData)) then
begin
QMimeData_text(TempMimeData, @Str);
Str2 := UTF8ToUTF16(Clipbrd.Clipboard.AsText);
Result := Str <> Str2;
if Result then
Clipbrd.Clipboard.AsText := UTF16ToUTF8(Str);
end;
finally
FLockClip := False;
end;
end;
function TQtClipboard.EventFilter(Sender: QObjectH; Event: QEventH): Boolean; cdecl;
{$IFDEF HASX11}
var
ClipboardType: TClipboardType;
FormatCount: PtrUint;
Modifiers: QtKeyboardModifiers;
procedure PutSelectionOnClipBoard;
var
MimeType: WideString;
MimeData: QMimeDataH;
Data: QByteArrayH;
DataStream: TMemoryStream;
I: Integer;
Clip: TClipboard;
begin
// We must track this event if shift is down, since
// we are doing keyboard selection.
// When shift is depressed, selectionTimer will trigger
// another event which will pass this point
// and assign selection to qt selection clipboard.
if Modifiers and QtShiftModifier <> 0 then
begin
if not FSelTimer.TimerEnabled then
FSelTimer.TimerEnabled := True;
exit;
end;
if FSelTimer.TimerEnabled then
FSelTimer.TimerEnabled := False;
Clip := Clipbrd.Clipboard(ClipboardType);
MimeData := QMimeData_create();
DataStream := TMemoryStream.Create;
for I := 0 to FormatCount - 1 do
begin
DataStream.Size := 0;
DataStream.Position := 0;
MimeType := UTF8ToUTF16(FormatToMimeType(Clip.Formats[I]));
FOnClipBoardRequest[ClipboardType](Clip.Formats[I], DataStream);
Data := QByteArray_create(PAnsiChar(DataStream.Memory), DataStream.Size);
if (QByteArray_length(Data) > 1) and QByteArray_endsWith(Data, #0) then
QByteArray_chop(Data, 1);
QMimeData_setData(MimeData, @MimeType, Data);
QByteArray_destroy(Data);
end;
DataStream.Free;
// we must "wake up" QMimeData text property, otherwise
// some non ascii chars could be eaten (possible qt bug)
QMimeData_text(MimeData, @MimeType);
setMimeData(MimeData, ClipbBoardTypeToQtClipboard[ClipBoardType]);
// do not destroy MimeData!!!
end;
{$ENDIF}
begin
Result := False;
BeginEventProcessing;
try
{$IFDEF HASX11}
if QEvent_type(Event) = LCLQt_ClipboardPrimarySelection then
begin
ClipboardType := TClipBoardType(QLCLMessageEvent_getMsg(QLCLMessageEventH(Event)));
FormatCount := QLCLMessageEvent_getWParam(QLCLMessageEventH(Event));
Modifiers := QtKeyboardModifiers(QLCLMessageEvent_getLParam(QLCLMessageEventH(Event)));
if FOnClipBoardRequest[ClipboardType] <> nil then
PutSelectionOnClipboard;
Result := True;
QEvent_accept(Event);
end;
{$ENDIF}
if QEvent_type(Event) = QEventClipboard then
begin
Result := FClipChanged;
// Clipboard is changed, but we have no ability at moment to pass that info
// to LCL since LCL has no support for that event
// so we are using signalDataChanged() to pass changes to Clipbrd.Clipboard
if FClipChanged then
FClipChanged := False;
QEvent_accept(Event);
end;
finally
EndEventProcessing;
end;
end;
function TQtClipboard.Clipboard: QClipboardH;
begin
Result := QClipboardH(TheObject);
end;
function TQtClipboard.getMimeData(AMode: QClipboardMode): QMimeDataH;
begin
{$IFDEF HASX11}
if InX11SelectionLock or FX11Delay then
Result := nil
else
{$ENDIF}
Result := QClipboard_mimeData(Clipboard, AMode);
end;
procedure TQtClipboard.setMimeData(AMimeData: QMimeDataH; AMode: QClipboardMode);
begin
QClipboard_setMimeData(Clipboard, AMimeData, AMode);
end;
procedure TQtClipboard.Clear(AMode: QClipboardMode);
begin
QClipboard_clear(ClipBoard, AMode);
end;
function TQtClipboard.FormatToMimeType(AFormat: TClipboardFormat): String;
begin
if FClipBoardFormats.Count > Integer(AFormat) then
Result := FClipBoardFormats[AFormat]
else
Result := '';
end;
function TQtClipboard.RegisterFormat(AMimeType: String): TClipboardFormat;
var
Index: Integer;
begin
Index := FClipBoardFormats.IndexOf(AMimeType);
if Index < 0 then
Index := FClipBoardFormats.Add(AMimeType);
Result := Index;
end;
function TQtClipboard.GetData(ClipboardType: TClipboardType;
FormatID: TClipboardFormat; Stream: TStream): boolean;
var
QtMimeData: QMimeDataH;
MimeType: WideString;
Data: QByteArrayH;
p: PAnsiChar;
s: Integer;
{$IF DEFINED(UNIX) AND NOT DEFINED(DARWIN)}
i: integer;
WStr: WideString;
AFormats: QStringListH;
{$ENDIF}
begin
Result := False;
QtMimeData := getMimeData(ClipbBoardTypeToQtClipboard[ClipBoardType]);
if QtMimeData = nil then
exit;
MimeType := UTF8ToUTF16(FormatToMimeType(FormatID));
{$IF DEFINED(UNIX) AND NOT DEFINED(DARWIN)}
//issue #40423
if (MimeType = 'text/plain') then // do not translate
begin
QGuiApplication_platformName(@WStr);
if WideSameText(WStr, 'xcb') or
WideSameText(Copy(WStr, 1, 7), 'wayland') then // do not translate
begin
AFormats := QStringList_Create;
QMimeData_formats(QtMimeData, AFormats);
for i := 0 to QStringList_size(AFormats) - 1 do
begin
QStringList_at(AFormats, @WStr, i);
if WStr = 'text/plain;charset=utf-8' then // do not translate
begin
MimeType := WStr;
break;
end;
end;
QStringlist_destroy(AFormats);
end;
end;
{$ENDIF}
Data := QByteArray_create();
QMimeData_data(QtMimeData, Data, @MimeType);
s := QByteArray_size(Data);
p := QByteArray_constData(Data);
Stream.Write(p^, s);
// what to do with p? FreeMem or nothing?
QByteArray_destroy(Data);
Result := True;
end;
function TQtClipboard.GetFormats(ClipboardType: TClipboardType;
var Count: integer; var List: PClipboardFormat): boolean;
var
QtMimeData: QMimeDataH;
QtList: QStringListH;
i: Integer;
Str: WideString;
begin
Result := False;
Count := 0;
List := nil;
QtMimeData := getMimeData(ClipbBoardTypeToQtClipboard[ClipBoardType]);
if QtMimeData = nil then
exit;
QtList := QStringList_create;
QMimeData_formats(QtMimeData, QtList);
try
Count := QStringList_size(QtList);
GetMem(List, Count * SizeOf(TClipboardFormat));
for i := 0 to Count - 1 do
begin
QStringList_at(QtList, @Str, i);
List[i] := RegisterFormat(UTF16ToUTF8(Str));
end;
Result := True;
finally
QStringList_destroy(QtList);
end;
end;
function TQtClipboard.GetOwnerShip(ClipboardType: TClipboardType;
OnRequestProc: TClipboardRequestEvent; FormatCount: integer;
Formats: PClipboardFormat): boolean;
procedure PutOnClipBoard;
var
MimeType: WideString;
MimeData: QMimeDataH;
Data: QByteArrayH;
DataStream: TMemoryStream;
I: Integer;
{$IFDEF HASX11}
Event: QLCLMessageEventH;
{$ENDIF}
begin
{$IFDEF HASX11}
// we must delay assigning selection to qt clipboard
// so generate our private event
if ClipboardType <> ctClipboard then
begin
FSelFmtCount := FormatCount;
Event := QLCLMessageEvent_create(LCLQt_ClipboardPrimarySelection,
PtrUInt(Ord(ClipboardType)), PtrUInt(FormatCount), PtrUInt(QGUIApplication_keyboardModifiers()), 0);
QCoreApplication_postEvent(ClipBoard, Event);
exit;
end;
{$ENDIF}
MimeData := QMimeData_create();
DataStream := TMemoryStream.Create;
for I := 0 to FormatCount - 1 do
begin
DataStream.Size := 0;
DataStream.Position := 0;
MimeType := UTF8ToUTF16(FormatToMimeType(Formats[I]));
FOnClipBoardRequest[ClipboardType](Formats[I], DataStream);
Data := QByteArray_create(PAnsiChar(DataStream.Memory), DataStream.Size);
{do not remove #0 from Application/X-Laz-SynEdit-Tagged issue #25692}
if (MimeType <> 'Application/X-Laz-SynEdit-Tagged') and
(QByteArray_length(Data) > 1) and QByteArray_endsWith(Data, #0) then
QByteArray_chop(Data, 1);
QMimeData_setData(MimeData, @MimeType, Data);
QByteArray_destroy(Data);
end;
DataStream.Free;
setMimeData(MimeData, ClipbBoardTypeToQtClipboard[ClipBoardType]);
// do not destroy MimeData!!!
end;
begin
Result := False;
if (FormatCount = 0) or (OnRequestProc = nil) then
begin
{ The LCL indicates it doesn't have the clipboard data anymore
and the interface can't use the OnRequestProc anymore.}
FOnClipBoardRequest[ClipboardType] := nil;
Result := True;
end else
begin
if FLockClip then
exit;
{FLockClip: we are sure that this request comes from LCL Clipboard}
FLockClip := True;
try
{ clear OnClipBoardRequest to prevent destroying the LCL clipboard,
when emptying the clipboard}
FOnClipBoardRequest[ClipBoardType] := nil;
{$IFDEF HASX11}
// if we are InUpdate , then change is asked
// from selectionChanged trigger, so don't do anything
if (ClipboardType <> ctClipBoard) and InUpdate then
begin
Result := True;
exit;
end;
{$ENDIF}
FOnClipBoardRequest[ClipBoardType] := OnRequestProc;
PutOnClipBoard;
Result := True;
finally
FLockClip := False;
end;
end;
end;
{ TQtPrinter }
constructor TQtPrinter.Create;
begin
FPrinterActive := False;
FPrintQuality := QPrinterHighResolution;
FHandle := nil;
// QPrinter_create(QPrinterHighResolution);
end;
constructor TQtPrinter.Create(AMode: QPrinterPrinterMode);
begin
FPrinterActive := False;
FPrintQuality := AMode; // QPrinterHighResolution;
FHandle := nil;
// FHandle := QPrinter_create(AMode);
end;
destructor TQtPrinter.Destroy;
begin
endDoc;
if Assigned(FHandle) then
begin
QPrinter_destroy(FHandle);
FHandle := nil;
end;
inherited Destroy;
end;
{returns default system printer}
function TQtPrinter.DefaultPrinter: WideString;
var
prnName: WideString;
PrnInfo: QPrinterInfoH;
begin
PrnInfo := QPrinterInfo_create();
QPrinterInfo_defaultPrinter(PrnInfo);
QPrinterInfo_printerName(PrnInfo, @PrnName);
QPrinterInfo_destroy(PrnInfo);
if PrnName = '' then
PrnName := 'unknown';
Result := PrnName;
end;
{returns available list of printers.
if there's no printer on system result will be false.
Default sys printer is always 1st in the list.}
function TQtPrinter.GetAvailablePrinters(Lst: TStrings): Boolean;
var
Str: WideString;
PrnName: WideString;
i: Integer;
PrnInfo: QPrinterInfoH;
Prntr: QPrinterInfoH;
PrnList: TPtrIntArray;
begin
Result := False;
Str := DefaultPrinter;
// EnumQPrinters(Lst);
PrnInfo := QPrinterInfo_create();
try
Lst.Clear;
QPrinterInfo_availablePrinters(@PrnList);
for i := Low(PrnList) to High(PrnList) do
begin
Prntr := QPrinterInfoH(PrnList[i]);
if Assigned(Prntr) and not QPrinterInfo_isNull(Prntr) then
begin
QPrinterInfo_printerName(Prntr, @PrnName);
if QPrinterInfo_isDefault(Prntr) then
Lst.Insert(0, UTF16ToUTF8(PrnName))
else
Lst.Add(UTF16ToUTF8(PrnName));
end;
end;
finally
QPrinterInfo_destroy(PrnInfo);
end;
i := Lst.IndexOf(UTF16ToUTF8(Str));
if i > 0 then
Lst.Move(i, 0);
Result := Lst.Count > 0;
end;
procedure TQtPrinter.beginDoc;
begin
getPrinterContext;
FPrinterActive := FPrinterContext <> nil;
end;
procedure TQtPrinter.endDoc;
begin
if FPrinterContext <> nil then
begin
if QPainter_isActive(FPrinterContext.Widget) then
QPainter_end(FPrinterContext.Widget);
FPrinterContext.Free;
FPrinterContext := nil;
end;
FPrinterActive := False;
end;
function TQtPrinter.getPrinterContext: TQtDeviceContext;
begin
if FPrinterContext = nil then
FPrinterContext := TQtDeviceContext.CreatePrinterContext(Handle);
Result := FPrinterContext;
end;
function TQtPrinter.GetDuplexMode: QPrinterDuplexMode;
begin
Result := QPrinter_duplex(Handle);
end;
function TQtPrinter.GetHandle: QPrinterH;
begin
if not Assigned(FHandle) then
FHandle := QPrinter_Create(FPrintQuality);
Result := FHandle;
end;
function TQtPrinter.getCollateCopies: Boolean;
begin
Result := QPrinter_collateCopies(Handle);
end;
function TQtPrinter.getColorMode: QPrinterColorMode;
begin
Result := QPrinter_colorMode(Handle);
end;
function TQtPrinter.getCreator: WideString;
begin
QPrinter_creator(Handle, @Result);
end;
function TQtPrinter.getDevType: Integer;
begin
Result := QPrinter_devType(Handle);
end;
function TQtPrinter.getDocName: WideString;
begin
QPrinter_docName(Handle, @Result);
end;
function TQtPrinter.getDoubleSidedPrinting: Boolean;
begin
Result := QPrinter_doubleSidedPrinting(Handle);
end;
function TQtPrinter.getFontEmbedding: Boolean;
begin
Result := QPrinter_fontEmbeddingEnabled(Handle);
end;
function TQtPrinter.getFullPage: Boolean;
begin
Result := QPrinter_fullPage(Handle);
end;
procedure TQtPrinter.setOutputFormat(const AValue: QPrinterOutputFormat);
begin
QPrinter_setOutputFormat(Handle, AValue);
end;
procedure TQtPrinter.setPaperSource(const AValue: QPrinterPaperSource);
begin
QPrinter_setPaperSource(Handle, AValue);
end;
function TQtPrinter.getOutputFormat: QPrinterOutputFormat;
begin
Result := QPrinter_outputFormat(Handle);
end;
function TQtPrinter.getPaperSource: QPrinterPaperSource;
begin
Result := QPrinter_paperSource(Handle);
end;
function TQtPrinter.getPrintProgram: WideString;
begin
QPrinter_printProgram(Handle, @Result);
end;
function TQtPrinter.getPrintRange: QPrinterPrintRange;
begin
Result := QPrinter_printRange(Handle);
end;
procedure TQtPrinter.setCollateCopies(const AValue: Boolean);
begin
QPrinter_setCollateCopies(Handle, AValue);
end;
procedure TQtPrinter.setColorMode(const AValue: QPrinterColorMode);
begin
QPrinter_setColorMode(Handle, AValue);
end;
procedure TQtPrinter.setCreator(const AValue: WideString);
begin
QPrinter_setCreator(Handle, @AValue);
end;
procedure TQtPrinter.setDocName(const AValue: WideString);
begin
QPrinter_setDocName(Handle, @AValue);
end;
procedure TQtPrinter.setDoubleSidedPrinting(const AValue: Boolean);
begin
QPrinter_setDoubleSidedPrinting(Handle, AValue);
end;
procedure TQtPrinter.SetDuplexMode(AValue: QPrinterDuplexMode);
begin
QPrinter_setDuplex(Handle, AValue);
end;
procedure TQtPrinter.setFontEmbedding(const AValue: Boolean);
begin
QPrinter_setFontEmbeddingEnabled(Handle, AValue);
end;
procedure TQtPrinter.setFullPage(const AValue: Boolean);
begin
QPrinter_setFullPage(Handle, AValue);
end;
procedure TQtPrinter.setPrinterName(const AValue: WideString);
begin
if getPrinterName <> AValue then
QPrinter_setPrinterName(Handle, @AValue);
end;
function TQtPrinter.getPrinterName: WideString;
begin
QPrinter_printerName(Handle, @Result);
end;
procedure TQtPrinter.setOutputFileName(const AValue: WideString);
begin
QPrinter_setOutputFileName(Handle, @AValue);
end;
function TQtPrinter.getOutputFileName: WideString;
begin
QPrinter_outputFileName(Handle, @Result);
end;
procedure TQtPrinter.setOrientation(const AValue: QPrinterOrientation);
begin
QPrinter_setOrientation(Handle, AValue);
end;
function TQtPrinter.getOrientation: QPrinterOrientation;
begin
Result := QPrinter_orientation(Handle);
end;
procedure TQtPrinter.setPageSize(const AValue: QPagedPaintDevicePageSize);
begin
QPrinter_setPaperSize(Handle, AValue);
end;
function TQtPrinter.getPageSize: QPagedPaintDevicePageSize;
begin
Result := QPrinter_paperSize(Handle);
end;
procedure TQtPrinter.setPageOrder(const AValue: QPrinterPageOrder);
begin
QPrinter_setPageOrder(Handle, AValue);
end;
function TQtPrinter.getPageOrder: QPrinterPageOrder;
begin
Result := QPrinter_pageOrder(Handle);
end;
procedure TQtPrinter.setPrintProgram(const AValue: WideString);
begin
QPrinter_setPrintProgram(Handle, @AValue);
end;
procedure TQtPrinter.setPrintRange(const AValue: QPrinterPrintRange);
begin
QPrinter_setPrintRange(Handle, AValue);
end;
procedure TQtPrinter.setResolution(const AValue: Integer);
begin
QPrinter_setResolution(Handle, AValue);
end;
function TQtPrinter.getResolution: Integer;
begin
Result := QPrinter_resolution(Handle);
end;
function TQtPrinter.getNumCopies: Integer;
begin
Result := QPrinter_numCopies(Handle);
end;
procedure TQtPrinter.setNumCopies(const AValue: Integer);
begin
QPrinter_setNumCopies(Handle, AValue);
end;
function TQtPrinter.getPrinterState: QPrinterPrinterState;
begin
Result := QPrinter_printerState(Handle);
end;
function TQtPrinter.NewPage: Boolean;
begin
Result := QPrinter_newPage(Handle);
end;
function TQtPrinter.Abort: Boolean;
begin
Result := QPrinter_abort(Handle);
end;
procedure TQtPrinter.setFromPageToPage(const AFromPage, AToPage: Integer);
begin
QPrinter_setFromTo(Handle, AFromPage, AToPage);
end;
function TQtPrinter.fromPage: Integer;
begin
Result := QPrinter_fromPage(Handle);
end;
function TQtPrinter.toPage: Integer;
begin
Result := QPrinter_toPage(Handle);
end;
function TQtPrinter.PaintEngine: QPaintEngineH;
begin
Result := QPrinter_paintEngine(Handle);
end;
function TQtPrinter.PageRect: TRect;
begin
QPrinter_pageRect(Handle, @Result);
end;
function TQtPrinter.PaperRect: TRect;
begin
QPrinter_paperRect(Handle, @Result);
end;
function TQtPrinter.PageRect(AUnits: QPrinterUnit): TRect;
var
R: QRectFH;
begin
R := QRectF_create();
QPrinter_pageRect(Handle, R, AUnits);
QRectF_toRect(R, @Result);
QRectF_destroy(R);
end;
function TQtPrinter.PaperRect(AUnits: QPrinterUnit): TRect;
var
R: QRectFH;
begin
R := QRectF_create();
QPrinter_paperRect(Handle, R, AUnits);
QRectF_toRect(R, @Result);
QRectF_destroy(R);
end;
function TQtPrinter.PrintEngine: QPrintEngineH;
begin
Result := QPrinter_printEngine(Handle);
end;
function TQtPrinter.GetPaperSize(AUnits: QPrinterUnit): TSize;
var
SizeF: QSizeFH;
begin
SizeF := QSizeF_create(0, 0);
QPrinter_paperSize(Handle, SizeF, AUnits);
Result.cx := Round(QSizeF_width(SizeF));
Result.cy := Round(QSizeF_height(SizeF));
QSizeF_destroy(SizeF);
end;
procedure TQtPrinter.SetPaperSize(ASize: TSize; AUnits: QPrinterUnit);
var
SizeF: QSizeFH;
begin
SizeF := QSizeF_create(@ASize);
try
QPrinter_setPaperSize(Handle, SizeF, AUnits);
finally
QSizeF_destroy(SizeF);
end;
end;
function TQtPrinter.SupportedResolutions: TPtrIntArray;
begin
QPrinter_supportedResolutions(Handle, @Result);
end;
{ TQtTimer }
{------------------------------------------------------------------------------
Function: TQtTimer.CreateTimer
Params: None
Returns: Nothing
------------------------------------------------------------------------------}
constructor TQtTimer.CreateTimer(Interval: integer;
const TimerFunc: TWSTimerProc; App: QObjectH);
begin
inherited Create;
FDeleteLater := True;
FAppObject := App;
FCallbackFunc := TimerFunc;
TheObject := QTimer_create(App);
QTimer_setInterval(QTimerH(TheObject), Interval);
AttachEvents;
// start timer and get ID
QTimer_start(QTimerH(TheObject), Interval);
FId := QTimer_timerId(QTimerH(TheObject));
{$ifdef VerboseQt}
WriteLn('TQtTimer.CreateTimer: Interval = ', Interval, ' ID = ', FId);
{$endif}
end;
{------------------------------------------------------------------------------
Function: TQtTimer.Destroy
Params: None
Returns: Nothing
------------------------------------------------------------------------------}
destructor TQtTimer.Destroy;
begin
{$ifdef VerboseQt}
WriteLn('TQtTimer.CreateTimer: Destroy. ID = ', FId);
{$endif}
FCallbackFunc := nil;
inherited Destroy;
end;
procedure TQtTimer.AttachEvents;
begin
FTimerHook := QTimer_hook_create(QTimerH(TheObject));
QTimer_hook_hook_timeout(FTimerHook, @signalTimeout);
inherited AttachEvents;
end;
procedure TQtTimer.DetachEvents;
begin
QTimer_stop(QTimerH(TheObject));
if FTimerHook <> nil then
QTimer_hook_destroy(FTimerHook);
inherited DetachEvents;
end;
procedure TQtTimer.signalTimeout; cdecl;
begin
if Assigned(FCallbackFunc) then
FCallbackFunc;
end;
function TQtTimer.getTimerEnabled: Boolean;
begin
if TheObject <> nil then
Result := QTimer_isActive(QTimerH(TheObject))
else
Result := False;
end;
procedure TQtTimer.setTimerEnabled(const AValue: Boolean);
begin
if (TheObject <> nil) and (getTimerEnabled <> AValue) then
begin
if AValue then
QTimer_start(QTimerH(TheObject))
else
QTimer_stop(QTimerH(TheObject));
end;
end;
{------------------------------------------------------------------------------
Function: TQtTimer.EventFilter
Params: None
Returns: Nothing
------------------------------------------------------------------------------}
function TQtTimer.EventFilter(Sender: QObjectH; Event: QEventH): Boolean; cdecl;
begin
Result := False;
QEvent_accept(Event);
end;
{ TQtIcon }
constructor TQtIcon.Create;
begin
FHandle := QIcon_create();
end;
destructor TQtIcon.Destroy;
begin
if FHandle <> nil then
QIcon_destroy(FHandle);
inherited Destroy;
end;
procedure TQtIcon.addPixmap(pixmap: QPixmapH; mode: QIconMode = QIconNormal; state: QIconState = QIconOff);
begin
QIcon_addPixmap(Handle, pixmap, mode, state);
end;
{ TQtStringList }
function TQtStringList.Get(Index: Integer): string;
var
W: Widestring;
begin
QStringList_at(FHandle, @W, Index);
Result := UTF16ToUTF8(W);
end;
function TQtStringList.GetCount: Integer;
begin
Result := QStringList_size(FHandle);
end;
constructor TQtStringList.Create;
begin
inherited Create;
FHandle := QStringList_create();
FOwnHandle := True;
end;
constructor TQtStringList.Create(Source: QStringListH);
begin
inherited Create;
FHandle := Source;
FOwnHandle := False;
end;
destructor TQtStringList.Destroy;
begin
if FOwnHandle then
QStringList_destroy(FHandle);
inherited Destroy;
end;
procedure TQtStringList.Clear;
begin
QStringList_clear(FHandle);
end;
procedure TQtStringList.Delete(Index: Integer);
begin
QStringList_removeAt(FHandle, Index);
end;
procedure TQtStringList.Insert(Index: Integer; const S: string);
var
W: WideString;
begin
W := {%H-}S;
QStringList_insert(FHandle, Index, @W);
end;
{ TQtCursor }
constructor TQtCursor.Create;
begin
FHandle := QCursor_create();
end;
constructor TQtCursor.Create(pixmap: QPixmapH; hotX: Integer = -1; hotY: Integer = -1);
begin
FHandle := QCursor_create(pixmap, hotX, hotY);
end;
constructor TQtCursor.Create(shape: QtCursorShape);
begin
FHandle := QCursor_create(shape);
end;
destructor TQtCursor.Destroy;
begin
if FHandle <> nil then
QCursor_destroy(FHandle);
inherited Destroy;
end;
{ TQtWidgetPalette }
procedure TQtWidgetPalette.initializeSysColors;
var
Palette: QPaletteH;
begin
FillChar(FCurrentColor, SizeOf(FCurrentColor), 0);
FillChar(FCurrentColor, SizeOf(FCurrentTextColor), 0);
Palette := QPalette_create();
try
QGUIApplication_palette(Palette);
FDefaultColor := QPalette_color(Palette, QPaletteActive, FWidgetRole)^;
FDefaultTextColor := QPalette_color(Palette, QPaletteActive, FTextRole)^;
FDisabledColor := QPalette_color(Palette, QPaletteDisabled, FWidgetRole)^;
FDisabledTextColor := QPalette_color(Palette, QPaletteDisabled, FTextRole)^;
finally
QPalette_destroy(Palette);
end;
end;
constructor TQtWidgetPalette.Create(AWidgetColorRole: QPaletteColorRole;
AWidgetTextColorRole: QPaletteColorRole; AWidget: QWidgetH);
begin
FInReload := False;
FForceColor := False;
FWidget := AWidget;
FWidgetRole := AWidgetColorRole;
FTextRole := AWidgetTextColorRole;
initializeSysColors;
// ugly qt mac bug
{$IFDEF DARWIN}
if QWidget_backgroundRole(FWidget) <> FWidgetRole then
begin
QWidget_setBackgroundRole(FWidget, FWidgetRole);
QWidget_setForegroundRole(FWidget, FTextRole);
end;
{$ENDIF}
FHandle := QPalette_create();
end;
destructor TQtWidgetPalette.Destroy;
begin
if FHandle <> nil then
QPalette_destroy(FHandle);
inherited Destroy;
end;
function TQtWidgetPalette.ColorChangeNeeded(const AColor: TQColor;
const ATextRole: Boolean): Boolean;
begin
if ATextRole then
Result := not (EqualTQColor(AColor, FDefaultTextColor) and
EqualTQColor(FCurrentTextColor, FDefaultTextColor))
else
Result := not (EqualTQColor(AColor, FDefaultColor) and
EqualTQColor(FCurrentColor, FDefaultColor));
end;
procedure TQtWidgetPalette.setColor(const AColor: PQColor);
begin
if not ColorChangeNeeded(AColor^, False) and not FInReload and not FForceColor then
exit;
QPalette_setColor(FHandle, QPaletteActive, FWidgetRole, AColor);
QPalette_setColor(FHandle, QPaletteInActive, FWidgetRole, AColor);
if EqualTQColor(AColor^, FDefaultColor) then
QPalette_setColor(FHandle, QPaletteDisabled, FWidgetRole, @FDisabledColor)
else
QPalette_setColor(FHandle, QPaletteDisabled, FWidgetRole, AColor);
QWidget_setPalette(FWidget, FHandle);
FCurrentColor := AColor^;
end;
procedure TQtWidgetPalette.setTextColor(const AColor: PQColor);
begin
if not ColorChangeNeeded(AColor^, True) and not FInReload and not FForceColor then
exit;
QPalette_setColor(FHandle, QPaletteActive, FTextRole, AColor);
QPalette_setColor(FHandle, QPaletteInActive, FTextRole, AColor);
if EqualTQColor(AColor^, FDefaultTextColor) or
EqualTQColor(FCurrentColor, FDefaultColor) then
QPalette_setColor(FHandle, QPaletteDisabled, FTextRole, @FDisabledTextColor)
else
QPalette_setColor(FHandle, QPaletteDisabled, FTextRole, AColor);
QWidget_setPalette(FWidget, FHandle);
FCurrentTextColor := AColor^;
end;
procedure TQtWidgetPalette.ReloadPaletteBegin;
var
AOldCurrent, AOldText: TQColor;
begin
FInReload := True;
AOldCurrent := FCurrentColor;
AOldText := FCurrentTextColor;
initializeSysColors;
FCurrentColor := AOldCurrent;
FCurrentTextColor := AOldText;
end;
procedure TQtWidgetPalette.ReloadPaletteEnd;
begin
FInReload := False;
end;
{ TQtActionGroup }
constructor TQtActionGroup.Create(const AParent: QObjectH);
begin
FGroupIndex := 0;
Initialize(FActions);
FHandle := QActionGroup_create(AParent);
end;
destructor TQtActionGroup.Destroy;
begin
if FHandle <> nil then
QActionGroup_destroy(FHandle);
Finalize(FActions);
FActions := nil;
inherited Destroy;
end;
function TQtActionGroup.getEnabled: boolean;
begin
Result := QActionGroup_isEnabled(FHandle);
end;
function TQtActionGroup.getExclusive: boolean;
begin
Result := QActionGroup_isExclusive(FHandle);
end;
function TQtActionGroup.getVisible: boolean;
begin
Result := QActionGroup_isVisible(FHandle);
end;
procedure TQtActionGroup.setEnabled(const AValue: boolean);
begin
QActionGroup_setEnabled(FHandle, AValue);
end;
procedure TQtActionGroup.setExclusive(const AValue: boolean);
begin
QActionGroup_setExclusive(FHandle, AValue);
end;
procedure TQtActionGroup.setVisible(const AValue: boolean);
begin
QActionGroup_setVisible(FHandle, AValue);
end;
function TQtActionGroup.addAction(action: QActionH): QActionH;
begin
Result := QActionGroup_addAction(FHandle, action);
end;
function TQtActionGroup.addAction(text: WideString): QActionH;
begin
Result := QActionGroup_addAction(FHandle, @text);
end;
function TQtActionGroup.addAction(icon: QIconH; text: WideString): QActionH;
begin
Result := QActionGroup_addAction(FHandle, icon, @text);
end;
procedure TQtActionGroup.removeAction(action: QActionH);
begin
QActionGroup_removeAction(FHandle, action);
end;
function TQtActionGroup.actions: TQActions;
var
i: Integer;
Arr: TPtrIntArray;
begin
QActionGroup_actions(FHandle, @Arr);
SetLength(FActions, length(Arr));
for i := 0 to High(Arr) do
FActions[i] := QActionH(Arr[i]);
Result := FActions;
end;
function TQtActionGroup.checkedAction: QActionH;
begin
Result := QActionGroup_checkedAction(FHandle);
end;
procedure TQtActionGroup.setDisabled(ADisabled: Boolean);
begin
QActionGroup_setDisabled(FHandle, ADisabled);
end;
{ TQtObjectDump }
procedure TQtObjectDump.Iterator(ARoot: QObjectH);
var
i: Integer;
Children: TPtrIntArray;
begin
QObject_children(ARoot, @Children);
AddToList(ARoot);
for i := 0 to High(Children) do
Iterator(QObjectH(Children[i]))
end;
procedure TQtObjectDump.AddToList(AnObject: QObjectH);
// var
// ObjName: WideString;
begin
if AnObject <> nil then
begin
// QObject_objectName(AnObject, @ObjName);
if FObjList.IndexOf(AnObject) < 0 then
begin
FList.Add(dbghex(PtrUInt(AnObject)));
FObjList.Add(AnObject);
end else
raise Exception.Create('TQtObjectDump: Duplicated object in list '+dbghex(PtrUInt(AnObject)));
end;
end;
procedure TQtObjectDump.DumpObject;
begin
if FRoot = nil then
raise Exception.Create('TQtObjectDump: Invalid FRoot '+dbghex(PtrUInt(FRoot)));
Iterator(FRoot);
end;
function TQtObjectDump.findWidgetByName(const AName: WideString): QWidgetH;
var
j: Integer;
WS: WideString;
begin
Result := nil;
if AName = '' then
exit;
for j := 0 to FObjList.Count - 1 do
begin
QObject_objectName(QObjectH(FObjList.Items[j]), @WS);
if (WS = AName) and QObject_isWidgetType(QObjectH(FObjList.Items[j])) then
begin
Result := QWidgetH(FObjList.Items[j]);
break;
end;
end;
end;
function TQtObjectDump.IsWidget(AnObject: QObjectH): Boolean;
begin
if AnObject <> nil then
Result := QObject_IsWidgetType(AnObject)
else
Result := False;
end;
function TQtObjectDump.GetObjectName(AnObject: QObjectH): WideString;
begin
Result := '';
if AnObject = nil then
exit;
QObject_objectName(AnObject, @Result);
end;
function TQtObjectDump.InheritsQtClass(AnObject: QObjectH;
AQtClass: AnsiString): Boolean;
begin
if (AnObject = nil) or (AQtClass = '') then
Result := False
else
Result := QObject_inherits(AnObject, PAnsiChar(AQtClass));
end;
constructor TQtObjectDump.Create(AnObject: QObjectH);
begin
FRoot := AnObject;
FList := TStringList.Create;
FObjList := TFPList.Create;
end;
destructor TQtObjectDump.Destroy;
begin
FList.Free;
FObjList.Free;
inherited Destroy;
end;
{ TQtGDIObjects }
constructor TQtGDIObjects.Create;
begin
inherited Create;
{$IFDEF DebugQTGDIObjects}
FMaxCount := 0;
FInvalidCount := 0;
{$ENDIF}
FCount := 0;
FSavedHandlesList := TMap.Create(TMapIdType(ituPtrSize), SizeOf(TObject));
{$IFDEF DebugQTGDIObjects}
DebugLn('TQtGDIObjects.Create ');
{$ENDIF}
end;
destructor TQtGDIObjects.Destroy;
begin
{$IFDEF DebugQTGDIObjects}
DebugLn('TQtGDIObjects.Destroy: Count (must be zero) ',dbgs(FCount),
' FMaxCount ',dbgs(FMaxCount),' FInvalidCount ',dbgs(FInvalidCount));
{$ENDIF}
FSavedHandlesList.Free;
inherited Destroy;
end;
procedure TQtGDIObjects.AddGDIObject(AObject: TObject);
begin
if not FSavedHandlesList.HasId(AObject) then
begin
FSavedHandlesList.Add(AObject, AObject);
inc(FCount);
{$IFDEF DebugQTGDIObjects}
if FMaxCount < FCount then
FMaxCount := FCount;
{$ENDIF}
end;
end;
procedure TQtGDIObjects.RemoveGDIObject(AObject: TObject);
begin
if FSavedHandlesList.HasId(AObject) then
begin
FSavedHandlesList.Delete(AObject);
dec(FCount);
end;
end;
function TQtGDIObjects.IsValidGDIObject(AGDIObject: PtrUInt): Boolean;
begin
if (AGDIObject = 0) then
Exit(False);
Result := FSavedHandlesList.HasId(TObject(AGDIObject));
{$IFDEF DebugQTGDIObjects}
if not Result then
begin
inc(FInvalidCount);
DebugLn('TQtGDIObjects.IsValidGDIObject: Invalid object ',dbgs(AGDIObject));
end;
{$ENDIF}
end;
end.