LazOpenGLContextEx: TOpenGLControl с Qt-бэкендом на QOpenGLWidget

Форк штатного пакета LazOpenGLContext (Lazarus components/opengl). Qt5/Qt6-бэкенд (glqtnativecontext.pas) использует собственный контекст настоящего QOpenGLWidget вместо ручного GLX на winId(): EGL на Wayland, GLX на X11, WGL/CGL на Windows/macOS под ws=qt6. QOpenGLWidget-наследник с paintGL-хуком живёт в маленькой C++-либе csrc/qlclglwidget.cpp (QLCLOpenGLWidget из libQt6Pas — не QOpenGLWidget, а голый QWidget под внешний GLX). Сборка: csrc/Makefile (linux/macos/windows-кросс mingw-w64/windows-native MSYS2, install, install-app) + build-msvc.bat для MSVC-Qt. Либа грузится в рантайме рядом с бинарником приложения. Бэкенды gtk2/gtk3/win32/cocoa скопированы из стока без изменений (юниты переименованы с суффиксом Ex). Детали и нюансы — в README.md. Проверено: EWSDR, спектр/водопад через GL в нативном Wayland (KDE, qt6), живой эфир QO-100. Co-Authored-By: Claude Fable 5 <noreply@anthropic.com>
2026-08-25 17:37:31 +00:00 · 2026-07-03 15:00:26 +03:00
commit ac46e3d13a
14 changed files with 4041 additions and 0 deletions
@@ -0,0 +1,371 @@
+{
+ *****************************************************************************
+  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);
+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;
+
+procedure LOpenGLViewport(Handle: HWND; Left, Top, Width, Height: integer);
+var
+  Widget: TQtGLWidget;
+  Dpr: Double;
+begin
+  Dpr := 1.0;
+  if (Handle <> 0) and Assigned(QLCLGLWidget_devicePixelRatioF) then begin
+    Widget := TQtGLWidget(Handle);
+    Dpr := QLCLGLWidget_devicePixelRatioF(Widget.Widget);
+    if Dpr <= 0 then Dpr := 1.0;
+  end;
+  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.