lazopenglcontextex/glqtnativecontext.pas

{
 *****************************************************************************
  See the file COPYING.modifiedLGPL.txt, included in this distribution,
  for details about the license.
 *****************************************************************************

  Qt5/Qt6 OpenGL backend built on a real QOpenGLWidget (libqlclglwidget)
  instead of GLX. Qt creates and manages the GL context through the
  platform-appropriate API (EGL on Wayland, GLX on X11, WGL on Windows,
  CGL on macOS), so this backend works on every platform the Qt widgetset
  runs on — including Wayland sessions, where the classic GLX backend
  (GLQTContext) cannot work at all.

  Why a helper library: libQt6Pas's QLCLOpenGLWidget is NOT a QOpenGLWidget —
  it is a plain QWidget with WA_NativeWindow/paintEngine()=nullptr meant as a
  target for an external GLX context, X11 only. The real QOpenGLWidget
  subclass with a Pascal paintGL hook lives in the small companion library
  libqlclglwidget (csrc/qlclglwidget.cpp), loaded at runtime from the
  application directory or the system library path.

  How it works:
  - Qt makes the widget's context current and binds its backing FBO before
    invoking paintGL(); we deliver LM_PAINT from there, so all rendering in
    OnPaint just works. MakeCurrent during paint is a no-op.
  - MakeCurrent/ReleaseContext outside of paint map to
    QOpenGLWidget::makeCurrent/doneCurrent.
  - SwapBuffers is a no-op during paint (Qt composites the FBO itself after
    paintGL returns); outside of paint it schedules a repaint.

  Notes:
  - Contexts of all QOpenGLWidgets inside the same top-level window are
    automatically shared by Qt; the SharedControl property is ignored.
  - QOpenGLWidget renders into an FBO: do not call glBindFramebuffer(0)
    from user code.
  - On HiDPI (devicePixelRatio > 1) the backing FBO is larger than the
    logical widget size; LOpenGLViewport (AutoResizeViewport) scales by the
    devicePixelRatio, but explicit glViewport calls in user code must scale
    themselves.
}
unit GLQtNativeContext;

{$mode objfpc}{$H+}
{$PACKRECORDS C}

interface

{$IF NOT (DEFINED(LCLQt5) OR DEFINED(LCLQt6))}
  {$ERROR GLQtNativeContext supports only the Qt5/Qt6 widgetsets}
{$ENDIF}

uses
  Classes, SysUtils, Controls, LCLProc, LCLType, gl, dynlibs,
  InterfaceBase, WSLCLClasses,
  // Bindings
  {$IFDEF LCLQt5}qt5,{$ENDIF}
  {$IFDEF LCLQt6}qt6,{$ENDIF}
  qtwidgets, qtint;

procedure LOpenGLViewport(Handle: HWND; Left, Top, Width, Height: integer);
function LOpenGLPixelScale(Handle: HWND): Double;
procedure LOpenGLSwapBuffers(Handle: HWND);
function LOpenGLMakeCurrent(Handle: HWND): boolean;
function LOpenGLReleaseContext(Handle: HWND): boolean;
function LOpenGLCreateContext(AWinControl: TWinControl;
                          WSPrivate: TWSPrivateClass; SharedControl: TWinControl;
                          DoubleBuffered, RGBA: boolean;
                          const RedBits, GreenBits, BlueBits, MajorVersion, MinorVersion,
                          MultiSampling, AlphaBits, DepthBits, StencilBits, AUXBuffers: Cardinal;
                          const AParams: TCreateParams): HWND;
procedure LOpenGLDestroyContextInfo(AWinControl: TWinControl);

implementation

uses LMessages, Forms;

{ ---------------------------------------------------------------------------
  libqlclglwidget, loaded at runtime
  --------------------------------------------------------------------------- }

const
  GLWidgetLibName =
    {$IFDEF WINDOWS}'qlclglwidget.dll'{$ELSE}
    {$IFDEF DARWIN}'libqlclglwidget.dylib'{$ELSE}
    'libqlclglwidget.so'{$ENDIF}{$ENDIF};

type
  // an FPC method pointer passed by value; matches the C-side
  // QGLOverrideHook {void *func; void *data;}
  TGLWidgetPaintHook = procedure of object; cdecl;

  TQLCLGLWidget_Create = function(parent: QWidgetH; flags: Cardinal): QWidgetH; cdecl;
  TQLCLGLWidget_Method = procedure(handle: QWidgetH); cdecl;
  TQLCLGLWidget_override_paintGL = procedure(handle: QWidgetH; hook: TGLWidgetPaintHook); cdecl;
  TQLCLGLWidget_isValid = function(handle: QWidgetH): ByteBool; cdecl;
  TQLCLGLWidget_setFormat = procedure(handle: QWidgetH; fmt: QSurfaceFormatH); cdecl;
  TQLCLGLWidget_setForceOpaque = procedure(handle: QWidgetH; enable: ByteBool); cdecl;
  TQLCLGLWidget_defaultFBO = function(handle: QWidgetH): Cardinal; cdecl;
  TQLCLGLWidget_dprF = function(handle: QWidgetH): Double; cdecl;

var
  GLWidgetLibTried: boolean = false;
  GLWidgetLib: TLibHandle = NilHandle;
  QLCLGLWidget_Create: TQLCLGLWidget_Create = nil;
  QLCLGLWidget_override_paintGL: TQLCLGLWidget_override_paintGL = nil;
  QLCLGLWidget_makeCurrent: TQLCLGLWidget_Method = nil;
  QLCLGLWidget_doneCurrent: TQLCLGLWidget_Method = nil;
  QLCLGLWidget_isValid: TQLCLGLWidget_isValid = nil;
  QLCLGLWidget_setFormat: TQLCLGLWidget_setFormat = nil;
  QLCLGLWidget_setForceOpaque: TQLCLGLWidget_setForceOpaque = nil;
  QLCLGLWidget_defaultFramebufferObject: TQLCLGLWidget_defaultFBO = nil;
  QLCLGLWidget_devicePixelRatioF: TQLCLGLWidget_dprF = nil;

function LoadGLWidgetLib: boolean;

  function TryLoad(const AName: string): boolean;
  begin
    GLWidgetLib := LoadLibrary(AName);
    Result := GLWidgetLib <> NilHandle;
  end;

  function Need(const AName: string): Pointer;
  begin
    Result := GetProcedureAddress(GLWidgetLib, AName);
    if Result = nil then
      raise Exception.CreateFmt('%s: missing symbol %s', [GLWidgetLibName, AName]);
  end;

begin
  if not GLWidgetLibTried then begin
    GLWidgetLibTried := true;
    // next to the executable first, then the system library path
    if TryLoad(ExtractFilePath(ParamStr(0)) + GLWidgetLibName)
    or TryLoad(GLWidgetLibName) then begin
      Pointer(QLCLGLWidget_Create) := Need('QLCLGLWidget_Create');
      Pointer(QLCLGLWidget_override_paintGL) := Need('QLCLGLWidget_override_paintGL');
      Pointer(QLCLGLWidget_makeCurrent) := Need('QLCLGLWidget_makeCurrent');
      Pointer(QLCLGLWidget_doneCurrent) := Need('QLCLGLWidget_doneCurrent');
      Pointer(QLCLGLWidget_isValid) := Need('QLCLGLWidget_isValid');
      Pointer(QLCLGLWidget_setFormat) := Need('QLCLGLWidget_setFormat');
      Pointer(QLCLGLWidget_setForceOpaque) := Need('QLCLGLWidget_setForceOpaque');
      Pointer(QLCLGLWidget_defaultFramebufferObject) := Need('QLCLGLWidget_defaultFramebufferObject');
      Pointer(QLCLGLWidget_devicePixelRatioF) := Need('QLCLGLWidget_devicePixelRatioF');
    end;
  end;
  Result := GLWidgetLib <> NilHandle;
end;

type
  { TQtGLWidget }

  TQtGLWidget = class(TQtWidget)
  protected
    function CreateWidget(const Params: TCreateParams): QWidgetH; override;
    procedure paintGL(); cdecl; virtual;
  public
    InPaintGL: boolean;
    function GetContainerWidget: QWidgetH; override;
    procedure AttachEvents; override;
    procedure DetachEvents; override;
    procedure SlotPaintBg({%H-}Sender: QObjectH; {%H-}Event: QEventH); cdecl; override;
    procedure SlotPaint({%H-}Sender: QObjectH; {%H-}Event: QEventH); cdecl; override;
  end;

{ TQtGLWidget }

function TQtGLWidget.CreateWidget(const Params: TCreateParams): QWidgetH;
var
  Parent: QWidgetH;
begin
  if Params.WndParent <> 0 then
    Parent := TQtWidget(Params.WndParent).GetContainerWidget
  else
    Parent := nil;
  Widget := QLCLGLWidget_Create(Parent, 0);
  Result := Widget;
end;

function TQtGLWidget.GetContainerWidget: QWidgetH;
begin
  Result := Widget;
end;

procedure TQtGLWidget.AttachEvents;
begin
  QLCLGLWidget_override_paintGL(Widget, @paintGL);
  inherited AttachEvents;
end;

procedure TQtGLWidget.DetachEvents;
var
  NilHook: TGLWidgetPaintHook;
begin
  inherited DetachEvents;
  TMethod(NilHook).Code := nil;
  TMethod(NilHook).Data := nil;
  QLCLGLWidget_override_paintGL(Widget, NilHook);
end;

procedure TQtGLWidget.SlotPaintBg(Sender: QObjectH; Event: QEventH); cdecl;
begin
  // QOpenGLWidget paints itself through paintGL
end;

procedure TQtGLWidget.SlotPaint(Sender: QObjectH; Event: QEventH); cdecl;
begin
  // QOpenGLWidget paints itself through paintGL
end;

procedure TQtGLWidget.paintGL(); cdecl;
var
  Msg: TLMPaint;
  AStruct: PPaintStruct;
  B: Boolean;
begin
  // Qt has already made the widget's context current and bound its FBO
  if not (CanSendLCLMessage and (LCLObject is TWinControl)) then begin
    DebugLn('TQtGLWidget.paintGL error CanSendLCLMessage=',dbgs(CanSendLCLMessage),
      ' LCLObject=',dbgsName(LCLObject));
    exit;
  end;
  InPaintGL := true;
  try
    FillChar(Msg{%H-}, SizeOf(Msg), #0);
    Msg.Msg := LM_PAINT;
    New(AStruct);
    try
      try
        FillChar(AStruct^, SizeOf(TPaintStruct), 0);
        QWidget_rect(Widget, @AStruct^.rcPaint);
        AStruct^.hdc := PtrUInt(Widget);
        Msg.PaintStruct := AStruct;
        Msg.DC := AStruct^.hdc;
        LCLObject.WindowProc(TLMessage(Msg));
      finally
        Dispose(AStruct);
      end;
    except
      // prevent recursive repainting !
      B := QtWidgetSet.IsValidHandle(HWND(Self));
      if B then
        QWidget_setUpdatesEnabled(Widget, False);
      try
        Application.HandleException(nil);
      finally
        if B and Assigned(Application) and not Application.Terminated then
          QWidget_setUpdatesEnabled(Widget, True);
      end;
    end;
  finally
    InPaintGL := false;
  end;
end;

// devicePixelRatio виджета (1.0 если недоступен) — для явных glViewport
// в пользовательском коде и текстур в физических пикселях.
function LOpenGLPixelScale(Handle: HWND): Double;
var
  Widget: TQtGLWidget;
begin
  Result := 1.0;
  if (Handle <> 0) and Assigned(QLCLGLWidget_devicePixelRatioF) then begin
    Widget := TQtGLWidget(Handle);
    Result := QLCLGLWidget_devicePixelRatioF(Widget.Widget);
    if Result <= 0 then Result := 1.0;
  end;
end;

procedure LOpenGLViewport(Handle: HWND; Left, Top, Width, Height: integer);
var
  Dpr: Double;
begin
  Dpr := LOpenGLPixelScale(Handle);
  glViewport(Round(Left*Dpr), Round(Top*Dpr), Round(Width*Dpr), Round(Height*Dpr));
end;

procedure LOpenGLSwapBuffers(Handle: HWND);
var
  Widget: TQtGLWidget;
begin
  if Handle=0 then
    RaiseGDBException('LOpenGLSwapBuffers Handle=0');
  Widget := TQtGLWidget(Handle);
  // during paintGL Qt swaps/composites the FBO itself after the handler
  // returns; outside of paint the best we can do is schedule a repaint
  if not Widget.InPaintGL then
    QWidget_update(Widget.Widget);
end;

function LOpenGLMakeCurrent(Handle: HWND): boolean;
var
  Widget: TQtGLWidget;
begin
  Result := false;
  if Handle=0 then
    RaiseGDBException('LOpenGLMakeCurrent Handle=0');
  Widget := TQtGLWidget(Handle);
  if Widget.InPaintGL then
    exit(true); // Qt already made the context current for paintGL
  // no context yet before the widget was first realized/shown
  if not QLCLGLWidget_isValid(Widget.Widget) then
    exit;
  QLCLGLWidget_makeCurrent(Widget.Widget);
  Result := true;
end;

function LOpenGLReleaseContext(Handle: HWND): boolean;
var
  Widget: TQtGLWidget;
begin
  Result := false;
  if Handle=0 then
    RaiseGDBException('LOpenGLReleaseContext Handle=0');
  Widget := TQtGLWidget(Handle);
  if Widget.InPaintGL then exit; // never unbind Qt's own paint context
  QLCLGLWidget_doneCurrent(Widget.Widget);
  Result := true;
end;

function LOpenGLCreateContext(AWinControl: TWinControl;
  WSPrivate: TWSPrivateClass; SharedControl: TWinControl;
  DoubleBuffered, RGBA: boolean;
  const RedBits, GreenBits, BlueBits, MajorVersion, MinorVersion,
  MultiSampling, AlphaBits, DepthBits, StencilBits, AUXBuffers: Cardinal;
  const AParams: TCreateParams): HWND;
var
  NewQtWidget: TQtGLWidget;
  AFormat: QSurfaceFormatH;
begin
  if WSPrivate=nil then ;
  if SharedControl<>nil then ; // Qt shares QOpenGLWidget contexts per top-level window
  if AUXBuffers>0 then ;       // not supported by QSurfaceFormat
  if not LoadGLWidgetLib then
    raise Exception.Create(GLWidgetLibName+' not found (looked next to the '
      +'executable and in the system library path). Build it with '
      +'"make -C csrc" from the LazOpenGLContextEx package.');

  NewQtWidget := TQtGLWidget.Create(AWinControl, AParams);
  NewQtWidget.HasPaint := false;

  // must be set before the widget is first shown
  AFormat := QSurfaceFormat_Create();
  try
    QSurfaceFormat_setRenderableType(AFormat, QSurfaceFormatRenderableTypeOpenGL);
    if MajorVersion > 0 then begin
      QSurfaceFormat_setMajorVersion(AFormat, MajorVersion);
      QSurfaceFormat_setMinorVersion(AFormat, MinorVersion);
    end;
    if DoubleBuffered then
      QSurfaceFormat_setSwapBehavior(AFormat, QSurfaceSwapBehaviorDoubleBuffer);
    if RGBA then begin
      QSurfaceFormat_setRedBufferSize(AFormat, RedBits);
      QSurfaceFormat_setGreenBufferSize(AFormat, GreenBits);
      QSurfaceFormat_setBlueBufferSize(AFormat, BlueBits);
    end;
    if AlphaBits > 0 then
      QSurfaceFormat_setAlphaBufferSize(AFormat, AlphaBits);
    QSurfaceFormat_setDepthBufferSize(AFormat, DepthBits);
    QSurfaceFormat_setStencilBufferSize(AFormat, StencilBits);
    if MultiSampling > 1 then
      QSurfaceFormat_setSamples(AFormat, MultiSampling);
    QLCLGLWidget_setFormat(NewQtWidget.Widget, AFormat);
  finally
    QSurfaceFormat_Destroy(AFormat);
  end;
  // legacy GL code leaves arbitrary alpha in the FBO which would make the
  // widget translucent when Qt composites it; force alpha to 1 unless the
  // control explicitly asked for an alpha channel
  QLCLGLWidget_setForceOpaque(NewQtWidget.Widget, AlphaBits = 0);

  NewQtWidget.AttachEvents;
  Result := HWND(NewQtWidget);
end;

procedure LOpenGLDestroyContextInfo(AWinControl: TWinControl);
begin
  if not AWinControl.HandleAllocated then exit;
  // the QOpenGLWidget owns its context; it dies with the widget
end;

end.