Code: Alles auswählen
{
/***************************************************************************
GtkCaret.pas - Gtk Caret Emulation
-------------------------------------
copyright (c)
adopted for Lazarus and gtk3 by Lazarus German Forum
***************************************************************************/
*****************************************************************************
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 gtk3Caret;
{$mode ObjFPC}{$H+}
interface
{$DEFINE VerboseGtkCaret}
{$I gtk3defines.inc}
uses
// bindings
LazGtk3, LazGdk3,
// Free Pascal
Classes, SysUtils, Types,
// Widgetset
Gtk3Widgets,
// LCL
LCLType, LCLIntf, Graphics, ExtCtrls;
type
{ TEmulatedCaret }
TEmulatedCaret = class(TComponent)
private
FCaretDirty: Boolean;
FCaretDirtyPos: TGtkPoint; // TQtPoint { TODO -oANdi : Gtk3 ? }
FTimer: TTimer;
FOldRect: TRect;
FWidget: TGtkWidget;
FPixmap: GtkPixmapH;
FLastValidWidth, FLastValidHeight: Integer;
FWidth, FHeight: Integer;
FPos: TGtkPoint; // TQtPoint { TODO -oANdi : Gtk3 ? }
FVisible: Boolean;
FVisibleState: Boolean;
FRespondToFocus: Boolean;
FCritSect: TCriticalSection;
procedure SetPos(const Value: TGtkPoint); // TQtPoint { TODO -oANdi : Gtk3 ? }
protected
procedure DoTimer(Sender: TObject);
procedure DrawCaret; virtual;
function CreateColorPixmap(Color: PtrUInt): GtkPixmapH;
procedure SetWidget(AWidget: TGtk3Widget);
procedure UpdateCaret(const AForceUpdate: Boolean = False);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Lock;
procedure Unlock;
function CreateCaret(AWidget: TGtk3Widget; Pixmap: GtkPixmapH; Width, Height: Integer): Boolean;
function DestroyCaret: Boolean;
function IsValid: Boolean;
function Show(AWidget: TGtk3Widget): Boolean;
function Hide: Boolean;
property CaretDirty: Boolean read FCaretDirty;
property Timer: TTimer read FTimer;
property Pos: TGtkPoint read FPos write SetPos;
property RespondToFocus: Boolean read FRespondToFocus write FRespondToFocus;
end;
function CreateCaret(Widget: TGtk3Widget; Pixmap: GtkPixmapH; Width, Height: Integer): Boolean; overload;
function CreateCaret(Widget: TGtk3Widget; ColorCaret: PtrUInt; Width, Height: Integer): Boolean; overload;
function HideCaret(Widget: TGtk3Widget): Boolean;
function ShowCaret(Widget: TGtk3Widget): Boolean;
function SetCaretPos(X, Y: Integer): Boolean;
function GetCaretPos(var Pt: TPoint): Boolean;
function GetGtkCaretRespondToFocus: Boolean;
procedure SetGtkCaretRespondToFocus(Value: Boolean);
function DestroyCaret: Boolean;
procedure DrawCaret;
procedure DestroyGlobalCaret;
function GlobalCaretDirty: Boolean;
implementation
uses
gtk3int
{$IFDEF VerboseGtkCaret}
,LCLProc
{$ENDIF}
;
var
GlobalCaret: TEmulatedCaret = nil;
procedure GlobalCaretNeeded;
begin
if GlobalCaret = nil then
GlobalCaret := TEmulatedCaret.Create(nil);
end;
function GlobalCaretDirty: Boolean;
begin
Result := False;
if GlobalCaret <> nil then
Result := GlobalCaret.CaretDirty;
end;
procedure DrawCaret;
begin
GlobalCaretNeeded;
if Assigned(GlobalCaret) then
begin
GlobalCaret.Lock;
try
GlobalCaret.DrawCaret;
finally
GlobalCaret.Unlock;
end;
end;
end;
procedure DestroyGlobalCaret;
begin
FreeAndNil(GlobalCaret);
end;
function CreateCaret(Widget: TGtk3Widget; Pixmap: GtkPixmapH; Width, Height: Integer): Boolean;
begin
GlobalCaretNeeded;
GlobalCaret.Lock;
try
Result := GlobalCaret.CreateCaret(Widget, Pixmap, Width, Height);
finally
GlobalCaret.Unlock;
end;
end;
function CreateCaret(Widget: TGtk3Widget; ColorCaret: PtrUInt; Width, Height: Integer): Boolean;
begin
Result := CreateCaret(Widget, GtkPixmapH(ColorCaret), Width, Height);
end;
function GetCaretBlinkTime: Cardinal;
var
FlashTime: Integer;
begin
FlashTime := 600; { TODO -oAndi : What Flashtime ? } // GtkApplication_cursorFlashTime;
if FlashTime > 0 then
Result := FlashTime div 2
else
Result := 600; // our default value
end;
function SetCaretBlinkTime(uMSeconds: Cardinal): LongBool;
begin
Result := True;
try
// GtkApplication_setCursorFlashTime(uMSeconds); { TODO -oAndi : CursorFlashTime ? }
if assigned(GlobalCaret) then
begin
GlobalCaret.Lock;
try
GlobalCaret.Timer.Interval := GetCaretBlinkTime;
finally
GlobalCaret.Unlock;
end;
end;
except
Result := False;
end;
end;
function HideCaret(Widget: TGtk3Widget): Boolean;
begin
GlobalCaretNeeded;
if Assigned(GlobalCaret) then
begin
GlobalCaret.Lock;
try
Result := GlobalCaret.Hide;
finally
GlobalCaret.Unlock;
end;
end
else
Result := false;
end;
function ShowCaret(Widget: TGtk3Widget): Boolean;
begin
GlobalCaretNeeded;
GlobalCaret.Lock;
try
Result := GlobalCaret.Show(Widget);
finally
GlobalCaret.Unlock;
end;
end;
function SetCaretPos(X, Y: Integer): Boolean;
begin
Result := True;
GlobalCaretNeeded;
GlobalCaret.Lock;
try
GlobalCaret.Pos := GtkPoint(X, Y);
finally
GlobalCaret.Unlock;
end;
end;
function GetCaretPos(var Pt: TPoint): Boolean;
begin
Result := True;
GlobalCaretNeeded;
GlobalCaret.Lock;
try
with GlobalCaret.Pos do
begin
Pt.x := X;
Pt.y := Y;
end;
finally
GlobalCaret.Unlock;
end;
end;
function GetQtCaretRespondToFocus: Boolean;
begin
if Assigned(GlobalCaret) then
Result := GlobalCaret.RespondToFocus
else
Result := False;
end;
procedure SetQtCaretRespondToFocus(Value: Boolean);
begin
if Assigned(GlobalCaret) then
GlobalCaret.RespondToFocus := Value;
end;
function DestroyCaret: Boolean;
begin
if Assigned(GlobalCaret) then
begin
GlobalCaret.Lock;
try
Result := GlobalCaret.DestroyCaret;
finally
GlobalCaret.Unlock;
end;
end
else
Result := False;
end;
{ TEmulatedCaret }
constructor TEmulatedCaret.Create(AOwner: TComponent);
begin
{$IFDEF VerboseQtCaret}
writeln('TEmulatedCaret.Create(AsUTF8String)');
{$ENDIF}
inherited Create(AOwner);
InitializeCriticalSection(FCritSect);
FLastValidWidth := 0;
FLastValidHeight := 0;
FCaretDirty := False;
FOldRect := Rect(0, 0, 1, 1);
FPos := GtkPoint(0, 0);
FCaretDirtyPos := FPos;
FTimer := TTimer.Create(self);
FTimer.Enabled := False;
FTimer.Interval := GetCaretBlinkTime;
FTimer.OnTimer := @DoTimer;
FRespondToFocus := False;
end;
destructor TEmulatedCaret.Destroy;
begin
{$IFDEF VerboseQtCaret}
writeln('TEmulatedCaret.Destroy()');
{$ENDIF}
DestroyCaret;
DeleteCriticalSection(FCritSect);
inherited Destroy;
end;
function TEmulatedCaret.CreateCaret(AWidget: TGtk3Widget; Pixmap: GtkPixmapH;
Width, Height: Integer): Boolean;
begin
DestroyCaret;
SetWidget(AWidget);
FWidth := Width;
FHeight := Height;
if FWidth > 0 then
FLastValidWidth := FWidth;
if FHeight > 0 then
FLastValidHeight := FHeight;
if PtrUInt(Pixmap) > $FFFF then
FPixmap := GtkPixmap_create(Pixmap)
else
FPixmap := CreateColorPixmap(PtrUInt(Pixmap));
{$IFDEF VerboseGtkCaret}
writeln('TEmulatedCaret.CreateCaret IsValid=',IsValid,' FVis=',FVisible,
' FVisState=',FVisibleState,' FPixmap=',dbghex(PtrUInt(FPixmap)),
' FWidth=',FWidth,' FHeight=',FHeight{,' FWidget=',dbghex(PtrUInt(FWidget))});
{$ENDIF}
Result := Assigned(FPixmap);
FTimer.Enabled := True;
end;
function TEmulatedCaret.DestroyCaret: Boolean;
begin
{$IFDEF VerboseGtkCaret}
writeln('TEmulatedCaret.DestroyCaret IsValid=',IsValid,' FVis=',FVisible,
' FVisState=',FVisibleState,' FPixmap=',dbghex(PtrUInt(FPixmap)),
' FWidth=',FWidth,' FHeight=',FHeight{,' FWidget=',dbghex(PtrUInt(FWidget))});
{$ENDIF}
FTimer.Enabled := False;
Hide;
if Assigned(FPixmap) then
GtkPixmap_destroy(FPixmap);
FWidget := nil;
FPixmap := nil;
FWidth := 0;
FHeight := 0;
Result := not IsValid;
end;
procedure TEmulatedCaret.DrawCaret;
var
R: TRect;
begin
{$IFDEF VerboseQtCaret}
writeln('TEmulatedCaret.DrawCaret IsValid=',IsValid,' FVis=',FVisible,
' FVisState=',FVisibleState,' FPixmap=',dbghex(PtrUInt(FPixmap)),
' FWidth=',FWidth,' FHeight=',FHeight,' FWidget=',dbghex(PtrUInt(FWidget)));
{$ENDIF}
if IsValid and FVisible and FVisibleState then
begin
FCaretDirty := False;
R := Rect(0, 0, QPixmap_width(FPixmap), QPixmap_height(FPixmap));
TQtDeviceContext(FWidget.Context).save;
TQtDeviceContext(FWidget.Context).setCompositionMode(QPainterRasterOp_NotSourceXorDestination);
TQtDeviceContext(FWidget.Context).drawPixmap(PGtkPoint(@FPos), FPixmap, PRect(@R));
TQtDeviceContext(FWidget.Context).restore;
end;
end;
function TEmulatedCaret.Show(AWidget: TGtk3Widget): Boolean;
var
Pt: TGtkPoint;
begin
{$IFDEF VerboseQtCaret}
writeln('TEmulatedCaret.Show AWidget=',dbghex(PtrUInt(AWidget)));
{$ENDIF}
if FWidget <> AWidget then
begin
{$IFDEF VerboseQtCaret}
writeln('TEmulatedCaret.Show Widget changed IsValid=',IsValid);
{$ENDIF}
Hide;
SetWidget(AWidget);
if (FCaretDirty or (FPixmap=nil))
and (AWidget <> nil) and (FWidget.Context<>0) then
begin
CreateCaret(FWidget, nil, FLastValidWidth, FLastValidHeight);
if (FCaretDirtyPos.X > 0) or (FCaretDirtyPos.Y > 0) then
begin
if (FWidget.LastCaretPos.X >= 0) and (FWidget.LastCaretPos.Y >= 0) then
Pt := FWidget.LastCaretPos
else
Pt := FPos;
SetPos(FCaretDirtyPos);
FCaretDirtyPos := GtkPoint(0, 0);
QCoreApplication_processEvents(QEventLoopExcludeUserInpAsUTF8StringutEvents);
SetPos(Pt);
end else
SetPos(FPos);
end;
end;
Result := Assigned(FPixmap);
FVisible := Result;
SetPos(FPos);
//writeln('TEmulatedCaret.Show END Result=',Result,' IsValid=',IsValid,' Handle=',QtWidgetSet.IsValidHandle(HWND(FWidget)),' FPixmap=',FPixmap<>nil,' FWidget.Context=',FWidget.Context<>0);
end;
function TEmulatedCaret.Hide: Boolean;
begin
{$IFDEF VerboseQtCaret}
writeln('TEmulatedCaret.Hide IsValid=',IsValid,' FVisible=',FVisible);
{$ENDIF}
Result := IsValid;
if Result and FVisible then
begin
FVisible := False;
UpdateCaret;
end;
end;
procedure TEmulatedCaret.SetPos(const Value: TGtkPoint);
begin
{$IFDEF VerboseQtCaret}
writeln('TEmulatedCaret.SetPos FWidget=',dbghex(PtrUInt(FWidget)),' X=',Value.X,
' Y=',Value.Y,' OldX=',FPos.X,' OldY=',FPos.Y,' Dirty=',FCaretDirty);
{$ENDIF}
if not QtWidgetSet.IsValidHandle(HWND(FWidget)) or (FWidget.Widget = nil) then
begin
// oops, our caret is dirty here.
FCaretDirtyPos := FPos;
FCaretDirty := True;
FPos := Value;
exit;
end;
if ((FPos.x <> Value.x) or (FPos.y <> Value.y)) or FCaretDirty then
begin
FWidget.LastCaretPos := FPos;
FPos := Value;
FTimer.Enabled := False;
FVisibleState := FWidget.Context = 0;
{$note remove complete property RespondToFocus after testing}
// if RespondToFocus and not FCaretDirty then
if not FCaretDirty then
UpdateCaret(True);
if FCaretDirty then
begin
FVisible := True;
if FWidget.Context <> 0 then
DoTimer(FTimer);
FTimer.Enabled := True;
end;
end else
begin
if FWidget.Context = 0 then
begin
FVisibleState := True;
FTimer.Enabled := False;
UpdateCaret;
end else
begin
if not FTimer.Enabled then
FTimer.Enabled := True;
end;
end;
end;
procedure TEmulatedCaret.DoTimer(Sender: TObject);
begin
FVisibleState := not FVisibleState;
if FVisible then
UpdateCaret;
end;
procedure TEmulatedCaret.Lock;
begin
{$note TEmulatedCaret.Lock()
remove this routine later, after
testing on all platforms}
// EnterCriticalSection(FCritSect);
end;
procedure TEmulatedCaret.Unlock;
begin
{$note TEmulatedCaret.UnLock()
remove this routine later, after
testing on all platforms}
// LeaveCriticalSection(FCritSect);
end;
function TEmulatedCaret.CreateColorPixmap(Color: PtrUInt): GtkPixmapH;
var
QC: TGtkColor;
AColor: TColor;
begin
{$IFDEF VerboseQtCaret}
writeln('TEmulatedCaret.CreateColorPixmap FWidget=',dbghex(PtrUInt(FWidget)),' Width=',FWidth,
' FHeight=',FHeight);
{$ENDIF}
if (FWidth <= 0) or (FHeight <= 0) then
Result := nil
else
begin
case Color of
0: AColor := clBlack;
1: AColor := clGray;
else
begin
Result := nil;
Exit;
end;
end;
Result := QPixmap_create(FWidth, FHeight);
try
QColor_fromRgb(@QC,Red(AColor),Green(AColor),Blue(AColor));
QPixmap_fill(Result, @QC);
except
QPixmap_destroy(Result);
Result := nil;
end;
end;
end;
function TEmulatedCaret.IsValid: Boolean;
begin
Result := QtWidgetSet.IsValidHandle(HWND(FWidget));
if Result then
Result := (FPixmap <> nil) and (FWidget.Context <> 0);
end;
procedure TEmulatedCaret.SetWidget(AWidget: TGtk3Widget);
begin
if FWidget <> nil then
FWidget.HasCaret := False;
if AWidget is TQtCustomControl then
AWidget := TQtCustomControl(AWidget).viewport;
FWidget := AWidget;
if FWidget <> nil then
FWidget.HasCaret := True;
end;
procedure TEmulatedCaret.UpdateCaret(const AForceUpdate: Boolean = False);
var
R: TRect;
begin
if not Gtk3WidgetSet.IsValidHandle(HWND(FWidget)) then
exit;
if (FWidget.Widget <> nil) then
begin
if FPos.X < 0 then
FPos.X := 0;
if FPos.Y < 0 then
FPos.Y := 0;
R.Left := FPos.x;
R.Top := FPos.y;
R.Right := R.Left + FWidth + 2;
R.Bottom := R.Top + FHeight + 2;
if (FWidget.Context = 0) then
begin
if not EqualRect(FOldRect, R) then
FWidget.Update(@FOldRect);
FWidget.Update(@R);
FOldRect := R;
end else
begin
if AForceUpdate and not FVisible and not FTimer.Enabled then
FTimer.Enabled := True;
end;
end;
end;
end.
Ich glaube wenn es geht sollte man sich am funktionierenden QT5 und kommenden QT6 orientieren.
Verein
Links
