commit ac46e3d13a54682f38ee3780a29a2fff51730ae4 Author: Vladimir Date: Fri Jul 3 15:00:26 2026 +0300 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 diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..a726bf8 --- /dev/null +++ b/.gitignore @@ -0,0 +1,11 @@ +# Lazarus package output +lib/ +backup/ +*.compiled + +# built helper library artifacts +*.so +*.dylib +*.dll +*.dll.a +csrc/*.obj diff --git a/README.md b/README.md new file mode 100644 index 0000000..012d43e --- /dev/null +++ b/README.md @@ -0,0 +1,110 @@ +# LazOpenGLContextEx + +Форк штатного пакета `LazOpenGLContext` (Lazarus `components/opengl`), в котором +Qt5/Qt6-бэкенд построен на настоящем `QOpenGLWidget` вместо GLX. + +## Зачем + +Штатный `TOpenGLControl` под `--ws=qt5/qt6` работает только в X11-сессии и +вообще не собирается с Qt-виджетсетом на Windows/macOS: он руками создаёт +GLX-контекст на `winId()`. Важно: `QLCLOpenGLWidget` из libQt6Pas — это **не** +QOpenGLWidget, а голый QWidget с `WA_NativeWindow` и `paintEngine()=nullptr`, +т.е. просто мишень для внешнего GLX-рендера (вызов на нём методов +QOpenGLWidget = access violation — проверено). + +Здесь контекст создаёт сам Qt через платформенный API: + +| Платформа | Контекст | +|------------------|----------| +| Linux Wayland | EGL | +| Linux X11 | GLX | +| Windows (ws=qt6) | WGL | +| macOS (ws=qt6) | CGL | + +Бэкенды gtk2/gtk3/win32/cocoa скопированы из штатного пакета без изменений +(юниты переименованы с суффиксом `Ex`, чтобы не конфликтовать со стоковым пакетом). + +## Состав + +- `openglcontextex.pas` — `TOpenGLControl` (класс называется так же, юнит `OpenGLContextEx`). +- `glqtnativecontext.pas` — Qt-бэкенд поверх QOpenGLWidget. +- `csrc/qlclglwidget.cpp` — **вспомогательная C++-библиотека** `libqlclglwidget.so`: + наследник QOpenGLWidget с paintGL-хуком в Pascal + плоские экспорты + (`makeCurrent`, `doneCurrent`, `isValid`, `setFormat`, + `defaultFramebufferObject`, `devicePixelRatioF`). Грузится в рантайме: + сначала рядом с исполняемым файлом, затем по системным путям. + +## Сборка вспомогательной библиотеки (csrc/) + +| Где собираем | Команда | Результат | +|---|---|---| +| Linux | `make -C csrc` | `libqlclglwidget.so` | +| macOS | `make -C csrc` (авто) или `make -C csrc macos` | `libqlclglwidget.dylib` | +| Linux → Windows (кросс) | `make -C csrc windows` | `qlclglwidget.dll` (MinGW) | +| Windows, MSYS2 MinGW64 shell | `make -C csrc` (авто) или `make -C csrc windows-native` | `qlclglwidget.dll` (MinGW) | +| Windows, Qt MinGW-kit без pkg-config | `make -C csrc windows MINGW_CXX=g++ WIN_QT_INC=C:/Qt/6.x/mingw_64/include WIN_QT_LIB=C:/Qt/6.x/mingw_64/lib` | `qlclglwidget.dll` (MinGW) | +| Windows, MSVC | `csrc\build-msvc.bat` из «x64 Native Tools Command Prompt» с выставленным `QTDIR` | `qlclglwidget.dll` (MSVC) | + +Плюс: + +``` +make -C csrc install # установить в /usr/local/lib (PREFIX/DESTDIR поддерживаются) +make -C csrc install-app APPDIR=/путь/к/бинарнику # положить рядом с приложением +``` + +Для кросс-сборки нужен тулчейн mingw-w64 и **MinGW-сборка Qt6** (AUR +`mingw-w64-qt6-base`, MXE, либо Qt MinGW-kit; пути переопределяются +`MINGW_PREFIX`/`WIN_QT_INC`/`WIN_QT_LIB`). Для MSYS2: +`pacman -S mingw-w64-x86_64-gcc mingw-w64-x86_64-qt6-base pkgconf make`. + +⚠ **ABI:** MinGW-DLL работает только с MinGW-сборкой Qt6 на целевой машине, +MSVC-DLL — только с MSVC-Qt (официальные бинарники Qt из online-инсталлятора — +MSVC). Выбирайте вариант под ту Qt6, с которой собрана libQt6Pas приложения. + +## Использование + +В проекте: зависимость `LazOpenGLContext` → `LazOpenGLContextEx`, +в uses: `OpenGLContext` → `OpenGLContextEx`. + +``` +make -C csrc +lazbuild --ws=qt6 lazopenglcontextex.lpk +make -C csrc install-app APPDIR=<каталог с бинарником приложения> +``` + +## Как устроен Qt-бэкенд + +- Qt сам делает контекст текущим и биндит FBO виджета перед вызовом `paintGL()`; + оттуда доставляется `LM_PAINT`, так что весь рендер в `OnPaint` работает как раньше. +- `SwapBuffers` внутри paint — no-op (композитингом FBO занимается Qt после + возврата из `paintGL`); вне paint — планирует перерисовку (`QWidget::update`). +- `MakeCurrent`/`ReleaseContext` вне paint → `QOpenGLWidget::makeCurrent/doneCurrent`. + До первого показа виджета контекста ещё нет — `MakeCurrent` вернёт False. +- `LOpenGLViewport` (AutoResizeViewport) умножает координаты на devicePixelRatio. + +## Ограничения / нюансы + +- **Не вызывать `glBindFramebuffer(..., 0)`** — QOpenGLWidget рендерит в свой FBO. +- **Альфа фреймбуфера = прозрачность виджета.** Qt композитит FBO с учётом + альфы; легаси-GL-код после блендинга оставляет alpha<1, и виджет просвечивал + бы насквозь. Поэтому обёртка после каждого paintGL принудительно заливает + альфу единицей (`QLCLGLWidget_setForceOpaque`, включено по умолчанию). + Отключается автоматически, если контрол запросил `AlphaBits > 0` — тогда + альфа остаётся под контролем приложения. +- **SharedControl игнорируется**: Qt автоматически шарит контексты всех + QOpenGLWidget внутри одного top-level окна. Для шаринга между окнами нужно + выставить `Qt::AA_ShareOpenGLContexts` до создания QApplication. +- **Windows + qt6**: чтобы Qt не выбрал ANGLE/GLES (где нет immediate mode), + выставить `QT_OPENGL=desktop` или атрибут `AA_UseDesktopOpenGL`. +- **HiDPI (devicePixelRatio > 1)**: FBO больше логического размера виджета. + Явные вызовы `glViewport` в коде приложения должны умножать на dpr сами. +- AUXBuffers не поддерживаются QSurfaceFormat (игнорируются). +- Qt4 (LCLQT), gtk1 и carbon из форка выброшены. + +## Статус проверки + +- Linux Wayland (KDE, qt6): спектр EWSDR рендерится через GL, стартует без + ошибок, скриншот подтверждён (2026-07-03). +- Linux XWayland/xcb: стартует без ошибок. +- Windows/macOS: не проверялось (build.sh под них ещё нет — нужен аналог + с MSVC/clang и Qt-заголовками). diff --git a/csrc/Makefile b/csrc/Makefile new file mode 100644 index 0000000..0637373 --- /dev/null +++ b/csrc/Makefile @@ -0,0 +1,144 @@ +# ---------------------------------------------------------------------------- +# libqlclglwidget — QOpenGLWidget helper library for LazOpenGLContextEx +# +# Build variants: +# make / make linux native Linux build -> ../libqlclglwidget.so +# make macos native macOS build (on a Mac) -> ../libqlclglwidget.dylib +# make windows qlclglwidget.dll with a MinGW toolchain: +# * cross-build from Linux (mingw-w64), OR +# * natively on Windows with a Qt MinGW kit that has +# no pkg-config — override the variables: +# make windows MINGW_CXX=g++ \ +# WIN_QT_INC=C:/Qt/6.x.x/mingw_64/include \ +# WIN_QT_LIB=C:/Qt/6.x.x/mingw_64/lib +# make windows-native natively on Windows in an MSYS2 MinGW64 shell +# (uses pkg-config; auto-selected by plain `make` there) +# build-msvc.bat natively on Windows with MSVC (see the .bat file); +# required when the target Qt6/libQt6Pas is an MSVC +# build — MinGW and MSVC C++ ABIs are incompatible +# +# make install install the host-platform artifact into $(PREFIX)/lib +# (DESTDIR supported; run ldconfig yourself on Linux) +# make install-app APPDIR=/path/to/app/dir +# copy every built artifact next to the app binary +# (the Pascal loader looks there first) +# make clean +# +# Windows cross-build requirements (on the Linux build machine): +# - mingw-w64 toolchain: x86_64-w64-mingw32-g++ +# - a *MinGW* build of Qt6 (headers + import libs), one of: +# * Arch AUR: mingw-w64-qt6-base (installs to /usr/x86_64-w64-mingw32) +# * MXE (https://mxe.cc) with qt6 (set MINGW_PREFIX to the MXE usr dir) +# * a Qt "MinGW" kit copied from a Windows Qt install +# (set WIN_QT_INC / WIN_QT_LIB manually) +# +# Windows native (MSYS2 MinGW64 shell) requirements: +# pacman -S mingw-w64-x86_64-gcc mingw-w64-x86_64-qt6-base pkgconf make +# +# The MinGW-built DLL works only with MinGW Qt6 DLLs on the target machine, +# the MSVC-built DLL only with MSVC Qt6 DLLs (incompatible C++ ABIs). +# +# macOS notes: needs Xcode command line tools + Qt6 with pkg-config files, +# e.g. Homebrew: brew install qt pkgconf +# export PKG_CONFIG_PATH="$(brew --prefix qt)/libexec/lib/pkgconfig" +# ---------------------------------------------------------------------------- + +NAME := qlclglwidget +SRC := qlclglwidget.cpp +OUTDIR := .. + +PREFIX ?= /usr/local +DESTDIR ?= + +CXXFLAGS ?= -O2 +CXXSTD := -std=c++17 + +PKG_CONFIG ?= pkg-config +QT_PKGS := Qt6Widgets Qt6OpenGLWidgets + +# Windows cross toolchain / Qt location (override as needed) +MINGW_CXX ?= x86_64-w64-mingw32-g++ +MINGW_PREFIX ?= /usr/x86_64-w64-mingw32 +WIN_QT_INC ?= $(MINGW_PREFIX)/include/qt6 +WIN_QT_LIB ?= $(MINGW_PREFIX)/lib +WIN_QT_LIBS ?= -lQt6Widgets -lQt6OpenGLWidgets -lQt6Gui -lQt6Core + +LINUX_OUT := $(OUTDIR)/lib$(NAME).so +MACOS_OUT := $(OUTDIR)/lib$(NAME).dylib +WIN_OUT := $(OUTDIR)/$(NAME).dll + +UNAME := $(shell uname -s) +ifeq ($(UNAME),Darwin) + HOST_OUT := $(MACOS_OUT) + HOST_TARGET := macos +else ifneq (,$(findstring MINGW,$(UNAME))$(findstring MSYS,$(UNAME))) + # MSYS2 MinGW64 shell on Windows + HOST_OUT := $(WIN_OUT) + HOST_TARGET := windows-native +else + HOST_OUT := $(LINUX_OUT) + HOST_TARGET := linux +endif + +.PHONY: all linux macos windows windows-native install install-app clean + +all: $(HOST_TARGET) + +linux: $(LINUX_OUT) + +$(LINUX_OUT): $(SRC) + $(CXX) $(CXXFLAGS) $(CXXSTD) -shared -fPIC \ + $(shell $(PKG_CONFIG) --cflags $(QT_PKGS)) \ + -o $@ $(SRC) \ + $(shell $(PKG_CONFIG) --libs $(QT_PKGS)) + +macos: $(MACOS_OUT) + +$(MACOS_OUT): $(SRC) + $(CXX) $(CXXFLAGS) $(CXXSTD) -dynamiclib -fPIC \ + $(shell $(PKG_CONFIG) --cflags $(QT_PKGS)) \ + -o $@ $(SRC) \ + $(shell $(PKG_CONFIG) --libs $(QT_PKGS)) \ + -Wl,-install_name,@rpath/lib$(NAME).dylib + +# MinGW build: cross from Linux, or native on Windows with a Qt MinGW kit +# (no pkg-config needed — plain include/lib paths) +windows: $(WIN_OUT) + +$(WIN_OUT): $(SRC) + $(MINGW_CXX) $(CXXFLAGS) $(CXXSTD) -shared \ + -I$(WIN_QT_INC) \ + -I$(WIN_QT_INC)/QtCore \ + -I$(WIN_QT_INC)/QtGui \ + -I$(WIN_QT_INC)/QtWidgets \ + -I$(WIN_QT_INC)/QtOpenGL \ + -I$(WIN_QT_INC)/QtOpenGLWidgets \ + -o $@ $(SRC) \ + -L$(WIN_QT_LIB) $(WIN_QT_LIBS) \ + -static-libgcc -static-libstdc++ \ + -Wl,--out-implib,$(OUTDIR)/lib$(NAME).dll.a + +# native Windows build in an MSYS2 MinGW64 shell (pkg-config available) +windows-native: + $(CXX) $(CXXFLAGS) $(CXXSTD) -shared \ + $(shell $(PKG_CONFIG) --cflags $(QT_PKGS)) \ + -o $(WIN_OUT) $(SRC) \ + $(shell $(PKG_CONFIG) --libs $(QT_PKGS)) \ + -static-libgcc -static-libstdc++ \ + -Wl,--out-implib,$(OUTDIR)/lib$(NAME).dll.a + +install: $(HOST_OUT) + install -d $(DESTDIR)$(PREFIX)/lib + install -m755 $(HOST_OUT) $(DESTDIR)$(PREFIX)/lib/ + +install-app: + @test -n "$(APPDIR)" || { echo "usage: make install-app APPDIR=/path/to/app/dir"; exit 1; } + install -d $(APPDIR) + @for f in $(LINUX_OUT) $(MACOS_OUT) $(WIN_OUT); do \ + if [ -f $$f ]; then install -m755 $$f $(APPDIR)/ && echo "installed $$f -> $(APPDIR)/"; fi; \ + done + +clean: + rm -f $(LINUX_OUT) $(MACOS_OUT) $(WIN_OUT) \ + $(OUTDIR)/lib$(NAME).dll.a $(OUTDIR)/$(NAME).lib $(OUTDIR)/$(NAME).exp \ + $(NAME).obj diff --git a/csrc/build-msvc.bat b/csrc/build-msvc.bat new file mode 100644 index 0000000..60bc919 --- /dev/null +++ b/csrc/build-msvc.bat @@ -0,0 +1,43 @@ +@echo off +rem --------------------------------------------------------------------------- +rem Builds qlclglwidget.dll natively on Windows with MSVC. +rem +rem Use this when the target Qt6 / libQt6Pas is an MSVC build (the official +rem Qt online-installer binaries are MSVC). A MinGW-built DLL cannot link +rem against MSVC Qt DLLs - the C++ ABIs are incompatible. +rem +rem How to run: +rem 1. Open "x64 Native Tools Command Prompt for VS" (vcvars64 environment). +rem 2. set QTDIR=C:\Qt\6.7.2\msvc2019_64 (your MSVC Qt kit) +rem 3. build-msvc.bat +rem +rem Output: ..\qlclglwidget.dll (put it next to the application executable). +rem --------------------------------------------------------------------------- + +if "%QTDIR%"=="" ( + echo error: set QTDIR to your MSVC Qt kit first, e.g.: + echo set QTDIR=C:\Qt\6.7.2\msvc2019_64 + exit /b 1 +) +if not exist "%QTDIR%\include\QtOpenGLWidgets" ( + echo error: %QTDIR%\include\QtOpenGLWidgets not found - is QTDIR an MSVC Qt6 kit? + exit /b 1 +) + +cl /nologo /LD /EHsc /std:c++17 /permissive- /Zc:__cplusplus /MD /O2 ^ + /I"%QTDIR%\include" ^ + /I"%QTDIR%\include\QtCore" ^ + /I"%QTDIR%\include\QtGui" ^ + /I"%QTDIR%\include\QtWidgets" ^ + /I"%QTDIR%\include\QtOpenGL" ^ + /I"%QTDIR%\include\QtOpenGLWidgets" ^ + qlclglwidget.cpp /Fe:..\qlclglwidget.dll ^ + /link /LIBPATH:"%QTDIR%\lib" Qt6Widgets.lib Qt6OpenGLWidgets.lib Qt6Gui.lib Qt6Core.lib + +if errorlevel 1 ( + echo build FAILED + exit /b 1 +) + +del qlclglwidget.obj ..\qlclglwidget.exp ..\qlclglwidget.lib 2>nul +echo built ..\qlclglwidget.dll diff --git a/csrc/qlclglwidget.cpp b/csrc/qlclglwidget.cpp new file mode 100644 index 0000000..3fd85b5 --- /dev/null +++ b/csrc/qlclglwidget.cpp @@ -0,0 +1,124 @@ +//****************************************************************************** +// qlclglwidget - a real QOpenGLWidget subclass with a Pascal paintGL hook. +// +// libQt6Pas's QLCLOpenGLWidget is NOT a QOpenGLWidget: it is a plain QWidget +// with WA_NativeWindow/paintEngine()=nullptr, designed as a target for an +// external GLX context (X11 only). This tiny library provides the missing +// piece: a genuine QOpenGLWidget whose context is created and managed by Qt +// itself (EGL on Wayland, GLX on X11, WGL on Windows, CGL on macOS), plus +// flat C exports for the methods the Lazarus side needs. +// +// Build: make (Linux .so / macOS .dylib) +// make windows (cross-build .dll with mingw-w64, see Makefile) +// make install (into /usr/local/lib) +//****************************************************************************** + +#include +#include +#include +#include + +// mirrors QHook/QOverrideHook from libQt6Pas pascalbind.h: +// an FPC "procedure of object; cdecl" method pointer passed by value +typedef struct { + void *func; + void *data; +} QGLOverrideHook; + +class QLCLGLWidget : public QOpenGLWidget { +public: + QGLOverrideHook paintGLHook; + // The widget renders into an RGBA FBO that Qt composites with alpha into + // the window. Legacy GL code written for GLX/WGL windows leaves arbitrary + // alpha in the framebuffer (there it was simply ignored), which makes the + // widget translucent here. Unless the user explicitly asked for an alpha + // channel, force alpha to 1 after each paint. + bool forceOpaque; + + explicit QLCLGLWidget(QWidget *parent = nullptr, + Qt::WindowFlags flags = Qt::WindowFlags()) + : QOpenGLWidget(parent, flags) { + paintGLHook.func = nullptr; + paintGLHook.data = nullptr; + forceOpaque = true; + } + +protected: + // Qt makes the context current and binds the widget's FBO before this call + void paintGL() override { + if (paintGLHook.func) { + typedef void (*func_type)(void *data); + (*(func_type)paintGLHook.func)(paintGLHook.data); + if (forceOpaque) + fillAlpha(); + } else { + QOpenGLWidget::paintGL(); + } + } + +private: + void fillAlpha() { + QOpenGLFunctions *f = QOpenGLContext::currentContext()->functions(); + GLboolean mask[4]; + GLfloat clearColor[4]; + f->glGetBooleanv(GL_COLOR_WRITEMASK, mask); + f->glGetFloatv(GL_COLOR_CLEAR_VALUE, clearColor); + GLboolean scissor = f->glIsEnabled(GL_SCISSOR_TEST); + if (scissor) + f->glDisable(GL_SCISSOR_TEST); + f->glColorMask(GL_FALSE, GL_FALSE, GL_FALSE, GL_TRUE); + f->glClearColor(0.f, 0.f, 0.f, 1.f); + f->glClear(GL_COLOR_BUFFER_BIT); + f->glColorMask(mask[0], mask[1], mask[2], mask[3]); + f->glClearColor(clearColor[0], clearColor[1], clearColor[2], clearColor[3]); + if (scissor) + f->glEnable(GL_SCISSOR_TEST); + } +}; + +extern "C" { + +Q_DECL_EXPORT void *QLCLGLWidget_Create(void *parent, unsigned int flags) { + return (void *)new QLCLGLWidget((QWidget *)parent, (Qt::WindowFlags)flags); +} + +Q_DECL_EXPORT void QLCLGLWidget_Destroy(void *handle) { + delete (QLCLGLWidget *)handle; +} + +Q_DECL_EXPORT void QLCLGLWidget_override_paintGL(void *handle, + QGLOverrideHook hook) { + ((QLCLGLWidget *)handle)->paintGLHook = hook; +} + +Q_DECL_EXPORT void QLCLGLWidget_makeCurrent(void *handle) { + ((QLCLGLWidget *)handle)->makeCurrent(); +} + +Q_DECL_EXPORT void QLCLGLWidget_doneCurrent(void *handle) { + ((QLCLGLWidget *)handle)->doneCurrent(); +} + +Q_DECL_EXPORT bool QLCLGLWidget_isValid(void *handle) { + return ((QLCLGLWidget *)handle)->isValid(); +} + +// fmt is a QSurfaceFormatH created via libQt6Pas QSurfaceFormat_Create +Q_DECL_EXPORT void QLCLGLWidget_setFormat(void *handle, void *fmt) { + ((QLCLGLWidget *)handle)->setFormat(*(const QSurfaceFormat *)fmt); +} + +// enabled by default; pass false when the control requests AlphaBits > 0 +Q_DECL_EXPORT void QLCLGLWidget_setForceOpaque(void *handle, bool enable) { + ((QLCLGLWidget *)handle)->forceOpaque = enable; +} + +Q_DECL_EXPORT unsigned int QLCLGLWidget_defaultFramebufferObject(void *handle) { + return ((QLCLGLWidget *)handle)->defaultFramebufferObject(); +} + +Q_DECL_EXPORT double QLCLGLWidget_devicePixelRatioF(void *handle) { + return ((QLCLGLWidget *)handle)->devicePixelRatioF(); +} + +} // extern "C" diff --git a/glcocoanscontextex.pas b/glcocoanscontextex.pas new file mode 100644 index 0000000..95a1d31 --- /dev/null +++ b/glcocoanscontextex.pas @@ -0,0 +1,539 @@ +{ + ***************************************************************************** + See the file COPYING.modifiedLGPL.txt, included in this distribution, + for details about the license. + ***************************************************************************** + + Author: Mattias Gaertner + + ToDo: + use custom pixelformat + attributes: doublebufferd, version, ... + It should work with initWithFrame_pixelFormat, but this paints nothing + SwapBuffers - there is no function like aglSwapBuffers in CGL/NS + Mouse: + the TLCLCommonCallback mouse handlers check Owner.isEnabled, which + for a NSView always returns false. +} +unit GLCocoaNSContextEx; + +{$mode objfpc}{$H+} +{$ModeSwitch objectivec1} + +interface + +uses + Classes, SysUtils, Types, LCLType, Controls, + LMessages, LCLMessageGlue, WSLCLClasses, LazLoggerBase, + MacOSAll, CocoaAll, + CocoaPrivate, CocoaCommonCallback, CocoaUtils, Cocoa_Extra; + +function LBackingScaleFactor(Handle: HWND): single; +procedure LSetWantsBestResolutionOpenGLSurface(const AValue: boolean; Handle: HWND); +procedure LOpenGLViewport(Handle: HWND; Left, Top, Width, Height: integer); +procedure LOpenGLSwapBuffers(Handle: HWND); +function LOpenGLMakeCurrent(Handle: HWND): boolean; +function LOpenGLReleaseContext(Handle: HWND): boolean; +procedure LOpenGLClip(Handle: HWND); +function LOpenGLCreateContext(AWinControl: TWinControl; + {%H-}WSPrivate: TWSPrivateClass; SharedControl: TWinControl; + DoubleBuffered, AMacRetinaMode: boolean; + MajorVersion, MinorVersion: Cardinal; + MultiSampling, AlphaBits, DepthBits, StencilBits, AUXBuffers: Cardinal; + const {%H-}AParams: TCreateParams): HWND; +procedure LOpenGLDestroyContextInfo(AWinControl: TWinControl); +function CreateOpenGLContextAttrList(DoubleBuffered: boolean; + MajorVersion, MinorVersion: Cardinal; + MultiSampling, AlphaBits, DepthBits, + StencilBits, AUXBuffers: cardinal): NSOpenGLPixelFormatAttributePtr; + +const + // missing constants in FPC 3.1.1 rev 31197 and below + NSOpenGLPFAOpenGLProfile = 99; //cr: name changed to match https://developer.apple.com/library/mac/documentation//Cocoa/Reference/ApplicationKit/Classes/NSOpenGLPixelFormat_Class/index.html + NSOpenGLProfileLegacy = $1000; + NSOpenGLProfileVersion3_2Core = $3200; + NSOpenGLProfileVersion4_1Core = $4100; //requires OSX SDK 10.10 or later, https://github.com/google/gxui/issues/98 + +type + NSOpenGLViewFix = objccategory external (NSOpenGLView) + procedure setWantsBestResolutionOpenGLSurface(bool: NSInteger); message 'setWantsBestResolutionOpenGLSurface:'; + end; + + { TCocoaOpenGLView } + + TCocoaOpenGLView = objcclass(NSOpenGLView) + public + Owner: TWinControl; + callback: TLCLCommonCallback; + backingScaleFactor: Single; + function acceptsFirstResponder: LCLObjCBoolean; override; + function becomeFirstResponder: LCLObjCBoolean; override; + function resignFirstResponder: LCLObjCBoolean; override; + procedure drawRect(dirtyRect: NSRect); override; + procedure dealloc; override; + function lclGetCallback: ICommonCallback; override; + procedure lclClearCallback; override; + function lclIsEnabled: Boolean; override; + // mouse + procedure mouseDown(event: NSEvent); override; + procedure mouseUp(event: NSEvent); override; + procedure rightMouseDown(event: NSEvent); override; + procedure rightMouseUp(event: NSEvent); override; + procedure rightMouseDragged(event: NSEvent); override; + procedure otherMouseDown(event: NSEvent); override; + procedure otherMouseUp(event: NSEvent); override; + procedure otherMouseDragged(event: NSEvent); override; + procedure mouseDragged(event: NSEvent); override; + procedure mouseEntered(event: NSEvent); override; + procedure mouseExited(event: NSEvent); override; + procedure mouseMoved(event: NSEvent); override; + procedure scrollWheel(event: NSEvent); override; + end; + +function GetCGLContextObj(OpenGLControlHandle: HWND): CGLContextObj; +(*function CreateCGLContextAttrList(DoubleBuffered: boolean; + {$IFDEF UsesModernGL} + MajorVersion, MinorVersion: Cardinal; + {$ENDIF} + MultiSampling, AlphaBits, DepthBits, + StencilBits, AUXBuffers: cardinal): PInteger; +function IsCGLPixelFormatAvailable(Attribs: PInteger): boolean;*) + +implementation + +//value > 1 if screen is scaled, e.g. default for MOST retina displays is 2 +function LBackingScaleFactor(Handle: HWND): single; +begin + result := TCocoaOpenGLView(Handle).backingScaleFactor; +end; + +procedure LSetWantsBestResolutionOpenGLSurface(const AValue: boolean; Handle: HWND); +var + View: TCocoaOpenGLView; +begin + if Handle=0 then exit; + View:=TCocoaOpenGLView(Handle); + if not View.respondsToSelector(objcselector('setWantsBestResolutionOpenGLSurface:')) then exit; + if AValue then + View.setWantsBestResolutionOpenGLSurface(1) + else + View.setWantsBestResolutionOpenGLSurface(0); + if (AValue) and (NSScreen.mainScreen.respondsToSelector(objcselector('backingScaleFactor'))) then //MacOS >=10.7 + View.backingScaleFactor := NSScreen.mainScreen.backingScaleFactor + else + View.backingScaleFactor := 1; +end; + +procedure LOpenGLViewport(Handle: HWND; Left, Top, Width, Height: integer); +var + View: NSOpenGLView absolute Handle; + lFinalWidth, lFinalHeight: Integer; +begin + lFinalWidth := Width; + lFinalHeight := Height; + if View <> nil then + begin + lFinalWidth := Round(Width * LBackingScaleFactor(Handle)); + lFinalHeight := Round(Height * LBackingScaleFactor(Handle)); + end; + glViewport(Left,Top,lFinalWidth,lFinalHeight); +end; + +procedure LOpenGLSwapBuffers(Handle: HWND); +//var +// View: TCocoaOpenGLView; //TCocoaOpenGLView +begin + if Handle=0 then exit; + glFlush(); + // View:=TCocoaOpenGLView(Handle); + // View.nsGL.flushBuffer; +end; + +function LOpenGLMakeCurrent(Handle: HWND): boolean; +var + CGLContext: CGLContextObj; +begin + if Handle=0 then exit(false); + CGLContext:=GetCGLContextObj(Handle); + Result:=CGLSetCurrentContext(CGLContext)=kCGLNoError; +end; + +function LOpenGLReleaseContext(Handle: HWND): boolean; +begin + if Handle=0 then exit(false); + Result:=CGLSetCurrentContext(nil)=kCGLNoError; + //Result:=true; +end; + +procedure LOpenGLClip(Handle: HWND); +begin + if Handle=0 then exit; + // ToDo +end; + +function LOpenGLCreateContext(AWinControl: TWinControl; + WSPrivate: TWSPrivateClass; SharedControl: TWinControl; + DoubleBuffered, AMacRetinaMode: boolean; + MajorVersion, MinorVersion: Cardinal; + MultiSampling, AlphaBits, DepthBits, StencilBits, + AUXBuffers: Cardinal; const AParams: TCreateParams): HWND; +var + View: TCocoaOpenGLView; + Attrs: NSOpenGLPixelFormatAttributePtr; + PixFmt: NSOpenGLPixelFormat; + p: NSView; + ns: NSRect; + aNSOpenGLContext, SharedContext: NSOpenGLContext; +begin + Result:=0; + p := nil; + if (AParams.WndParent <> 0) then + p := NSObject(AParams.WndParent).lclContentView; + if Assigned(p) then + TCocoaTypeUtil.toRect(types.Bounds(AParams.X, AParams.Y, AParams.Width, AParams.Height), + p.frame.size.height, ns) + else + ns := NSMakeRect(AParams.X, AParams.Y, AParams.Width, AParams.Height); + Attrs:=CreateOpenGLContextAttrList(DoubleBuffered,MajorVersion,MinorVersion, MultiSampling,AlphaBits,DepthBits,StencilBits,AUXBuffers); + try + PixFmt:=NSOpenGLPixelFormat(NSOpenGLPixelFormat.alloc).initWithAttributes(Attrs); + { Use SharedControl to share OpenGL resources with another TOpenGLControl instance } + if SharedControl <> nil then + SharedContext := TCocoaOpenGLView(SharedControl.Handle).openGLContext + else + SharedContext := nil; + aNSOpenGLContext:=NSOpenGLContext(NSOpenGLContext.alloc).initWithFormat_shareContext(PixFmt,SharedContext); + if aNSOpenGLContext = nil then + debugln(['LOpenGLCreateContext Error']); + View := TCocoaOpenGLView(TCocoaOpenGLView.alloc).initWithFrame_pixelFormat(ns,PixFmt); + if not Assigned(View) then Exit; + finally + FreeMem(Attrs); + end; + View.setHidden(AParams.Style and WS_VISIBLE = 0); + if Assigned(p) then + p.addSubview(View); + TCocoaViewUtil.setDefaultMargin(View); + View.Owner:=AWinControl; + { If we wouldn't set View.openGLContext, it would get automatically created. + But then aNSOpenGLContext is ignored, and so SharedContext and SharedControl don't work. } + View.setOpenGLContext(aNSOpenGLContext); + View.callback:=TLCLCommonCallback.Create(View, AWinControl); + LSetWantsBestResolutionOpenGLSurface(AMacRetinaMode, HWND(View)); + //View.setPixelFormat(PixFmt); + Result:=TLCLHandle(View); +end; + +procedure LOpenGLDestroyContextInfo(AWinControl: TWinControl); +begin + // no special needed, simply release handle + if AWinControl=nil then + raise Exception.Create(''); +end; + +function CreateOpenGLContextAttrList(DoubleBuffered: boolean; MajorVersion, + MinorVersion: Cardinal; MultiSampling, AlphaBits, DepthBits, StencilBits, + AUXBuffers: cardinal): NSOpenGLPixelFormatAttributePtr; +var + p: integer; + + procedure AddUInt32(i: NSOpenGLPixelFormatAttribute); + begin + if Result<>nil then + Result[p]:=i; + inc(p); + end; + + procedure CreateList; + begin + //see https://developer.apple.com/library/mac/documentation//Cocoa/Reference/ApplicationKit/Classes/NSOpenGLPixelFormat_Class/index.html + //AddUInt32(NSOpenGLPFAAccelerated); // <- comment out: we can run in software if hardware is not available + //AddUInt32(NSOpenGLPFAOpenGLProfile); //Versions beyond 'Legacy' appear to break CULL_FACE and DEPTH_BUFFER, legacy seems to be default, so comment out whole instruction + //if (MajorVersion>=4) and (MinorVersion>=1) + // AddUInt32(NSOpenGLProfileVersion4_1Core); + //else if (MajorVersion>=3) and (MinorVersion>=2) then + // AddUInt32(NSOpenGLProfileVersion3_2Core); + //else + //AddUInt32(NSOpenGLProfileLegacy); // NSOpenGLProfileLegacy is default and sufficient, later versions depend on SDK we are building against + AddUInt32(NSOpenGLPFAOpenGLProfile); + if (MajorVersion>=4) and (MinorVersion>=1) then + AddUInt32(NSOpenGLProfileVersion4_1Core) //OpenGL 4.1, GLSL 4.1 + else if (MajorVersion>=3) and (MinorVersion>=2) then + AddUInt32(NSOpenGLProfileVersion3_2Core) + else + AddUInt32(NSOpenGLProfileLegacy); //OpenGL 2.1, GLSL 1.2 + AddUInt32(NSOpenGLPFAColorSize); AddUInt32(24); + if DepthBits > 0 then begin + AddUInt32(NSOpenGLPFADepthSize); AddUInt32(32); + end; + if AlphaBits>0 then begin + AddUInt32(NSOpenGLPFAAlphaSize); AddUInt32(AlphaBits); + end; + AddUInt32(NSOpenGLPFAAccelerated); + if MultiSampling > 1 then begin + AddUInt32(NSOpenGLPFAMultisample); + AddUInt32(NSOpenGLPFASampleBuffers); AddUInt32(1); + AddUInt32(NSOpenGLPFASamples); AddUInt32(MultiSampling); + end; + if StencilBits>0 then + begin + AddUInt32(NSOpenGLPFAStencilSize); AddUInt32(StencilBits); + end; + if AUXBuffers>0 then + begin + AddUInt32(NSOpenGLPFAAuxBuffers); AddUInt32(AUXBuffers); + end; + //if DoubleBuffered then //requires fix for nsGL + // AddUInt32(NSOpenGLPFADoubleBuffer); //this doen't work with Lazarus + AddUInt32(NSOpenGLPFAMaximumPolicy); //allows future changes to make attributes more demanding, e.g. add multisampling + + AddUInt32(NSOpenGLPFANoRecovery); //see apple web page: "not generally useful" but might help with multisample + AddUInt32(0); // end of list + end; + +begin + Result:=nil; + p:=0; + CreateList; + GetMem(Result,SizeOf(NSOpenGLPixelFormatAttribute)*(p+1)); + p:=0; + CreateList; +end; + +function GetCGLContextObj(OpenGLControlHandle: HWND): CGLContextObj; +var + View: NSOpenGLView; +begin + Result:=nil; + if OpenGLControlHandle=0 then exit; + View:=TCocoaOpenGLView(OpenGLControlHandle); + Result:=CGLContextObj(View.openGLContext.CGLContextObj); + NSScreen.mainScreen.colorSpace; +end; + +(* +//these functions are commented out: this was an attempt to use CGL, porting NSOpenGLView instead was more successful +function CreateCGLContextAttrList(DoubleBuffered: boolean; MultiSampling, + AlphaBits, DepthBits, StencilBits, AUXBuffers: cardinal): PInteger; +var + p: integer; + + procedure Add(i: integer); + begin + if Result<>nil then + Result[p]:=i; + inc(p); + end; + + procedure CreateList; + begin + //Add(kCGLPFAWindow); deprecated since 10.9 + Add(kCGLPFAAccelerated); + if DoubleBuffered then + Add(kCGLPFADoubleBuffer); + //if (MajorVersion>=3) and (MinorVersion>=2) then + // Add(kCGLOGLPVersion); + Add(kCGLPFANoRecovery); + Add(kCGLPFAMaximumPolicy); + Add(kCGLPFASingleRenderer); + if AlphaBits>0 then + begin + Add(kCGLPFAAlphaSize); Add(AlphaBits); + end; + if DepthBits>0 then + begin + Add(kCGLPFADepthSize); Add(DepthBits); + end; + if StencilBits>0 then + begin + Add(kCGLPFAStencilSize); Add(StencilBits); + end; + if AUXBuffers>0 then + begin + //Add(kCGLPFAAuxBuffers); Add(AUXBuffers); ToDo + end; + if MultiSampling > 1 then + begin + Add(kCGLPFASampleBuffers); Add(1); + Add(kCGLPFASamples); Add(MultiSampling); + end; + + Add(0); // end of list + end; + +begin + Result:=nil; + p:=0; + CreateList; + GetMem(Result,SizeOf(integer)*p); + p:=0; + CreateList; +end; + +function IsCGLPixelFormatAvailable(Attribs: PInteger): boolean; +var + //display: CGDirectDisplayID; + aPixFormatObj: CGLPixelFormatObj; + aPixObjCountAttrList: GLint; +begin + //display := CGMainDisplayID(); + if CGLChoosePixelFormat(Attribs, @aPixFormatObj, @aPixObjCountAttrList)<>kCGLNoError + then + exit(false); + if aPixFormatObj=nil then + exit(false); + Result:=true; + // ToDo: free aPixFormatObj +end; *) + +{ TCocoaOpenGLView } + +function TCocoaOpenGLView.acceptsFirstResponder: LCLObjCBoolean; +begin + Result := True; +end; + +function TCocoaOpenGLView.becomeFirstResponder: LCLObjCBoolean; +begin + Result:=inherited becomeFirstResponder; + TCocoaLCLMessageUtil.BecomeFirstResponder(self); +end; + +function TCocoaOpenGLView.resignFirstResponder: LCLObjCBoolean; +begin + Result:=inherited resignFirstResponder; + TCocoaLCLMessageUtil.ResignFirstResponder(self); +end; + +procedure TCocoaOpenGLView.dealloc; +begin + inherited dealloc; +end; + +function TCocoaOpenGLView.lclGetCallback: ICommonCallback; +begin + Result := callback; +end; + +procedure TCocoaOpenGLView.lclClearCallback; +begin + callback := nil; +end; + +function TCocoaOpenGLView.lclIsEnabled: Boolean; +begin + Result := Owner.Enabled; +end; + +procedure TCocoaOpenGLView.mouseDown(event: NSEvent); +begin + if not Assigned(callback) or not callback.MouseUpDownEvent(event) then + begin + // do not pass mouseDown below or it will pass it to the parent control + // causing double events + //inherited mouseDown(event); + end; +end; + +procedure TCocoaOpenGLView.mouseUp(event: NSEvent); +begin + if not Assigned(callback) or not callback.MouseUpDownEvent(event) then + inherited mouseUp(event); +end; + +procedure TCocoaOpenGLView.rightMouseDown(event: NSEvent); +begin + if not Assigned(callback) or not callback.MouseUpDownEvent(event) then + inherited rightMouseDown(event); +end; + +procedure TCocoaOpenGLView.rightMouseUp(event: NSEvent); +begin + if not Assigned(callback) or not callback.MouseUpDownEvent(event) then + inherited rightMouseUp(event); +end; + +procedure TCocoaOpenGLView.rightMouseDragged(event: NSEvent); +begin + if not Assigned(callback) or not callback.MouseMove(event) then + inherited rightMouseDragged(event); +end; + +procedure TCocoaOpenGLView.otherMouseDown(event: NSEvent); +begin + if not Assigned(callback) or not callback.MouseUpDownEvent(event) then + inherited otherMouseDown(event); +end; + +procedure TCocoaOpenGLView.otherMouseUp(event: NSEvent); +begin + if not Assigned(callback) or not callback.MouseUpDownEvent(event) then + inherited otherMouseUp(event); +end; + +procedure TCocoaOpenGLView.otherMouseDragged(event: NSEvent); +begin + if not Assigned(callback) or not callback.MouseMove(event) then + inherited otherMouseDragged(event); +end; + +procedure TCocoaOpenGLView.mouseDragged(event: NSEvent); +begin + if Assigned(callback) + then callback.MouseMove(event) + else inherited mouseDragged(event); +end; + +procedure TCocoaOpenGLView.mouseEntered(event: NSEvent); +begin + inherited mouseEntered(event); +end; + +procedure TCocoaOpenGLView.mouseExited(event: NSEvent); +begin + inherited mouseExited(event); +end; + +procedure TCocoaOpenGLView.mouseMoved(event: NSEvent); +begin + if not Assigned(callback) or not callback.MouseMove(event) then + inherited mouseMoved(event); +end; + +procedure TCocoaOpenGLView.scrollWheel(event: NSEvent); +begin + if Assigned(callback) + then callback.scrollWheel(event) + else inherited scrollWheel(event); +end; + +procedure TCocoaOpenGLView.drawRect(dirtyRect: NSRect); +var + ctx : NSGraphicsContext; + PS : TPaintStruct; + r : NSRect; +begin + ctx := NSGraphicsContext.currentContext; + inherited drawRect(dirtyRect); + if TCocoaApplicationUtil.isMainThread and Assigned(callback) then + begin + if ctx = nil then + begin + // In macOS 10.14 (mojave) current context is nil + // we still can paint anything related to OpenGL! + // todo: consider creating a dummy context (for a bitmap) + FillChar(PS, SizeOf(TPaintStruct), 0); + r := frame; + r.origin.x:=0; + r.origin.y:=0; + PS.hdc := HDC(0); + PS.rcPaint := TCocoaTypeUtil.toRect(r); + LCLSendPaintMsg(Owner, HDC(0), @PS); + end + else + callback.Draw(ctx, bounds, dirtyRect); + end; +end; + +end. + diff --git a/glgtk3glxcontextex.pas b/glgtk3glxcontextex.pas new file mode 100644 index 0000000..39e30f0 --- /dev/null +++ b/glgtk3glxcontextex.pas @@ -0,0 +1,143 @@ +unit GLGtk3GlxContextEx; + +{$mode objfpc} +{$LinkLib GL} + +interface + +uses + Classes, SysUtils, ctypes, X, XUtil, XLib, gl, glext, glx, + // LazUtils + LazUtilities, + // LCL + LCLType, InterfaceBase, LMessages, Controls, + WSLCLClasses, LCLMessageGlue, + glib2, gtk3int, LazGdk3, LazGtk3, gtk3widgets; + +function LBackingScaleFactor(Handle: HWND): single; +procedure LOpenGLViewport({%H-}Handle: HWND; Left, Top, Width, Height: integer); +procedure LOpenGLSwapBuffers(Handle: HWND); +function LOpenGLMakeCurrent(Handle: HWND): boolean; +function LOpenGLReleaseContext({%H-}Handle: HWND): boolean; +function LOpenGLCreateContext(AWinControl: TWinControl; + WSPrivate: TWSPrivateClass; SharedControl: TWinControl; + DoubleBuffered, RGBA, DebugContext: boolean; + const RedBits, GreenBits, BlueBits, MajorVersion, MinorVersion, + MultiSampling, AlphaBits, DepthBits, StencilBits, AUXBuffers: Cardinal; + const AParams: TCreateParams): HWND; +procedure LOpenGLDestroyContextInfo(AWinControl: TWinControl); + +implementation + +{$assertions on} + +procedure on_render(widget: PGtkWidget; context: gpointer{Pcairo_t}; data: TGtk3Widget); cdecl; +begin + data.LCLObject.Perform(LM_PAINT, WParam(data), 0); +end; + +function gtkglarea_size_allocateCB(Widget: PGtkWidget; Size: pGtkAllocation; Data: gPointer): GBoolean; cdecl; +var + SizeMsg: TLMSize; + GtkWidth, GtkHeight: integer; + LCLControl: TWinControl; +begin + Result := true; + LCLControl:=TWinControl(Data); + if LCLControl=nil then exit; + + gtk_widget_get_size_request(Widget, @GtkWidth, @GtkHeight); + + SizeMsg.Msg:=0; + FillChar(SizeMsg,SizeOf(SizeMsg),0); + with SizeMsg do + begin + Result := 0; + Msg := LM_SIZE; + SizeType := Size_SourceIsInterface; + Width := SmallInt(GtkWidth); + Height := SmallInt(GtkHeight); + end; + LCLControl.WindowProc(TLMessage(SizeMsg)); +end; + +function gtk_gl_area_get_error (area: PGtkGLArea): PGError; cdecl; external; + +function LBackingScaleFactor(Handle: HWND): single; +var + glarea: TGtk3GLArea absolute Handle; +begin + if Assigned(glarea) then begin + Result := glarea.GetWindow^.get_scale_factor; + end else begin + Result := 1; + end; +end; + +procedure LOpenGLViewport(Handle: HWND; Left, Top, Width, Height: integer); +var + scaleFactor: integer; +begin + scaleFactor := RoundToInt(LBackingScaleFactor(Handle)); + glViewport(Left,Top,Width*scaleFactor,Height*scaleFactor); +end; + +procedure LOpenGLSwapBuffers(Handle: HWND); +var + glarea: TGtk3GLArea absolute Handle; +begin + if Handle=0 then exit; + glFlush(); +end; + +function LOpenGLMakeCurrent(Handle: HWND): boolean; +var + glarea: TGtk3GLArea absolute Handle; +begin + glarea.Widget^.realize; + PGtkGLArea(glarea.Widget)^.make_current; + Assert(gtk_gl_area_get_error(PGtkGLArea(glarea.Widget)) = nil, 'LOpenGLMakeCurrent failed'); + result := true; +end; + +function LOpenGLReleaseContext(Handle: HWND): boolean; +var + glarea: TGtk3GLArea absolute Handle; +begin + // todo(ryan): is it possible to make no context current? + result:=true; +end; + +function LOpenGLCreateContext(AWinControl: TWinControl; + WSPrivate: TWSPrivateClass; SharedControl: TWinControl; + DoubleBuffered, RGBA, DebugContext: boolean; + const RedBits, GreenBits, BlueBits, MajorVersion, MinorVersion, + MultiSampling, AlphaBits, DepthBits, StencilBits, AUXBuffers: Cardinal; + const AParams: TCreateParams): HWND; +var + NewWidget: TGtk3GLArea; + glarea: PGtkGLArea; +begin + NewWidget := TGtk3GLArea.Create(AWinControl, AParams); + result := TLCLHandle(NewWidget); + glarea := PGtkGLArea(NewWidget.Widget); + + g_signal_connect(glarea, 'render', TGCallback(@on_render), NewWidget); + // todo(ryan): do we need this? + g_signal_connect_after(glarea, 'size-allocate', TGCallback(@gtkglarea_size_allocateCB), AWinControl); + + glarea^.set_auto_render(false); + glarea^.set_required_version(MajorVersion, MinorVersion); + glarea^.set_has_depth_buffer(DepthBits > 0); + glarea^.set_has_alpha(AlphaBits > 0); + glarea^.set_has_stencil_buffer(StencilBits > 0); +end; + +procedure LOpenGLDestroyContextInfo(AWinControl: TWinControl); +begin + if not AWinControl.HandleAllocated then exit; + // nothing to do +end; + +end. + diff --git a/glgtkglxcontextex.pas b/glgtkglxcontextex.pas new file mode 100644 index 0000000..ef9c920 --- /dev/null +++ b/glgtkglxcontextex.pas @@ -0,0 +1,1018 @@ +{ + ***************************************************************************** + See the file COPYING.modifiedLGPL.txt, included in this distribution, + for details about the license. + ***************************************************************************** + + Author: Mattias Gaertner + +} +unit GLGtkGlxContextEx; + +{$mode objfpc}{$H+} +{$LinkLib GL} +{$PACKRECORDS C} + +interface + +uses + Classes, SysUtils, ctypes, LCLProc, LCLType, X, XUtil, XLib, gl, + InterfaceBase, + glx, + WSLCLClasses, + {$IFDEF LCLGTK2} + LMessages, Gtk2Def, gdk2x, glib2, gdk2, gtk2, Gtk2Int, + {$ENDIF} + {$IFDEF LCLGTK} + glib, gdk, gtk, GtkInt, + {$ENDIF} + Controls; + +type + TGLBool = longbool; +const + GLXTrue:longbool = true; + GLXFalse:longbool = false; + +type + TGdkGLContext = record end; + PGdkGLContext = ^TGdkGLContext; + +// GLX_EXT_visual_info extension + +function gdk_gl_query: boolean; +function gdk_gl_choose_visual(attrlist: Plongint): PGdkVisual; +function gdk_gl_get_config(visual: PGdkVisual; attrib: longint): longint; +function gdk_gl_context_new(visual: PGdkVisual; attrlist: PlongInt): PGdkGLContext; +function gdk_gl_context_share_new(visual: PGdkVisual; sharelist: PGdkGLContext; + direct: TGLBool; attrlist: plongint): PGdkGLContext; +function gdk_gl_context_attrlist_share_new(attrlist: Plongint; + sharelist: PGdkGLContext; direct: TGLBool): PGdkGLContext; +function gdk_gl_context_ref(context: PGdkGLContext): PGdkGLContext; +function gdk_gl_context_unref(context:PGdkGLContext): PGdkGLContext; +function gdk_gl_make_current(drawable: PGdkDrawable; + context: PGdkGLContext): boolean; +procedure gdk_gl_swap_buffers(drawable: PGdkDrawable); +procedure gdk_gl_wait_gdk; +procedure gdk_gl_wait_gl; + +{ glpixmap stuff } + +type + TGdkGLPixmap = record end; + PGdkGLPixmap = ^TGdkGLPixmap; + TGLXContext = pointer; + + +// gtkglarea + +type + TGtkGlAreaMakeCurrentType = boolean; + + PGtkGLArea = ^TGtkGLArea; + TGtkGLArea = record + darea: TGtkDrawingArea; + glcontext: PGdkGLContext; + end; + + PGtkGLAreaClass = ^TGtkGLAreaClass; + TGtkGLAreaClass = record + parent_class: TGtkDrawingAreaClass; + end; + + TContextAttribs = record + AttributeList: PLongint; + MajorVersion: Cardinal; + MinorVersion: Cardinal; + MultiSampling: Cardinal; + ContextFlags: Cardinal; + end; + +function GTK_TYPE_GL_AREA: TGtkType; +function GTK_GL_AREA(obj: Pointer): PGtkGLArea; +function GTK_GL_AREA_CLASS(klass: Pointer): PGtkGLAreaClass; +function GTK_IS_GL_AREA(obj: Pointer): Boolean; +function GTK_IS_GL_AREA_CLASS(klass: Pointer): Boolean; + +function gtk_gl_area_get_type: TGtkType; +function gtk_gl_area_new(Attribs: TContextAttribs): PGtkWidget; +function gtk_gl_area_share_new(Attribs: TContextAttribs; share: PGtkGLArea): PGtkWidget; +function gtk_gl_area_share_new_usefpglx(Attribs: TContextAttribs; share: PGtkGLArea): PGtkGLArea; +function gtk_gl_area_make_current(glarea: PGtkGLArea): boolean; +function gtk_gl_area_begingl(glarea: PGtkGLArea): boolean; +procedure gtk_gl_area_swap_buffers(gl_area: PGtkGLArea); + +procedure LOpenGLViewport({%H-}Handle: HWND; Left, Top, Width, Height: integer); +procedure LOpenGLSwapBuffers(Handle: HWND); +function LOpenGLMakeCurrent(Handle: HWND): boolean; +function LOpenGLReleaseContext({%H-}Handle: HWND): boolean; +function LOpenGLCreateContext(AWinControl: TWinControl; + WSPrivate: TWSPrivateClass; SharedControl: TWinControl; + DoubleBuffered, RGBA, DebugContext: boolean; + const RedBits, GreenBits, BlueBits, MajorVersion, MinorVersion, + MultiSampling, AlphaBits, DepthBits, StencilBits, AUXBuffers: Cardinal; + const AParams: TCreateParams): HWND; +procedure LOpenGLDestroyContextInfo(AWinControl: TWinControl); + +{ Create GLX attributes list suitable for glXChooseVisual or glXChooseFBConfig. } +function CreateOpenGLContextAttrList(DoubleBuffered: boolean; + RGBA: boolean; + const RedBits, GreenBits, BlueBits, + AlphaBits, DepthBits, StencilBits, AUXBuffers: Cardinal): PInteger; + +implementation + + +var + gl_area_type: TGtkType = 0; + parent_class: Pointer = nil; + +type + TGdkGLContextPrivate = record + xdisplay: PDisplay; + glxcontext: TGLXContext; + ref_count: gint; + end; + PGdkGLContextPrivate = ^TGdkGLContextPrivate; + +type + //PGLXPixmap = ^GLXPixmap; + GLXPixmap = {%H-}TXID; + + //PGLXDrawable = ^GLXDrawable; + GLXDrawable = {%H-}TXID; + +procedure g_return_if_fail(b: boolean; const Msg: string); +begin + if not b then raise Exception.Create(Msg); +end; + +procedure g_return_if_fail(b: boolean); +begin + g_return_if_fail(b,''); +end; + +function DefaultScreen(ADisplay: PDisplay): longint; +begin + Result:=XDefaultScreen(ADisplay); +end; + +function g_new(BaseSize, Count: integer): Pointer; +begin + Result:=g_malloc(BaseSize*Count); +end; + +function GetDefaultXDisplay: PDisplay; +begin + Result:=GDK_DISPLAY; +end; + +{$IFDEF LCLGtk2} +function GdkVisualAsString(Visual: PGdkVisual): string; +begin + if Visual=nil then begin + Result:='nil'; + end else begin + with Visual^ do begin + Result:='' + //parent_instance : TGObject; + +' TheType='+dbgs(ord(TheType)) + +' depth='+dbgs(depth) + +' byte_order='+dbgs(ord(byte_order)) + +' colormap_size='+dbgs(colormap_size) + +' bits_per_rgb='+dbgs(bits_per_rgb) + +' red_mask='+hexstr(red_mask,8) + +' red_shift='+dbgs(red_shift) + +' red_prec='+dbgs(red_prec) + +' green_mask='+hexstr(green_mask,8) + +' green_shift='+dbgs(green_shift) + +' green_prec='+dbgs(green_prec) + +' blue_mask='+hexstr(blue_mask,8) + +' blue_shift='+dbgs(blue_shift) + +' blue_prec='+dbgs(blue_prec) + //screen : PGdkScreen; + +''; + end; + end; +end; + +function XVisualAsString(AVisual: PVisual): string; +begin + if AVisual=nil then begin + Result:='nil'; + end else begin + Result:='' + +' bits_per_rgb='+dbgs(AVisual^.bits_per_rgb) + +' red_mask='+hexstr(AVisual^.red_mask,8) + +' green_mask='+hexstr(AVisual^.green_mask,8) + +' blue_mask='+hexstr(AVisual^.blue_mask,8) + +' map_entries='+dbgs(AVisual^.map_entries) + +''; + end; +end; + +function XDisplayAsString(ADisplay: PDisplay): string; +begin + if ADisplay=nil then begin + Result:='nil'; + end else begin + Result:='' + +''; + end; +end; +{$ENDIF} + +function get_xvisualinfo(visual: PGdkVisual): PXVisualInfo; +// IMPORTANT: remember to XFree returned XVisualInfo !!! +var + vinfo_template: TXVisualInfo; + dpy: PDisplay; + nitems_return: integer; + vi: PXVisualInfo; +begin + dpy := GetDefaultXDisplay; + {$IFDEF Lclgtk2} + DebugLn('get_xvisualinfo dpy=',XDisplayAsString(dpy)); + DebugLn('get_xvisualinfo visual=',GdkVisualAsString(Visual)); + RaiseGDBException('not implemented for gtk2'); + {$ENDIF} + + // 'GLX uses VisualInfo records because they uniquely identify + // a (VisualID,screen,depth) tuple.' + vinfo_template.bits_per_rgb:=0; + FillChar(vinfo_template,SizeOf(vinfo_template),0); + vinfo_template.visual := GDK_VISUAL_XVISUAL({$IFDEF LCLGTK} + PGdkVisualPrivate(visual) + {$ELSE} + visual + {$ENDIF}); + vinfo_template.visualid := XVisualIDFromVisual(vinfo_template.visual); + vinfo_template.depth := PGdkVisualPrivate(visual)^.visual.depth; + vinfo_template.screen := DefaultScreen(GetDefaultXDisplay); + {$IFDEF LCLGTK2} + DebugLn('get_xvisualinfo vinfo_template.visual=',dbgs(vinfo_template.visual)); + DebugLn('get_xvisualinfo vinfo_template.visual: ',XVisualAsString(vinfo_template.visual)); + DebugLn('get_xvisualinfo vinfo_template.visualid=',dbgs(vinfo_template.visualid)); + DebugLn('get_xvisualinfo vinfo_template.depth=',dbgs(vinfo_template.depth),' GetDefaultXDisplay=',dbgs(GetDefaultXDisplay)); + DebugLn('get_xvisualinfo vinfo_template.screen=',dbgs(vinfo_template.screen)); + {$ENDIF} + vi := XGetVisualInfo(dpy, VisualIDMask or VisualDepthMask or VisualScreenMask, + @vinfo_template, @nitems_return); + DebugLn('get_xvisualinfo nitems_return=',dbgs(nitems_return)); + // visualinfo needs to be unique + if (vi=nil) then raise Exception.Create('get_xvisualinfo vi=nil'); + if (nitems_return<>1) then raise Exception.Create('get_xvisualinfo nitems_return='+dbgs(nitems_return)); + + Result:=vi; +end; + +procedure gtk_gl_area_destroy(obj: PGtkObject); cdecl; +var + gl_area: PGtkGLArea; +begin + g_return_if_fail (obj <>nil,''); + g_return_if_fail (GTK_IS_GL_AREA(obj),''); + + gl_area := GTK_GL_AREA(obj); + if gl_area^.glcontext <> nil then // avoid double-free + gl_area^.glcontext := gdk_gl_context_unref(gl_area^.glcontext); + + if Assigned(GTK_OBJECT_CLASS(parent_class)^.destroy) then + GTK_OBJECT_CLASS(parent_class)^.destroy(obj); +end; + +procedure gtk_gl_area_class_init(klass: Pointer); cdecl; +var + object_class: PGtkObjectClass; +begin + parent_class := gtk_type_class(gtk_drawing_area_get_type()); + g_return_if_fail(parent_class<>nil,'gtk_gl_area_class_init parent_class=nil'); + object_class := PGtkObjectClass(klass); + g_return_if_fail(object_class<>nil,'gtk_gl_area_class_init object_class=nil'); + + object_class^.destroy := @gtk_gl_area_destroy; +end; + +function gdk_gl_query: boolean; +var + errorb: Integer = 0; + event: Integer = 0; +begin + Result:=boolean(glXQueryExtension(GetDefaultXDisplay, errorb, event)); +end; + +function gdk_gl_choose_visual(attrlist: Plongint): PGdkVisual; +var + dpy: PDisplay; + vi: PXVisualInfo; + visual: PGdkVisual; +begin + {$IFDEF lclgtk2} + DebugLn(['gdk_gl_choose_visual not implemented yet for gtk2']); + RaiseGDBException(''); + {$ENDIF} + + if attrList=nil then begin + Result:=nil; + exit; + end; + + dpy := GetDefaultXDisplay; + vi := glXChooseVisual(dpy,DefaultScreen(dpy), attrlist); + if (vi=nil) then begin + Result:=nil; + exit; + end; + + visual := gdkx_visual_get(vi^.visualid); + XFree(vi); + Result:=visual; +end; + +function gdk_gl_get_config(visual: PGdkVisual; attrib: longint): longint; +var + dpy: PDisplay; + vi: PXVisualInfo; + value: integer; +begin + Result:=-1; + if visual=nil then exit; + + dpy := GetDefaultXDisplay; + + vi := get_xvisualinfo(visual); + + value:=0; + if (glXGetConfig(dpy, vi, attrib, value) = 0) then begin + XFree(vi); + Result:=value; + end else + XFree(vi); +end; + +function gdk_gl_context_new(visual: PGdkVisual; attrlist: PlongInt): PGdkGLContext; +begin + Result := gdk_gl_context_share_new(visual, nil, GLXTrue, attrlist); +end; + +function gdk_gl_context_share_new(visual: PGdkVisual; sharelist: PGdkGLContext; + direct: TGLBool; attrlist: plongint): PGdkGLContext; +var + dpy: PDisplay; + vi: PXVisualInfo; + PrivateShareList: PGdkGLContextPrivate; + PrivateContext: PGdkGLContextPrivate; + glxcontext: TGLXContext; + +begin + Result:=nil; + dpy := GetDefaultXDisplay; + + {$IFDEF lclgtk2} + if visual=nil then ; + vi:=glXChooseVisual(dpy, DefaultScreen(dpy), @attrList[0]); + {$ELSE} + if visual=nil then exit; + vi := get_xvisualinfo(visual); + {$ENDIF} + if vi=nil then + raise Exception.Create('gdk_gl_context_share_new no visual found'); + + PrivateShareList:=PGdkGLContextPrivate(sharelist); + + if (sharelist<>nil) then + glxcontext := glXCreateContext(dpy, vi, PrivateShareList^.glxcontext, + direct) + else + glxcontext := glXCreateContext(dpy, vi, nil, direct); + + XFree(vi); + if (glxcontext = nil) then exit; + + PrivateContext := g_new(SizeOf(TGdkGLContextPrivate), 1); + PrivateContext^.xdisplay := dpy; + PrivateContext^.glxcontext := glxcontext; + PrivateContext^.ref_count := 1; + + Result := PGdkGLContext(PrivateContext); +end; + +function gdk_gl_context_attrlist_share_new(attrlist: Plongint; + sharelist: PGdkGLContext; direct: TGLBool): PGdkGLContext; +var + visual: PGdkVisual; +begin + {$IFDEF lclgtk2} + visual :=nil; + Result := gdk_gl_context_share_new(visual, sharelist, direct, attrlist); + {$ELSE} + visual := gdk_gl_choose_visual(attrlist); + if (visual <> nil) then + Result := gdk_gl_context_share_new(visual, sharelist, direct, attrlist) + else + Result := nil; + {$ENDIF} +end; + +function gdk_gl_context_ref(context: PGdkGLContext): PGdkGLContext; +var + PrivateContext: PGdkGLContextPrivate; +begin + Result:=nil; + if context=nil then exit; + PrivateContext := PGdkGLContextPrivate(context); + inc(PrivateContext^.ref_count); + //DebugLn(['gdk_gl_context_ref ref_count=',PrivateContext^.ref_count]); + Result:=context; +end; + +function gdk_gl_context_unref(context: PGdkGLContext):PGdkGLContext; +var + PrivateContext: PGdkGLContextPrivate; +begin + Result:=context; + g_return_if_fail(context<>nil,''); + + PrivateContext:=PGdkGLContextPrivate(context); + + dec(PrivateContext^.ref_count); + if (PrivateContext^.ref_count = 0) then begin + //DebugLn(['gdk_gl_context_unref START ref_count=',PrivateContext^.ref_count]); + if (PrivateContext^.glxcontext = glXGetCurrentContext()) then + glXMakeCurrent(PrivateContext^.xdisplay, None, nil); + glXDestroyContext(PrivateContext^.xdisplay, PrivateContext^.glxcontext); + PrivateContext^.glxcontext:=nil; + g_free(PrivateContext); + //DebugLn(['gdk_gl_context_unref END']); + Result:=nil; + end; +end; + +function gdk_gl_make_current(drawable: PGdkDrawable; + context: PGdkGLContext): boolean; +var + PrivateContext: PGdkGLContextPrivate; +begin + Result:=false; + if drawable=nil then exit; + if context=nil then exit; + PrivateContext := PGdkGLContextPrivate(context); + + Result:=boolean(glXMakeCurrent(PrivateContext^.xdisplay, + {$IFDEF LCLGTK} + GDK_WINDOW_XWINDOW(PGdkWindowPrivate(drawable)), + {$ELSE} + GDK_WINDOW_XWINDOW(drawable), + {$ENDIF} + PrivateContext^.glxcontext) + ); +end; + +procedure gdk_gl_swap_buffers(drawable: PGdkDrawable); +begin + g_return_if_fail(drawable <> nil); + + glXSwapBuffers({$IFDEF LCLGTK} + GDK_WINDOW_XDISPLAY(PGdkWindowPrivate(drawable)), + GDK_WINDOW_XWINDOW(PGdkWindowPrivate(drawable)) + {$ELSE} + GDK_WINDOW_XDISPLAY(drawable), + GDK_WINDOW_XWINDOW(drawable) + {$ENDIF} + ); +end; + +procedure gdk_gl_wait_gdk; +begin + glXWaitX; +end; + +procedure gdk_gl_wait_gl; +begin + glXWaitGL; +end; + +procedure gtk_gl_area_init( + {$IFDEF LCLGTK} + gl_area, theClass: Pointer + {$ELSE} + gl_area: PGTypeInstance; theClass: gpointer + {$ENDIF} + ); cdecl; +begin + if theClass=nil then ; + //DebugLn(['gtk_gl_area_init START']); + PGtkGLArea(gl_area)^.glcontext:=nil; + {$IFDEF LclGtk2} + gtk_widget_set_double_buffered(PGtkWidget(gl_area),gdkFALSE); + GTK_WIDGET_UNSET_FLAGS(PGtkWidget(gl_area),GTK_NO_WINDOW); + {$ENDIF} + //DebugLn(['gtk_gl_area_init END']); +end; + +function GTK_TYPE_GL_AREA: TGtkType; +const + gl_area_type_name = 'GtkGLArea'; + gl_area_info: TGtkTypeInfo = ( + type_name: gl_area_type_name; + object_size: SizeOf(TGtkGLArea); + class_size: SizeOf(TGtkGLAreaClass); + class_init_func: @gtk_gl_area_class_init; + object_init_func: @gtk_gl_area_init; + reserved_1: nil; + reserved_2: nil; + base_class_init_func: nil; + ); +begin + if (gl_area_type=0) then begin + gl_area_type:=gtk_type_unique(gtk_drawing_area_get_type(),@gl_area_info); + end; + Result:=gl_area_type; +end; + +function GTK_GL_AREA(obj: Pointer): PGtkGLArea; +begin + g_return_if_fail(GTK_IS_GL_AREA(obj),''); + Result:=PGtkGLArea(obj); +end; + +function GTK_GL_AREA_CLASS(klass: Pointer): PGtkGLAreaClass; +begin + g_return_if_fail(GTK_IS_GL_AREA_CLASS(klass),''); + Result:=PGtkGLAreaClass(klass); +end; + +function GTK_IS_GL_AREA(obj: Pointer): Boolean; +begin + {$IFDEF LCLGTK} + Result := Assigned(obj) and GTK_IS_GL_AREA_CLASS(PGtkTypeObject(obj)^.klass); + {$ELSE} + GTK_IS_GL_AREA:=GTK_CHECK_TYPE(obj,GTK_TYPE_GL_AREA); + {$ENDIF} +end; + +function GTK_IS_GL_AREA_CLASS(klass: Pointer): Boolean; +begin + {$IFDEF LCLGTK} + Result := Assigned(klass) and (PGtkTypeClass(klass)^.thetype = GTK_TYPE_GL_AREA); + {$ELSE} + GTK_IS_GL_AREA_CLASS:=GTK_CHECK_CLASS_TYPE(klass,GTK_TYPE_GL_AREA); + {$ENDIF} +end; + +function gtk_gl_area_get_type: TGtkType; +begin + Result:=GTK_TYPE_GL_AREA; +end; + +function gtk_gl_area_new(Attribs: TContextAttribs): PGtkWidget; +begin + Result:=gtk_gl_area_share_new(Attribs, nil); +end; + +{$IFDEF VerboseMultiSampling} +procedure WriteFBConfigID(const Prefix: string; PrivateContext: PGdkGLContextPrivate); +var + ctxValue: longint; +begin + ctxValue:=0; + debugln([Prefix,' ContextAttrib: ', + glXQueryContext(PrivateContext^.xdisplay, PrivateContext^.glxcontext, GLX_FBCONFIG_ID, ctxValue), + '-',ctxValue]); +end; +{$ENDIF} + +function gtk_gl_area_share_new(Attribs: TContextAttribs; share: PGtkGLArea): PGtkWidget; +var + gl_area: PGtkGLArea; +begin + Result := nil; + //DebugLn(['gtk_gl_area_share_new START']); + if (share <> nil) and (not GTK_IS_GL_AREA(share)) then + exit; + gl_area:=gtk_gl_area_share_new_usefpglx(Attribs, share); + Result:=PGtkWidget(gl_area); +end; + +function CustomXErrorHandler({%H-}para1:XLib.PDisplay; para2:PXErrorEvent):cint;cdecl; +begin + if para2^.error_code=8 then begin + raise Exception.Create('A BadMatch X error occurred. Most likely the requested OpenGL version is invalid.'); + end; + Result:=0; +end; + +function gtk_gl_area_share_new_usefpglx(Attribs: TContextAttribs; share: PGtkGLArea): PGtkGLArea; +var + GLArea: PGtkGLArea; + ShareList: PGdkGLContext; + PrivateShareList: PGdkGLContextPrivate; + ColorMap: PGdkColormap; + Visual: PGdkVisual; + PrivateContext: PGdkGLContextPrivate; + XDisplay: PDisplay; + XVInfo: PXVisualInfo; + ScreenNum: gint; + FBConfig: TGLXFBConfig; + FBConfigs: PGLXFBConfig; + FBConfigsCount: Integer; + Samples: cint; + BestSamples: Integer; + BestFBConfig: Integer; + GLXContext: TGLXContext; + i: Integer; + { Used with glXCreateContextAttribsARB to select 3.X and above context } + Context3X: array [0..6] of Integer; + +begin + Result:=nil; + ShareList:=nil; + if share<>nil then ShareList:=share^.glcontext; + PrivateShareList:=PGdkGLContextPrivate(ShareList); + {$IFDEF LCLGTK} + XDisplay:=gdk_display; + ScreenNum:=gdk_screen; + {$ELSE} + XDisplay:=gdk_x11_get_default_xdisplay; + ScreenNum:=gdk_x11_get_default_screen; + {$ENDIF} + if GLX_version_1_3(XDisplay) then begin + { use approach recommended since glX 1.3 } + FBConfigsCount:=0; + FBConfigs:=glXChooseFBConfig(XDisplay, ScreenNum, @Attribs.AttributeList[0], FBConfigsCount); + if FBConfigsCount = 0 then + raise Exception.Create('Could not find FB config'); + + // if multisampling is requested try to get a number of sample buffers as + // close to the specified number as possible + if Attribs.MultiSampling>0 then begin + BestSamples:=0; + for i:=0 to FBConfigsCount-1 do begin + Samples:=0; + glXGetFBConfigAttrib(XDisplay, FBConfigs[i], GLX_SAMPLES_ARB, Samples); + if Samples=Attribs.MultiSampling then begin + BestFBConfig:=i; + break; + end else begin + if (Samples>BestSamples) and (Samples0) then begin + // install custom X error handler + XSetErrorHandler(@CustomXErrorHandler); + Context3X[0]:=GLX_CONTEXT_MAJOR_VERSION_ARB; + Context3X[1]:=Attribs.MajorVersion; + Context3X[2]:=GLX_CONTEXT_MINOR_VERSION_ARB; + Context3X[3]:=Attribs.MinorVersion; + Context3X[4]:=GLX_CONTEXT_FLAGS_ARB; + Context3X[5]:=Attribs.ContextFlags; + Context3X[6]:=None; + if (ShareList<>nil) then begin + GLXContext:=glXCreateContextAttribsARB(XDisplay, FBConfig, + PrivateShareList^.glxcontext, true, + Context3X); + end else begin + GLXContext:=glXCreateContextAttribsARB(XDisplay, FBConfig, Nil, true, + Context3X); + end; + // restore default error handler + XSetErrorHandler(nil); + end else begin + if (ShareList<>nil) then begin + GLXContext:=glXCreateNewContext(XDisplay, FBConfig, GLX_RGBA_TYPE, + PrivateShareList^.glxcontext, True) + end else begin + GLXContext:=glXCreateNewContext(XDisplay, FBConfig, GLX_RGBA_TYPE, Nil, + True); + end; + end; + if FBConfigs<>nil then + XFree(FBConfigs); + end else begin + if (ShareList<>nil) then + GLXContext:=glXCreateContext(XDisplay, XVInfo, PrivateShareList^.glxcontext, + GLXTrue) + else + GLXContext:=glXCreateContext(XDisplay, XVInfo, Nil, GLXTrue); + end; + + if GLXContext=nil then + raise Exception.Create('gdk_gl_context_share_new_usefpglx context creation failed'); + + {$IFNDEF LCLGTK} + ColorMap:=gdk_colormap_get_system; + Visual:=gdk_colormap_get_visual(ColorMap); + if XVisualIDFromVisual(GDK_VISUAL_XVISUAL(visual)) <> XVInfo^.visualid then begin + Visual:=gdkx_visual_get(XVInfo^.visualid); + ColorMap:=gdk_colormap_new(Visual, gFALSE); + end; + {$ENDIF} + + GLArea:=gtk_type_new(gtk_gl_area_get_type); + {$IFNDEF LCLGTK} + gtk_widget_set_colormap(PGtkWidget(@GLArea^.darea), ColorMap); + {$ENDIF} + + PrivateContext:=g_new(SizeOf(TGdkGLContextPrivate), 1); + PrivateContext^.xdisplay:=XDisplay; + PrivateContext^.glxcontext:=GLXContext; + PrivateContext^.ref_count:=1; + + GLArea^.glcontext:=PGdkGLContext(PrivateContext); + Result:=GLArea; +end; + +function gtk_gl_area_make_current(glarea: PGtkGLArea): boolean; +begin + Result:=false; + if glarea=nil then exit; + if not GTK_IS_GL_AREA(glarea) then exit; + if not GTK_WIDGET_REALIZED(PGtkWidget(glarea)) then exit; + + //DebugLn(['gtk_gl_area_make_current START']); + Result:=gdk_gl_make_current(PGtkWidget(glarea)^.window, glarea^.glcontext); + //DebugLn(['gtk_gl_area_make_current END']); + {$IFDEF VerboseMultiSampling} + //WriteFBConfigID('gtk_gl_area_make_current',PGdkGLContextPrivate(glarea^.glcontext)); + {$ENDIF} +end; + +function gtk_gl_area_begingl(glarea: PGtkGLArea): boolean; +begin + Result:=gtk_gl_area_make_current(glarea); +end; + +procedure gtk_gl_area_swap_buffers(gl_area: PGtkGLArea); +begin + g_return_if_fail(gl_area <> nil); + g_return_if_fail(GTK_IS_GL_AREA(gl_area)); + g_return_if_fail(GTK_WIDGET_REALIZED(PGtkWidget(gl_area))); + + gdk_gl_swap_buffers(GTK_WIDGET(gl_area)^.window); +end; + +procedure LOpenGLViewport(Handle: HWND; Left, Top, Width, Height: integer); +begin + glViewport(Left,Top,Width,Height); +end; + +procedure LOpenGLSwapBuffers(Handle: HWND); +begin + gtk_gl_area_swap_buffers({%H-}PGtkGLArea(Handle)); +end; + +function LOpenGLMakeCurrent(Handle: HWND): boolean; +var + Widget: PGtkWidget; + glarea: PGtkGLArea; +begin + if Handle=0 then + RaiseGDBException('LOpenGLSwapBuffers Handle=0'); + Result:=false; + + Widget:={%H-}PGtkWidget(PtrUInt(Handle)); + glarea:=PGtkGLArea(Widget); + if not GTK_IS_GL_AREA(glarea) then + RaiseGDBException('LOpenGLSwapBuffers not a PGtkGLArea'); + + // make sure the widget is realized + gtk_widget_realize(Widget); + if not GTK_WIDGET_REALIZED(Widget) then exit; + + // make current + Result:=gtk_gl_area_make_current(glarea); +end; + +function LOpenGLReleaseContext(Handle: HWND): boolean; +var pd:PDIsplay; +begin + Result := false; + pd := glXGetCurrentDisplay(); + if Assigned(pd) then + Result := glXMakeCurrent(pd, 0, nil); +end; + +{$IFDEF LCLGtk2} +function gtkglarea_size_allocateCB(Widget: PGtkWidget; Size: pGtkAllocation; + Data: gPointer): GBoolean; cdecl; +const + CallBackDefaultReturn = {$IFDEF GTK2}false{$ELSE}true{$ENDIF}; +var + SizeMsg: TLMSize; + GtkWidth, GtkHeight: integer; + LCLControl: TWinControl; +begin + Result := CallBackDefaultReturn; + if not GTK_WIDGET_REALIZED(Widget) then begin + // the widget is not yet realized, so this GTK resize was not a user change. + // => ignore + exit; + end; + if Size=nil then ; + LCLControl:=TWinControl(Data); + if LCLControl=nil then exit; + //DebugLn(['gtkglarea_size_allocateCB ',DbgSName(LCLControl)]); + + gtk_widget_get_size_request(Widget, @GtkWidth, @GtkHeight); + + SizeMsg.Msg:=0; + FillChar(SizeMsg,SizeOf(SizeMsg),0); + with SizeMsg do + begin + Result := 0; + Msg := LM_SIZE; + SizeType := Size_SourceIsInterface; + Width := SmallInt(GtkWidth); + Height := SmallInt(GtkHeight); + end; + //DebugLn(['gtkglarea_size_allocateCB ',GtkWidth,',',GtkHeight]); + LCLControl.WindowProc(TLMessage(SizeMsg)); +end; +{$ENDIF} + +function LOpenGLCreateContextCore(AWinControl: TWinControl; + WSPrivate: TWSPrivateClass; SharedControl: TWinControl; + DoubleBuffered, RGBA, DebugContext: boolean; + const RedBits, GreenBits, BlueBits, MajorVersion, MinorVersion, + MultiSampling, AlphaBits, DepthBits, StencilBits, AUXBuffers: Cardinal; + const AParams: TCreateParams): HWND; +var + NewWidget: PGtkWidget; + SharedArea: PGtkGLArea; + Attribs: TContextAttribs; +begin + if WSPrivate=nil then ; + {$IFDEF VerboseMultiSampling} + debugln(['LOpenGLCreateContextCore MultiSampling=',MultiSampling]); + {$ENDIF} + Attribs.AttributeList:=CreateOpenGLContextAttrList(DoubleBuffered,RGBA,RedBits,GreenBits, + BlueBits,AlphaBits,DepthBits,StencilBits,AUXBuffers); + Attribs.MajorVersion:=MajorVersion; + Attribs.MinorVersion:=MinorVersion; + + // fill in context flags + Attribs.ContextFlags:=0; + if DebugContext then + Attribs.ContextFlags:=Attribs.ContextFlags or GLX_CONTEXT_DEBUG_BIT_ARB; + + if MultiSampling>1 then begin + Attribs.MultiSampling:=MultiSampling; + end else begin + Attribs.MultiSampling:=0; + end; + try + if SharedControl<>nil then begin + SharedArea:={%H-}PGtkGLArea(PtrUInt(SharedControl.Handle)); + if not GTK_IS_GL_AREA(SharedArea) then + RaiseGDBException('LOpenGLCreateContext'); + NewWidget:=gtk_gl_area_share_new(Attribs,SharedArea); + end else begin + NewWidget:=gtk_gl_area_new(Attribs); + end; + Result:=HWND({%H-}PtrUInt(Pointer(NewWidget))); + PGtkobject(NewWidget)^.flags:=PGtkobject(NewWidget)^.flags or GTK_CAN_FOCUS; + {$IFDEF LCLGtk} + TGTKWidgetSet(WidgetSet).FinishCreateHandle(AWinControl,NewWidget,AParams); + {$ELSE} + TGTK2WidgetSet(WidgetSet).FinishCreateHandle(AWinControl,NewWidget,AParams); + g_signal_connect_after(PGtkObject(NewWidget), 'size-allocate', + TGTKSignalFunc(@gtkglarea_size_allocateCB), AWinControl); + {$ENDIF} + finally + FreeMem(Attribs.AttributeList); + end; +end; + +function LOpenGLCreateContext(AWinControl: TWinControl; + WSPrivate: TWSPrivateClass; SharedControl: TWinControl; + DoubleBuffered, RGBA, DebugContext: boolean; + const RedBits, GreenBits, BlueBits, MajorVersion, MinorVersion, + MultiSampling, AlphaBits, DepthBits, StencilBits, AUXBuffers: Cardinal; + const AParams: TCreateParams): HWND; +begin + {$IFDEF VerboseMultiSampling} + debugln(['LOpenGLCreateContext MultiSampling=',MultiSampling]); + {$ENDIF} + if (MultiSampling > 1) and + GLX_ARB_multisample(GetDefaultXDisplay, DefaultScreen(GetDefaultXDisplay)) + then begin + {$IFDEF VerboseMultiSampling} + debugln(['LOpenGLCreateContext GLX_ARB_multisample succeeded']); + {$ENDIF} + try + Result := LOpenGLCreateContextCore(AWinControl, WSPrivate, SharedControl, + DoubleBuffered, RGBA, DebugContext, RedBits, GreenBits, BlueBits, MajorVersion, + MinorVersion, MultiSampling, AlphaBits, DepthBits, StencilBits, + AUXBuffers, AParams); + except + {$IFDEF VerboseMultiSampling} + debugln(['LOpenGLCreateContext LOpenGLCreateContextCore failed, trying without multisampling']); + {$ENDIF} + { retry without MultiSampling } + Result := LOpenGLCreateContextCore(AWinControl, WSPrivate, SharedControl, + DoubleBuffered, RGBA, DebugContext, RedBits, GreenBits, BlueBits, MajorVersion, + MinorVersion, 1, AlphaBits, DepthBits, StencilBits, AUXBuffers, AParams); + end; + end else begin + { no multi-sampling requested (or GLX_ARB_multisample not available), + just pass to LOpenGLCreateContextCore } + Result := LOpenGLCreateContextCore(AWinControl, WSPrivate, SharedControl, + DoubleBuffered, RGBA, DebugContext, RedBits, GreenBits, BlueBits, MajorVersion, + MinorVersion, MultiSampling, AlphaBits, DepthBits, StencilBits, + AUXBuffers, AParams); + end; +end; + +procedure LOpenGLDestroyContextInfo(AWinControl: TWinControl); +begin + if not AWinControl.HandleAllocated then exit; + // nothing to do +end; + +function CreateOpenGLContextAttrList(DoubleBuffered: boolean; RGBA: boolean; + const RedBits, GreenBits, BlueBits, AlphaBits, DepthBits, StencilBits, + AUXBuffers: Cardinal): PInteger; +var + p: integer; + UseFBConfig: boolean; + + procedure Add(i: integer); + begin + if Result<>nil then + Result[p]:=i; + inc(p); + end; + + procedure CreateList; + begin + p:=0; + if UseFBConfig then begin + Add(GLX_X_RENDERABLE); Add(1); + Add(GLX_X_VISUAL_TYPE); Add(GLX_TRUE_COLOR); + end; + if DoubleBuffered then + begin + if UseFBConfig then + begin Add(GLX_DOUBLEBUFFER); Add(1); end else + Add(GLX_DOUBLEBUFFER); + end; + if RGBA then + begin + if not UseFBConfig then Add(GLX_RGBA); + { For UseFBConfig, glXChooseFBConfig already defaults to RGBA } + end; + Add(GLX_RED_SIZE); Add(RedBits); + Add(GLX_GREEN_SIZE); Add(GreenBits); + Add(GLX_BLUE_SIZE); Add(BlueBits); + if AlphaBits>0 then + begin + Add(GLX_ALPHA_SIZE); Add(AlphaBits); + end; + if DepthBits>0 then + begin + Add(GLX_DEPTH_SIZE); Add(DepthBits); + end; + if StencilBits>0 then + begin + Add(GLX_STENCIL_SIZE); Add(StencilBits); + end; + if AUXBuffers>0 then + begin + Add(GLX_AUX_BUFFERS); Add(AUXBuffers); + end; + + Add(0); { 0 = X.None (be careful: GLX_NONE is something different) } + end; + +begin + {$IFDEF VerboseMultiSampling} + debugln(['CreateOpenGLContextAttrList MultiSampling=',MultiSampling]); + {$ENDIF} + UseFBConfig := GLX_version_1_3(GetDefaultXDisplay); + Result:=nil; + CreateList; + GetMem(Result,SizeOf(integer)*p); + CreateList; +end; + +end. + diff --git a/glqtnativecontext.pas b/glqtnativecontext.pas new file mode 100644 index 0000000..921e5e2 --- /dev/null +++ b/glqtnativecontext.pas @@ -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. diff --git a/glwin32wglcontextex.pas b/glwin32wglcontextex.pas new file mode 100644 index 0000000..3aee8fc --- /dev/null +++ b/glwin32wglcontextex.pas @@ -0,0 +1,699 @@ +{ + ***************************************************************************** + See the file COPYING.modifiedLGPL.txt, included in this distribution, + for details about the license. + ***************************************************************************** + + Author: Mattias Gaertner + +} +unit GLWin32WGLContextEx; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, LMessages, Windows, LCLProc, LCLType, gl, Forms, Controls, + Win32Int, WSLCLClasses, WSControls, Win32WSControls, Win32Proc, LCLMessageGlue; + +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, DebugContext: boolean; + const RedBits, GreenBits, BlueBits, + MultiSampling, AlphaBits, DepthBits, StencilBits, AUXBuffers: Cardinal; + const AParams: TCreateParams): HWND; +procedure LOpenGLDestroyContextInfo(AWinControl: TWinControl); + +procedure InitWGL(RequireWGL_ARB_create_context : boolean); +procedure InitOpenGLContextGLWindowClass; + + +type + TWGLControlInfo = record + Window: HWND; + DC: HDC; + PixelFormat: GLUInt; + WGLContext: HGLRC; + end; + PWGLControlInfo = ^TWGLControlInfo; + +var + WGLControlInfoAtom: ATOM = 0; + +function AllocWGLControlInfo(Window: HWND): PWGLControlInfo; +function DisposeWGLControlInfo(Window: HWND): boolean; +function GetWGLControlInfo(Window: HWND): PWGLControlInfo; + + +const + WGL_SAMPLE_BUFFERS_ARB = $2041; + WGL_SAMPLES_ARB = $2042; + + // WGL_ARB_pixel_format + WGL_NUMBER_PIXEL_FORMATS_ARB = $2000; + WGL_DRAW_TO_WINDOW_ARB = $2001; + WGL_DRAW_TO_BITMAP_ARB = $2002; + WGL_ACCELERATION_ARB = $2003; + WGL_NEED_PALETTE_ARB = $2004; + WGL_NEED_SYSTEM_PALETTE_ARB = $2005; + WGL_SWAP_LAYER_BUFFERS_ARB = $2006; + WGL_SWAP_METHOD_ARB = $2007; + WGL_NUMBER_OVERLAYS_ARB = $2008; + WGL_NUMBER_UNDERLAYS_ARB = $2009; + WGL_TRANSPARENT_ARB = $200A; + WGL_TRANSPARENT_RED_VALUE_ARB = $2037; + WGL_TRANSPARENT_GREEN_VALUE_ARB = $2038; + WGL_TRANSPARENT_BLUE_VALUE_ARB = $2039; + WGL_TRANSPARENT_ALPHA_VALUE_ARB = $203A; + WGL_TRANSPARENT_INDEX_VALUE_ARB = $203B; + WGL_SHARE_DEPTH_ARB = $200C; + WGL_SHARE_STENCIL_ARB = $200D; + WGL_SHARE_ACCUM_ARB = $200E; + WGL_SUPPORT_GDI_ARB = $200F; + WGL_SUPPORT_OPENGL_ARB = $2010; + WGL_DOUBLE_BUFFER_ARB = $2011; + WGL_STEREO_ARB = $2012; + WGL_PIXEL_TYPE_ARB = $2013; + WGL_COLOR_BITS_ARB = $2014; + WGL_RED_BITS_ARB = $2015; + WGL_RED_SHIFT_ARB = $2016; + WGL_GREEN_BITS_ARB = $2017; + WGL_GREEN_SHIFT_ARB = $2018; + WGL_BLUE_BITS_ARB = $2019; + WGL_BLUE_SHIFT_ARB = $201A; + WGL_ALPHA_BITS_ARB = $201B; + WGL_ALPHA_SHIFT_ARB = $201C; + WGL_ACCUM_BITS_ARB = $201D; + WGL_ACCUM_RED_BITS_ARB = $201E; + WGL_ACCUM_GREEN_BITS_ARB = $201F; + WGL_ACCUM_BLUE_BITS_ARB = $2020; + WGL_ACCUM_ALPHA_BITS_ARB = $2021; + WGL_DEPTH_BITS_ARB = $2022; + WGL_STENCIL_BITS_ARB = $2023; + WGL_AUX_BUFFERS_ARB = $2024; + WGL_NO_ACCELERATION_ARB = $2025; + WGL_GENERIC_ACCELERATION_ARB = $2026; + WGL_FULL_ACCELERATION_ARB = $2027; + WGL_SWAP_EXCHANGE_ARB = $2028; + WGL_SWAP_COPY_ARB = $2029; + WGL_SWAP_UNDEFINED_ARB = $202A; + WGL_TYPE_RGBA_ARB = $202B; + WGL_TYPE_COLORINDEX_ARB = $202C; + + // WGL_NV_float_buffer + WGL_FLOAT_COMPONENTS_NV = $20B0; + WGL_BIND_TO_TEXTURE_RECTANGLE_FLOAT_R_NV = $20B1; + WGL_BIND_TO_TEXTURE_RECTANGLE_FLOAT_RG_NV = $20B2; + WGL_BIND_TO_TEXTURE_RECTANGLE_FLOAT_RGB_NV = $20B3; + WGL_BIND_TO_TEXTURE_RECTANGLE_FLOAT_RGBA_NV = $20B4; + WGL_TEXTURE_FLOAT_R_NV = $20B5; + WGL_TEXTURE_FLOAT_RG_NV = $20B6; + WGL_TEXTURE_FLOAT_RGB_NV = $20B7; + WGL_TEXTURE_FLOAT_RGBA_NV = $20B8; + + // WGL_ARB_pbuffer +type + HPBUFFERARB = Integer; + TGLenum = uint; + +const + WGL_DRAW_TO_PBUFFER_ARB = $202D; + WGL_MAX_PBUFFER_PIXELS_ARB = $202E; + WGL_MAX_PBUFFER_WIDTH_ARB = $202F; + WGL_MAX_PBUFFER_HEIGHT_ARB = $2030; + WGL_PBUFFER_LARGEST_ARB = $2033; + WGL_PBUFFER_WIDTH_ARB = $2034; + WGL_PBUFFER_HEIGHT_ARB = $2035; + WGL_PBUFFER_LOST_ARB = $2036; + + // WGL_ARB_buffer_region + WGL_FRONT_COLOR_BUFFER_BIT_ARB = $00000001; + WGL_BACK_COLOR_BUFFER_BIT_ARB = $00000002; + WGL_DEPTH_BUFFER_BIT_ARB = $00000004; + WGL_STENCIL_BUFFER_BIT_ARB = $00000008; + + WGL_CONTEXT_FLAGS_ARB = $2094; + WGL_CONTEXT_DEBUG_BIT_ARB = $0001; + +const + opengl32 = 'OpenGL32.dll'; + glu32 = 'GLU32.dll'; + +type + PWGLSwap = ^TWGLSwap; + _WGLSWAP = packed record + hdc: HDC; + uiFlags: UINT; + end; + TWGLSwap = _WGLSWAP; + WGLSWAP = _WGLSWAP; + + function wglGetProcAddress(ProcName: PChar): Pointer; stdcall; external opengl32; + function wglCopyContext(p1: HGLRC; p2: HGLRC; p3: Cardinal): BOOL; stdcall; external opengl32; + function wglCreateContext(DC: HDC): HGLRC; stdcall; external opengl32; + function wglCreateLayerContext(p1: HDC; p2: Integer): HGLRC; stdcall; external opengl32; + function wglDeleteContext(p1: HGLRC): BOOL; stdcall; external opengl32; + function wglDescribeLayerPlane(p1: HDC; p2, p3: Integer; p4: Cardinal; var p5: TLayerPlaneDescriptor): BOOL; stdcall; external opengl32; + function wglGetCurrentContext: HGLRC; stdcall; external opengl32; + function wglGetCurrentDC: HDC; stdcall; external opengl32; + function wglGetLayerPaletteEntries(p1: HDC; p2, p3, p4: Integer; var pcr): Integer; stdcall; external opengl32; + function wglMakeCurrent(DC: HDC; p2: HGLRC): BOOL; stdcall; external opengl32; + function wglRealizeLayerPalette(p1: HDC; p2: Integer; p3: BOOL): BOOL; stdcall; external opengl32; + function wglSetLayerPaletteEntries(p1: HDC; p2, p3, p4: Integer; var pcr): Integer; stdcall; external opengl32; + function wglShareLists(p1, p2: HGLRC): BOOL; stdcall; external opengl32; + function wglSwapLayerBuffers(p1: HDC; p2: Cardinal): BOOL; stdcall; external opengl32; + function wglUseFontBitmapsA(DC: HDC; p2, p3, p4: DWORD): BOOL; stdcall; external opengl32; + function wglUseFontOutlinesA (p1: HDC; p2, p3, p4: DWORD; p5, p6: Single; p7: Integer; p8: PGlyphMetricsFloat): BOOL; stdcall; external opengl32; + function wglUseFontBitmapsW(DC: HDC; p2, p3, p4: DWORD): BOOL; stdcall; external opengl32; + function wglUseFontOutlinesW (p1: HDC; p2, p3, p4: DWORD; p5, p6: Single; p7: Integer; p8: PGlyphMetricsFloat): BOOL; stdcall; external opengl32; + function wglUseFontBitmaps(DC: HDC; p2, p3, p4: DWORD): BOOL; stdcall; external opengl32 name 'wglUseFontBitmapsA'; + function wglUseFontOutlines(p1: HDC; p2, p3, p4: DWORD; p5, p6: Single; p7: Integer; p8: PGlyphMetricsFloat): BOOL; stdcall; external opengl32 name 'wglUseFontOutlinesA'; + +var + // WGL Extensions ---------------------------- + WGL_EXT_swap_control: boolean; + WGL_ARB_multisample: boolean; + WGL_ARB_extensions_string: boolean; + WGL_ARB_pixel_format: boolean; + WGL_ARB_pbuffer: boolean; + WGL_ARB_buffer_region: boolean; + WGL_ATI_pixel_format_float: boolean; + + + // ARB wgl extensions + wglCreateContextAttribsARB : function (DC: HDC; hShareContext:HGLRC; attribList:PInteger ):HGLRC;stdcall; + wglGetExtensionsStringARB: function(DC: HDC): PChar; stdcall; + wglGetPixelFormatAttribivARB: function(DC: HDC; iPixelFormat, iLayerPlane: Integer; nAttributes: TGLenum; + const piAttributes: PGLint; piValues : PGLint) : BOOL; stdcall; + wglGetPixelFormatAttribfvARB: function(DC: HDC; iPixelFormat, iLayerPlane: Integer; nAttributes: TGLenum; + const piAttributes: PGLint; piValues: PGLFloat) : BOOL; stdcall; + wglChoosePixelFormatARB: function(DC: HDC; const piAttribIList: PGLint; const pfAttribFList: PGLFloat; + nMaxFormats: GLint; piFormats: PGLint; nNumFormats: PGLenum) : BOOL; stdcall; + wglCreatePbufferARB: function(DC: HDC; iPixelFormat: Integer; iWidth, iHeight : Integer; + const piAttribList: PGLint) : HPBUFFERARB; stdcall; + wglGetPbufferDCARB: function(hPbuffer: HPBUFFERARB) : HDC; stdcall; + wglReleasePbufferDCARB: function(hPbuffer: HPBUFFERARB; DC: HDC) : Integer; stdcall; + wglDestroyPbufferARB: function(hPbuffer: HPBUFFERARB): BOOL; stdcall; + wglQueryPbufferARB: function(hPbuffer: HPBUFFERARB; iAttribute : Integer; + piValue: PGLint) : BOOL; stdcall; + + wglCreateBufferRegionARB: function(DC: HDC; iLayerPlane: Integer; uType: TGLenum) : Integer; stdcall; + wglDeleteBufferRegionARB: procedure(hRegion: Integer); stdcall; + wglSaveBufferRegionARB: function(hRegion: Integer; x, y, width, height: Integer): BOOL; stdcall; + wglRestoreBufferRegionARB: function(hRegion: Integer; x, y, width, height: Integer; + xSrc, ySrc: Integer): BOOL; stdcall; + + // non-ARB wgl extensions + wglSwapIntervalEXT: function(interval : Integer) : BOOL; stdcall; + wglGetSwapIntervalEXT: function : Integer; stdcall; + +var + WGLInitialized: boolean = false; + OpenGLContextWindowClassInitialized: boolean = false; + OpenGLContextWindowClass: WNDCLASS; + +const + DefaultOpenGLContextInitAttrList: array [0..0] of LongInt = ( + 0 + ); + +implementation +uses glext; + +function GLGetProcAddress(ProcName: PChar):Pointer; +begin + Result := wglGetProcAddress(ProcName); +end; + +procedure LOpenGLViewport(Handle: HWND; Left, Top, Width, Height: integer); +begin + glViewport(Left,Top,Width,Height); +end; + +procedure LOpenGLSwapBuffers(Handle: HWND); +var + Info: PWGLControlInfo; +begin + Info:=GetWGLControlInfo(Handle); + // don't use wglSwapLayerBuffers or wglSwapBuffers! + SwapBuffers(Info^.DC); +end; + +function LOpenGLMakeCurrent(Handle: HWND): boolean; +var + Info: PWGLControlInfo; +begin + Info:=GetWGLControlInfo(Handle); + Result:=wglMakeCurrent(Info^.DC,Info^.WGLContext); +end; + +function LOpenGLReleaseContext(Handle: HWND): boolean; +begin + Result:=wglMakeCurrent(0,0); +end; + +function GlWindowProc(Window: HWnd; Msg: UInt; WParam: Windows.WParam; + LParam: Windows.LParam): LResult; stdcall; +var + PaintMsg : TLMPaint; + winctrl : TWinControl; +begin + case Msg of + WM_ERASEBKGND: begin + Result:=0; + end; + WM_PAINT: begin + winctrl := GetWin32WindowInfo(Window)^.WinControl; + if Assigned(winctrl) then begin + FillChar(PaintMsg, SizeOf(PaintMsg), 0); + PaintMsg.Msg := LM_PAINT; + PaintMsg.DC := WParam; + DeliverMessage(winctrl, PaintMsg); + Result:=PaintMsg.Result; + end else + Result:=WindowProc(Window, Msg, WParam, LParam); + end; + else + Result:=WindowProc(Window, Msg, WParam, LParam); + end; +end; + +var + Temp_h_GLRc: HGLRC; + Temp_h_Dc: HDC; + Temp_h_Wnd: HWND; + +procedure LGlMsDestroyTemporaryWindow; forward; + +procedure LGlMsCreateTemporaryWindow; +var + PixelFormat: LongInt; + pfd: PIXELFORMATDESCRIPTOR; +begin + Temp_h_Wnd := 0; + Temp_h_Dc := 0; + Temp_h_GLRc := 0; + + try + { create Temp_H_wnd } + Temp_H_wnd := CreateWindowEx(WS_EX_APPWINDOW or WS_EX_WINDOWEDGE, + PChar('STATIC'), + PChar('temporary window for wgl'), + WS_OVERLAPPEDWINDOW or WS_CLIPSIBLINGS or WS_CLIPCHILDREN, + 0, 0, 100, 100, + 0 { no parent window }, 0 { no menu }, hInstance, + nil); + if Temp_H_wnd=0 then + raise Exception.Create('LGlMsCreateTemporaryWindow CreateWindowEx failed'); + + { create Temp_h_Dc } + Temp_h_Dc := GetDC(Temp_h_Wnd); + if Temp_h_Dc=0 then + raise Exception.Create('LGlMsCreateTemporaryWindow GetDC failed'); + + { create and set PixelFormat (must support OpenGL to be able to + later do wglCreateContext) } + FillChar(pfd, SizeOf(pfd), 0); + with pfd do + begin + nSize := SizeOf(pfd); + nVersion := 1; + dwFlags := PFD_DRAW_TO_WINDOW or PFD_SUPPORT_OPENGL or PFD_DOUBLEBUFFER; + iPixelType := PFD_TYPE_RGBA; + iLayerType := PFD_MAIN_PLANE; + end; + PixelFormat := ChoosePixelFormat(Temp_h_Dc, @pfd); + if PixelFormat = 0 then + raise Exception.Create('LGlMsCreateTemporaryWindow ChoosePixelFormat failed'); + + if not SetPixelFormat(Temp_h_Dc, PixelFormat, @pfd) then + raise Exception.Create('LGlMsCreateTemporaryWindow SetPixelFormat failed'); + + { create and make current Temp_h_GLRc } + Temp_h_GLRc := wglCreateContext(Temp_h_Dc); + if Temp_h_GLRc = 0 then + raise Exception.Create('LGlMsCreateTemporaryWindow wglCreateContext failed'); + + if not wglMakeCurrent(Temp_h_Dc, Temp_h_GLRc) then + raise Exception.Create('LGlMsCreateTemporaryWindow wglMakeCurrent failed'); + except + { make sure to finalize all partially initialized window parts } + LGlMsDestroyTemporaryWindow; + raise; + end; +end; + +procedure LGlMsDestroyTemporaryWindow; +begin + if Temp_h_GLRc <> 0 then + begin + wglMakeCurrent(Temp_h_Dc, 0); + wglDeleteContext(Temp_h_GLRc); + Temp_h_GLRc := 0; + end; + + if Temp_h_Dc <> 0 then + begin + ReleaseDC(Temp_h_Wnd, Temp_h_Dc); + Temp_h_Dc := 0; + end; + + if Temp_h_Wnd <> 0 then + begin + DestroyWindow(Temp_h_Wnd); + Temp_h_Wnd := 0; + end; +end; + +function LGlMsCreateOpenGLContextAttrList(DoubleBuffered: boolean; RGBA: boolean; + const RedBits, GreenBits, BlueBits, MultiSampling, AlphaBits, DepthBits, + StencilBits, AUXBuffers: Cardinal): PInteger; +var + p: integer; + + procedure Add(i: integer); + begin + if Result<>nil then + Result[p]:=i; + inc(p); + end; + + procedure CreateList; + begin + Add(WGL_DRAW_TO_WINDOW_ARB); Add(GL_TRUE); + Add(WGL_SUPPORT_OPENGL_ARB); Add(GL_TRUE); + Add(WGL_ACCELERATION_ARB); Add(WGL_FULL_ACCELERATION_ARB); + if DoubleBuffered then + begin Add(WGL_DOUBLE_BUFFER_ARB); Add(GL_TRUE); end; + Add(WGL_PIXEL_TYPE_ARB); + if RGBA then + Add(WGL_TYPE_RGBA_ARB) + else + Add(WGL_TYPE_COLORINDEX_ARB); + + Add(WGL_RED_BITS_ARB); Add(RedBits); + Add(WGL_GREEN_BITS_ARB); Add(GreenBits); + Add(WGL_BLUE_BITS_ARB); Add(BlueBits); + Add(WGL_COLOR_BITS_ARB); Add(RedBits+GreenBits+BlueBits); + Add(WGL_ALPHA_BITS_ARB); Add(AlphaBits); + Add(WGL_DEPTH_BITS_ARB); Add(DepthBits); + Add(WGL_STENCIL_BITS_ARB); Add(StencilBits); + Add(WGL_AUX_BUFFERS_ARB); Add(AUXBuffers); + if MultiSampling > 1 then + begin + Add(WGL_SAMPLE_BUFFERS_ARB); Add(1); + Add(WGL_SAMPLES_ARB); Add(MultiSampling); + end; + Add(0); Add(0); + end; + +begin + Result:=nil; + p:=0; + CreateList; + GetMem(Result,SizeOf(integer)*p); + p:=0; + CreateList; +end; + +function LOpenGLCreateContext(AWinControl: TWinControl; + WSPrivate: TWSPrivateClass; SharedControl: TWinControl; + DoubleBuffered, RGBA, DebugContext: boolean; + const RedBits, GreenBits, BlueBits, + MultiSampling, AlphaBits, DepthBits, StencilBits, AUXBuffers: Cardinal; + const AParams: TCreateParams): HWND; +var + Params: TCreateWindowExParams; + pfd: PIXELFORMATDESCRIPTOR; + Info, SharedInfo: PWGLControlInfo; + + ReturnedFormats: UINT; + VisualAttrList: PInteger; + VisualAttrFloat: array [0..1] of Single; + MsInitSuccess: WINBOOL; + FailReason : string; + attribList : array [0..2] of Integer; +begin + InitWGL( DebugContext ); + //InitOpenGLContextGLWindowClass; + + // general initialization of Params + PrepareCreateWindow(AWinControl, AParams, Params); + // customization of Params + with Params do begin + pClassName := @ClsName; + WindowTitle := StrCaption; + SubClassWndProc := @GlWindowProc; + end; + // create window + FinishCreateWindow(AWinControl, Params, false); + Result := Params.Window; + + // create info + Info:=AllocWGLControlInfo(Result); + + // create device context + Info^.DC := GetDC(Result); + if Info^.DC=0 then + raise Exception.Create('LOpenGLCreateContext GetDC failed'); + + // get pixelformat + FillChar(pfd,SizeOf(pfd),0); + with pfd do begin + nSize:=sizeOf(pfd); + nVersion:=1; + dwFlags:=PFD_DRAW_TO_WINDOW or PFD_SUPPORT_OPENGL; + if DoubleBuffered then + dwFlags:=dwFlags or PFD_DOUBLEBUFFER; + if RGBA then + iPixelType:=PFD_TYPE_RGBA + else + iPixelType:=PFD_TYPE_COLORINDEX; + cColorBits:=RedBits+GreenBits+BlueBits; // color depth + cRedBits:=RedBits; + cGreenBits:=GreenBits; + cBlueBits:=BlueBits; + cAlphaBits:=AlphaBits; + cDepthBits:=DepthBits; // Z-Buffer + cStencilBits:=StencilBits; + cAuxBuffers:=AUXBuffers; + iLayerType:=PFD_MAIN_PLANE; + end; + + MsInitSuccess := false; + if (MultiSampling > 1) and WGL_ARB_multisample and WGL_ARB_pixel_format + and Assigned(wglChoosePixelFormatARB) then + begin + VisualAttrList := LGlMsCreateOpenGLContextAttrList(DoubleBuffered, RGBA, + RedBits, GreenBits, BlueBits, MultiSampling, AlphaBits, DepthBits, + StencilBits, AUXBuffers); + try + FillChar(VisualAttrFloat, SizeOf(VisualAttrFloat), 0); + MsInitSuccess := wglChoosePixelFormatARB(Info^.DC, PGLint(VisualAttrList), + @VisualAttrFloat[0], 1, @Info^.PixelFormat, @ReturnedFormats); + finally FreeMem(VisualAttrList) end; + + if MsInitSuccess and (ReturnedFormats >= 1) then + SetPixelFormat(Info^.DC, Info^.PixelFormat, nil) + else + MsInitSuccess := false; + end; + + if not MsInitSuccess then + begin + Info^.PixelFormat:=ChoosePixelFormat(Info^.DC,@pfd); + if Info^.PixelFormat=0 then + raise Exception.Create('LOpenGLCreateContext ChoosePixelFormat failed'); + + // set pixel format in device context + if not SetPixelFormat(Info^.DC,Info^.PixelFormat,@pfd) then + raise Exception.Create('LOpenGLCreateContext SetPixelFormat failed'); + end; + + // create WGL context + Info^.WGLContext:=0; + if not DebugContext then + begin + Info^.WGLContext:=wglCreateContext(Info^.DC); + FailReason:='wglCreateContext failed'; + end + else if wglCreateContextAttribsARB = nil then + begin + FailReason:='wglCreateContextAttribsARB not supported'; + end + else + begin + // try to create debug context + attribList[0]:=WGL_CONTEXT_FLAGS_ARB; + attribList[1]:=WGL_CONTEXT_DEBUG_BIT_ARB; + attribList[2]:=0; + Info^.WGLContext:=wglCreateContextAttribsARB(Info^.DC, 0, @attribList); + FailReason:='wglCreateContextAttribsARB failed'; + end; + + if Info^.WGLContext=0 then + raise Exception.CreateFmt('LOpenGLCreateContext: %s', [FailReason]); + + // share context objects + if Assigned(SharedControl) then begin + SharedInfo:=GetWGLControlInfo(SharedControl.Handle); + if Assigned(SharedInfo) then wglShareLists(SharedInfo^.WGLContext, Info^.WGLContext); + end; +end; + +procedure LOpenGLDestroyContextInfo(AWinControl: TWinControl); +var + Info: PWGLControlInfo; +begin + if not AWinControl.HandleAllocated then exit; + Info:=GetWGLControlInfo(AWinControl.Handle); + if Info=nil then exit; + if wglMakeCurrent(Info^.DC,Info^.WGLContext) then begin + wglDeleteContext(Info^.WGLContext); + Info^.WGLContext:=0; + end; + if (Info^.DC<>0) then begin + ReleaseDC(Info^.Window,Info^.DC); + end; + DisposeWGLControlInfo(Info^.Window); +end; + +procedure InitWGL( RequireWGL_ARB_create_context : boolean ); +var + Buffer: string; + + // Checks if the given Extension string is in Buffer. + function CheckExtension(const extension : String) : Boolean; + begin + Result:=(Pos(extension, Buffer)>0); + end; + +begin + if WGLInitialized then exit; + WGLInitialized:=true; + + try + { to successfully use wglGetExtensionsStringARB (to query e.g. ARB_multisample, + needed for MultiSampling), you need to have OpenGL context + already initialized. We create a temporary window for this purpose. } + LGlMsCreateTemporaryWindow; + + if wglGetCurrentContext() = 0 then + raise Exception.Create('Context is not active'); + + // ARB wgl extensions + Pointer(wglCreateContextAttribsARB) := GLGetProcAddress('wglCreateContextAttribsARB'); + Pointer(wglGetExtensionsStringARB) := GLGetProcAddress('wglGetExtensionsStringARB'); + Pointer(wglGetPixelFormatAttribivARB) := GLGetProcAddress('wglGetPixelFormatAttribivARB'); + Pointer(wglGetPixelFormatAttribfvARB) := GLGetProcAddress('wglGetPixelFormatAttribfvARB'); + Pointer(wglChoosePixelFormatARB) := GLGetProcAddress('wglChoosePixelFormatARB'); + + Pointer(wglCreatePbufferARB) := GLGetProcAddress('wglCreatePbufferARB'); + Pointer(wglGetPbufferDCARB) := GLGetProcAddress('wglGetPbufferDCARB'); + Pointer(wglReleasePbufferDCARB) := GLGetProcAddress('wglReleasePbufferDCARB'); + Pointer(wglDestroyPbufferARB) := GLGetProcAddress('wglDestroyPbufferARB'); + Pointer(wglQueryPbufferARB) := GLGetProcAddress('wglQueryPbufferARB'); + + Pointer(wglCreateBufferRegionARB) := GLGetProcAddress('wglCreateBufferRegionARB'); + Pointer(wglDeleteBufferRegionARB) := GLGetProcAddress('wglDeleteBufferRegionARB'); + Pointer(wglSaveBufferRegionARB) := GLGetProcAddress('wglSaveBufferRegionARB'); + Pointer(wglRestoreBufferRegionARB) := GLGetProcAddress('wglRestoreBufferRegionARB'); + + // -EGG- ---------------------------- + Pointer(wglSwapIntervalEXT) := GLGetProcAddress('wglSwapIntervalEXT'); + Pointer(wglGetSwapIntervalEXT) := GLGetProcAddress('wglGetSwapIntervalEXT'); + + // ARB wgl extensions + if Assigned(wglGetExtensionsStringARB) then + begin + Buffer:=wglGetExtensionsStringARB(Temp_h_Dc); + { Writeln('WGL extensions supported: ', Buffer); } + end else + Buffer:=''; + WGL_ARB_multisample:=CheckExtension('WGL_ARB_multisample'); + WGL_EXT_swap_control:=CheckExtension('WGL_EXT_swap_control'); + WGL_ARB_buffer_region:=CheckExtension('WGL_ARB_buffer_region'); + WGL_ARB_extensions_string:=CheckExtension('WGL_ARB_extensions_string'); + WGL_ARB_pbuffer:=CheckExtension('WGL_ARB_pbuffer '); + WGL_ARB_pixel_format:=CheckExtension('WGL_ARB_pixel_format'); + WGL_ATI_pixel_format_float:=CheckExtension('WGL_ATI_pixel_format_float'); + except + on E: Exception do begin + DebugLn('InitWGL ',E.Message); + end; + end; + + try + if RequireWGL_ARB_create_context then + begin + if wglGetExtensionsStringARB = nil then + raise Exception.Create('InitWGL : wglGetExtensionsStringARB = nil'); + if not CheckExtension('WGL_ARB_create_context') then + begin + raise Exception.CreateFmt('InitWGL : WGL_ARB_create_context not found. Version %s Renderer=%s' + + sLineBreak + 'Extensions found:' + sLineBreak + '%s', + [String(glGetString(GL_VERSION)), String(glGetString(GL_RENDERER)), Buffer]); + end; + if wglCreateContextAttribsARB = nil then + raise Exception.Create('InitWGL : wglCreateContextAttribsARB = nil'); + end; + finally + LGlMsDestroyTemporaryWindow; + end; +end; + +procedure InitOpenGLContextGLWindowClass; +begin + if OpenGLContextWindowClassInitialized then exit; + OpenGLContextWindowClassInitialized:=true; + with OpenGLContextWindowClass do begin + style:=CS_HREDRAW or CS_VREDRAW or CS_OWNDC;// Redraw On Move, And Own DC For Window + lpfnWndProc := @WindowProc; // WndProc Handles Messages + cbClsExtra := 0; // No Extra Window Data + cbWndExtra := 0; // No Extra Window Data + hInstance := System.HInstance; // Set The Instance + hIcon := LoadIcon(NULL, IDI_WINLOGO);// Load The Default Icon + hCursor := LoadCursor(NULL, IDC_ARROW);// Load The Arrow Pointer + hbrBackground:= NULL; // No Background Required For GL + lpszMenuName := nil; // We Don't Want A Menu + lpszClassName:= 'LazOpenGLContext'; // Set The Class Name + end; + if RegisterClass(@OpenGLContextWindowClass)=0 then + raise Exception.Create('registering OpenGLContextWindowClass failed'); +end; + +function AllocWGLControlInfo(Window: HWND): PWGLControlInfo; +begin + New(Result); + FillChar(Result^, sizeof(Result^), 0); + Result^.Window := Window; + if WGLControlInfoAtom=0 then + WGLControlInfoAtom := Windows.GlobalAddAtom('WGLControlInfo'); + Windows.SetProp(Window, PChar(PtrUInt(WGLControlInfoAtom)), PtrUInt(Result)); +end; + +function DisposeWGLControlInfo(Window: HWND): boolean; +var + Info: PWGLControlInfo; +begin + Info := PWGLControlInfo(Windows.GetProp(Window, + PChar(PtrUInt(WGLControlInfoAtom)))); + Result := Windows.RemoveProp(Window, PChar(PtrUInt(WGLControlInfoAtom)))<>0; + if Result then begin + Dispose(Info); + end; +end; + +function GetWGLControlInfo(Window: HWND): PWGLControlInfo; +begin + Result:=PWGLControlInfo(Windows.GetProp(Window, + PChar(PtrUInt(WGLControlInfoAtom)))); +end; + +end. + diff --git a/lazopenglcontextex.lpk b/lazopenglcontextex.lpk new file mode 100644 index 0000000..6016bcb --- /dev/null +++ b/lazopenglcontextex.lpk @@ -0,0 +1,69 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/lazopenglcontextex.pas b/lazopenglcontextex.pas new file mode 100644 index 0000000..876b851 --- /dev/null +++ b/lazopenglcontextex.pas @@ -0,0 +1,22 @@ +{ This file was automatically created by Lazarus. Do not edit! + This source is only used to compile and install the package. + } + +unit LazOpenGLContextEx; + +{$warn 5023 off : no warning about unused units} +interface + +uses + OpenGLContextEx, LazarusPackageIntf; + +implementation + +procedure Register; +begin + RegisterUnit('OpenGLContextEx', @OpenGLContextEx.Register); +end; + +initialization + RegisterPackage('LazOpenGLContextEx', @Register); +end. diff --git a/openglcontextex.pas b/openglcontextex.pas new file mode 100644 index 0000000..cfaab01 --- /dev/null +++ b/openglcontextex.pas @@ -0,0 +1,748 @@ +{ + ***************************************************************************** + See the file COPYING.modifiedLGPL.txt, included in this distribution, + for details about the license. + ***************************************************************************** + + Author: Mattias Gaertner + + Abstract: + TOpenGLControl is a LCL control with an opengl context. + Fork of the stock LazOpenGLContext package where the Qt5/Qt6 backend + uses the widget's own QOpenGLWidget context (GLQtNativeContext) instead + of GLX, so it works on Wayland and with the Qt widgetset on Windows and + macOS as well. + Supported: gtk2/gtk3 (glx), win32 (wgl), cocoa, qt5/qt6 (QOpenGLWidget). +} +unit OpenGLContextEx; + +{$mode objfpc}{$H+} + +// choose the right backend depending on used LCL widgetset +{$IFDEF LCLGTK2} + {$IF defined(Linux) or defined(FreeBSD)} + {$DEFINE UseGtk2GLX} + {$DEFINE UsesModernGL} + {$DEFINE HasRGBA} + {$DEFINE HasRGBBits} + {$DEFINE HasDebugContext} + {$DEFINE OpenGLTargetDefined} + {$ENDIF} +{$ENDIF} +{$IFDEF LCLGTK3} + {$IF defined(Linux) or defined(FreeBSD)} + {$DEFINE UseGtk3GLX} + {$DEFINE UsesModernGL} + {$DEFINE HasRGBA} + {$DEFINE HasRGBBits} + {$DEFINE HasDebugContext} + {$DEFINE OpenGLTargetDefined} + {$ENDIF} +{$ENDIF} +{$IFDEF LCLCocoa} + {$DEFINE UseCocoaNS} + {$DEFINE UsesModernGL} + {$DEFINE OpenGLTargetDefined} + {$DEFINE HasMacRetinaMode} +{$ENDIF} +{$IFDEF LCLWin32} + {$DEFINE UseWin32WGL} + {$DEFINE HasRGBA} + {$DEFINE HasRGBBits} + {$DEFINE HasDebugContext} + {$DEFINE OpenGLTargetDefined} +{$ENDIF} +{$IF DEFINED(LCLQT5) OR DEFINED(LCLQt6)} + {$DEFINE UseQtNative} + {$DEFINE UsesModernGL} + {$DEFINE HasRGBA} + {$DEFINE HasRGBBits} + {$DEFINE OpenGLTargetDefined} +{$ENDIF} +{$IFNDEF OpenGLTargetDefined} + {$ERROR this LCL widgetset/OS is not yet supported} +{$ENDIF} + +interface + +uses + Classes, SysUtils, + // LCL + LCLType, LCLIntf, LResources, Forms, Controls, Graphics, LMessages, + WSLCLClasses, WSControls, +{$IFDEF UseGtk2GLX} + GLGtkGlxContextEx; +{$ENDIF} +{$IFDEF UseGtk3GLX} + GLGtk3GlxContextEx; +{$ENDIF} +{$IFDEF UseCocoaNS} + GLCocoaNSContextEx; +{$ENDIF} +{$IFDEF UseWin32WGL} + GLWin32WGLContextEx; +{$ENDIF} +{$IFDEF UseQtNative} + GLQtNativeContext; +{$ENDIF} + +const + DefaultDepthBits = 24; + +type + TOpenGlCtrlMakeCurrentEvent = procedure(Sender: TObject; + var Allow: boolean) of object; + + TOpenGLControlOption = (ocoMacRetinaMode, ocoRenderAtDesignTime); + TOpenGLControlOptions = set of TOpenGLControlOption; + + { TCustomOpenGLControl } + { Sharing: + You can share opengl contexts. For example: + Assume OpenGLControl2 and OpenGLControl3 should share the same as + OpenGLControl1. Then set + + OpenGLControl2.SharedControl:=OpenGLControl1; + OpenGLControl3.SharedControl:=OpenGLControl1; + + After this OpenGLControl1.SharingControlCount will be two and + OpenGLControl1.SharingControls will contain OpenGLControl2 and + OpenGLControl3. + } + + TCustomOpenGLControl = class(TWinControl) + private + FAutoResizeViewport: boolean; + FCanvas: TCanvas; // only valid at designtime + FDebugContext: boolean; + FFrameDiffTime: integer; + FOnMakeCurrent: TOpenGlCtrlMakeCurrentEvent; + FOnPaint: TNotifyEvent; + FCurrentFrameTime: integer; // in msec + FLastFrameTime: integer; // in msec + fOpenGLMajorVersion: Cardinal; + fOpenGLMinorVersion: Cardinal; + FRGBA: boolean; + {$IFDEF HasRGBBits} + FRedBits, FGreenBits, FBlueBits, + {$ENDIF} + FMultiSampling, FAlphaBits, FDepthBits, FStencilBits, FAUXBuffers: Cardinal; + FSharedOpenGLControl: TCustomOpenGLControl; + FSharingOpenGlControls: TList; + FOptions: TOpenGLControlOptions; + function GetSharingControls(Index: integer): TCustomOpenGLControl; + procedure SetAutoResizeViewport(const AValue: boolean); + procedure SetDebugContext(AValue: boolean); + procedure SetOpenGLMajorVersion(AValue: Cardinal); + procedure SetOpenGLMinorVersion(AValue: Cardinal); + procedure SetOptions(AValue: TOpenGLControlOptions); + procedure SetRGBA(const AValue: boolean); + {$IFDEF HasRGBBits} + procedure SetRedBits(const AValue: Cardinal); + procedure SetGreenBits(const AValue: Cardinal); + procedure SetBlueBits(const AValue: Cardinal); + {$ENDIF} + procedure SetMultiSampling(const AMultiSampling: Cardinal); + procedure SetAlphaBits(const AValue: Cardinal); + procedure SetDepthBits(const AValue: Cardinal); + procedure SetStencilBits(const AValue: Cardinal); + procedure SetAUXBuffers(const AValue: Cardinal); + procedure SetSharedControl(const AValue: TCustomOpenGLControl); + function IsOpenGLRenderAllowed: boolean; + protected + class procedure WSRegisterClass; override; + procedure WMPaint(var Message: TLMPaint); message LM_PAINT; + procedure WMSize(var Message: TLMSize); message LM_SIZE; + procedure DestroyWnd; override; + procedure UpdateFrameTimeDiff; + procedure OpenGLAttributesChanged; + procedure CMDoubleBufferedChanged(var Message: TLMessage); message CM_DOUBLEBUFFEREDCHANGED; + public + constructor Create(TheOwner: TComponent); override; + destructor Destroy; override; + Procedure Paint; virtual; + procedure RealizeBounds; override; + procedure DoOnPaint; virtual; + procedure SwapBuffers; virtual; + function MakeCurrent(SaveOldToStack: boolean = false): boolean; virtual; + function ReleaseContext: boolean; virtual; + function RestoreOldOpenGLControl: boolean; + function SharingControlCount: integer; + property SharingControls[Index: integer]: TCustomOpenGLControl read GetSharingControls; + procedure Invalidate; override; + procedure EraseBackground(DC: HDC); override; + public + property FrameDiffTimeInMSecs: integer read FFrameDiffTime; + property OnMakeCurrent: TOpenGlCtrlMakeCurrentEvent read FOnMakeCurrent + write FOnMakeCurrent; + property OnPaint: TNotifyEvent read FOnPaint write FOnPaint; + property SharedControl: TCustomOpenGLControl read FSharedOpenGLControl + write SetSharedControl; + property AutoResizeViewport: boolean read FAutoResizeViewport + write SetAutoResizeViewport default false; + property DoubleBuffered stored True default True; + property ParentDoubleBuffered default False; + property DebugContext: boolean read FDebugContext write SetDebugContext default false; // create context with debugging enabled. Requires OpenGLMajorVersion! + property RGBA: boolean read FRGBA write SetRGBA default true; + {$IFDEF HasRGBBits} + property RedBits: Cardinal read FRedBits write SetRedBits default 8; + property GreenBits: Cardinal read FGreenBits write SetGreenBits default 8; + property BlueBits: Cardinal read FBlueBits write SetBlueBits default 8; + {$ENDIF} + property OpenGLMajorVersion: Cardinal read fOpenGLMajorVersion write SetOpenGLMajorVersion default 0; + property OpenGLMinorVersion: Cardinal read fOpenGLMinorVersion write SetOpenGLMinorVersion default 0; + { Number of samples per pixel, for OpenGL multi-sampling (anti-aliasing). + + Value <= 1 means that we use 1 sample per pixel, which means no anti-aliasing. + Higher values mean anti-aliasing. Exactly which values are supported + depends on GPU, common modern GPUs support values like 2 and 4. + + If this is > 1, and we will not be able to create OpenGL + with multi-sampling, we will fallback to normal non-multi-sampled context. + You can query OpenGL values GL_SAMPLE_BUFFERS_ARB and GL_SAMPLES_ARB + (see ARB_multisample extension) to see how many samples have been + actually allocated for your context. } + property MultiSampling: Cardinal read FMultiSampling write SetMultiSampling default 1; + + property AlphaBits: Cardinal read FAlphaBits write SetAlphaBits default 0; + property DepthBits: Cardinal read FDepthBits write SetDepthBits default DefaultDepthBits; + property StencilBits: Cardinal read FStencilBits write SetStencilBits default 0; + property AUXBuffers: Cardinal read FAUXBuffers write SetAUXBuffers default 0; + property Options: TOpenGLControlOptions read FOptions write SetOptions; + end; + + { TOpenGLControl } + + TOpenGLControl = class(TCustomOpenGLControl) + published + property Align; + property Anchors; + property AutoResizeViewport; + property BorderSpacing; + property Enabled; + {$IFDEF HasRGBBits} + property RedBits; + property GreenBits; + property BlueBits; + {$ENDIF} + property OpenGLMajorVersion; + property OpenGLMinorVersion; + property MultiSampling; + property AlphaBits; + property DepthBits; + property StencilBits; + property AUXBuffers; + property OnChangeBounds; + property OnClick; + property OnConstrainedResize; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMakeCurrent; + property OnMouseDown; + property OnMouseEnter; + property OnMouseLeave; + property OnMouseMove; + property OnMouseUp; + property OnMouseWheel; + property OnMouseWheelDown; + property OnMouseWheelUp; + property OnPaint; + property OnResize; + property OnShowHint; + property PopupMenu; + property ShowHint; + property Visible; + end; + + { TWSOpenGLControl } + + TWSOpenGLControl = class(TWSWinControl) + published + class function CreateHandle(const AWinControl: TWinControl; + const AParams: TCreateParams): HWND; override; + class procedure DestroyHandle(const AWinControl: TWinControl); override; + class function GetDoubleBuffered(const AWinControl: TWinControl): Boolean; override; + end; + + + +procedure Register; + + +implementation + +{$R openglcontextex.res} + +var + OpenGLControlStack: TList = nil; + +procedure Register; +begin + RegisterComponents('OpenGL',[TOpenGLControl]); +end; + +{ TCustomOpenGLControl } + +function TCustomOpenGLControl.GetSharingControls(Index: integer + ): TCustomOpenGLControl; +begin + Result:=TCustomOpenGLControl(FSharingOpenGlControls[Index]); +end; + +procedure TCustomOpenGLControl.SetAutoResizeViewport(const AValue: boolean); +begin + if FAutoResizeViewport=AValue then exit; + FAutoResizeViewport:=AValue; + if AutoResizeViewport + and ([csLoading,csDestroying]*ComponentState=[]) + and IsVisible and HandleAllocated + and MakeCurrent then + LOpenGLViewport(Handle,0,0,Width,Height); +end; + +procedure TCustomOpenGLControl.SetDebugContext(AValue: boolean); +begin + if FDebugContext=AValue then Exit; + FDebugContext:=AValue; + OpenGLAttributesChanged; +end; + +procedure TCustomOpenGLControl.CMDoubleBufferedChanged(var Message: TLMessage); +begin + inherited; + OpenGLAttributesChanged; +end; + +procedure TCustomOpenGLControl.SetOpenGLMajorVersion(AValue: Cardinal); +begin + if fOpenGLMajorVersion=AValue then Exit; + fOpenGLMajorVersion:=AValue; +end; + +procedure TCustomOpenGLControl.SetOpenGLMinorVersion(AValue: Cardinal); +begin + if fOpenGLMinorVersion=AValue then Exit; + fOpenGLMinorVersion:=AValue; +end; + +procedure TCustomOpenGLControl.SetOptions(AValue: TOpenGLControlOptions); +var + RemovedRenderAtDesignTime: boolean; +begin + if FOptions=AValue then Exit; + + RemovedRenderAtDesignTime:= + (ocoRenderAtDesignTime in FOptions) and + (not (ocoRenderAtDesignTime in AValue)); + + FOptions:=AValue; + + { if you remove the flag ocoRenderAtDesignTime at design-time, + we need to destroy the handle. The call to OpenGLAttributesChanged + would not do this, so do it explicitly by calling ReCreateWnd + (ReCreateWnd will destroy handle, and not create new one, + since IsOpenGLRenderAllowed = false). } + if (csDesigning in ComponentState) and + RemovedRenderAtDesignTime and + HandleAllocated then + ReCreateWnd(Self); + + OpenGLAttributesChanged(); +end; + +procedure TCustomOpenGLControl.SetRGBA(const AValue: boolean); +begin + if FRGBA=AValue then exit; + FRGBA:=AValue; + OpenGLAttributesChanged; +end; + +{$IFDEF HasRGBBits} +procedure TCustomOpenGLControl.SetRedBits(const AValue: Cardinal); +begin + if FRedBits=AValue then exit; + FRedBits:=AValue; + OpenGLAttributesChanged; +end; + +procedure TCustomOpenGLControl.SetGreenBits(const AValue: Cardinal); +begin + if FGreenBits=AValue then exit; + FGreenBits:=AValue; + OpenGLAttributesChanged; +end; + +procedure TCustomOpenGLControl.SetBlueBits(const AValue: Cardinal); +begin + if FBlueBits=AValue then exit; + FBlueBits:=AValue; + OpenGLAttributesChanged; +end; +{$ENDIF} + +procedure TCustomOpenGLControl.SetMultiSampling(const AMultiSampling: Cardinal); +begin + if FMultiSampling=AMultiSampling then exit; + FMultiSampling:=AMultiSampling; + OpenGLAttributesChanged; +end; + +procedure TCustomOpenGLControl.SetAlphaBits(const AValue: Cardinal); +begin + if FAlphaBits=AValue then exit; + FAlphaBits:=AValue; + OpenGLAttributesChanged; +end; + +procedure TCustomOpenGLControl.SetDepthBits(const AValue: Cardinal); +begin + if FDepthBits=AValue then exit; + FDepthBits:=AValue; + OpenGLAttributesChanged; +end; + +procedure TCustomOpenGLControl.SetStencilBits(const AValue: Cardinal); +begin + if FStencilBits=AValue then exit; + FStencilBits:=AValue; + OpenGLAttributesChanged; +end; + +procedure TCustomOpenGLControl.SetAUXBuffers(const AValue: Cardinal); +begin + if FAUXBuffers=AValue then exit; + FAUXBuffers:=AValue; + OpenGLAttributesChanged; +end; + +procedure TCustomOpenGLControl.SetSharedControl( + const AValue: TCustomOpenGLControl); +begin + if FSharedOpenGLControl=AValue then exit; + if AValue=Self then + Raise Exception.Create('A control can not be shared by itself.'); + // unshare old + if (AValue<>nil) and (AValue.SharedControl<>nil) then + Raise Exception.Create('Target control is sharing too. A sharing control can not be shared.'); + if FSharedOpenGLControl<>nil then + FSharedOpenGLControl.FSharingOpenGlControls.Remove(Self); + // share new + if (AValue<>nil) and (csDestroying in AValue.ComponentState) then + FSharedOpenGLControl:=nil + else begin + FSharedOpenGLControl:=AValue; + if (FSharedOpenGLControl<>nil) then begin + if FSharedOpenGLControl.FSharingOpenGlControls=nil then + FSharedOpenGLControl.FSharingOpenGlControls:=TList.Create; + FSharedOpenGLControl.FSharingOpenGlControls.Add(Self); + end; + end; + // recreate handle if needed + if HandleAllocated and IsOpenGLRenderAllowed then + ReCreateWnd(Self); +end; + +{ OpenGL rendering allowed, because not in design-mode or because we + should render even in design-mode. } +function TCustomOpenGLControl.IsOpenGLRenderAllowed: boolean; +begin + Result := (not (csDesigning in ComponentState)) or + (ocoRenderAtDesignTime in Options); +end; + +class procedure TCustomOpenGLControl.WSRegisterClass; +const + Registered : Boolean = False; +begin + if Registered then + Exit; + inherited WSRegisterClass; + RegisterWSComponent(TCustomOpenGLControl,TWSOpenGLControl); + Registered := True; +end; + +procedure TCustomOpenGLControl.WMPaint(var Message: TLMPaint); +begin + Include(FControlState, csCustomPaint); + inherited WMPaint(Message); + //debugln('TCustomGTKGLAreaControl.WMPaint A ',dbgsName(Self),' ',dbgsName(FCanvas)); + if (not IsOpenGLRenderAllowed) and (FCanvas<>nil) then begin + with FCanvas do begin + if Message.DC <> 0 then + Handle := Message.DC; + Brush.Color:=clLtGray; + Pen.Color:=clRed; + Rectangle(0,0,Self.Width,Self.Height); + MoveTo(0,0); + LineTo(Self.Width,Self.Height); + MoveTo(0,Self.Height); + LineTo(Self.Width,0); + if Message.DC <> 0 then + Handle := 0; + end; + end else begin + Paint; + end; + Exclude(FControlState, csCustomPaint); +end; + +procedure TCustomOpenGLControl.WMSize(var Message: TLMSize); +begin + if (Message.SizeType and Size_SourceIsInterface)>0 then + DoOnResize; +end; + +procedure TCustomOpenGLControl.DestroyWnd; +begin + inherited DestroyWnd; + + if FCanvas <> nil then + TControlCanvas(FCanvas).FreeHandle; +end; + +procedure TCustomOpenGLControl.UpdateFrameTimeDiff; +begin + FCurrentFrameTime:=integer(GetTickCount); + if FLastFrameTime=0 then + FLastFrameTime:=FCurrentFrameTime; + // calculate time since last call: + FFrameDiffTime:=FCurrentFrameTime-FLastFrameTime; + // if the counter is reset restart: + if (FFrameDiffTime<0) then FFrameDiffTime:=1; + FLastFrameTime:=FCurrentFrameTime; +end; + +procedure TCustomOpenGLControl.OpenGLAttributesChanged; +begin + if HandleAllocated and + ( ([csLoading,csDestroying]*ComponentState=[]) and IsOpenGLRenderAllowed ) then + RecreateWnd(Self); +end; + +procedure TCustomOpenGLControl.EraseBackground(DC: HDC); +begin + if DC=0 then ; + // everything is painted, so erasing the background is not needed +end; + +constructor TCustomOpenGLControl.Create(TheOwner: TComponent); +begin + inherited Create(TheOwner); + ParentDoubleBuffered:=False; + FDoubleBuffered:=true; + FRGBA:=true; + {$IFDEF HasRGBBits} + FRedBits:=8; + FGreenBits:=8; + FBlueBits:=8; + {$ENDIF} + fOpenGLMajorVersion:=0; + fOpenGLMinorVersion:=0; + FMultiSampling:=1; + FDepthBits:=DefaultDepthBits; + ControlStyle:=ControlStyle-[csSetCaption]; + if not IsOpenGLRenderAllowed then begin + FCanvas := TControlCanvas.Create; + TControlCanvas(FCanvas).Control := Self; + end else + FCompStyle:=csNonLCL; + SetInitialBounds(0, 0, 160, 90); +end; + +destructor TCustomOpenGLControl.Destroy; +begin + if FSharingOpenGlControls<>nil then begin + while SharingControlCount>0 do + SharingControls[SharingControlCount-1].SharedControl:=nil; + FreeAndNil(FSharingOpenGlControls); + end; + SharedControl:=nil; + if OpenGLControlStack<>nil then begin + OpenGLControlStack.Remove(Self); + if OpenGLControlStack.Count=0 then + FreeAndNil(OpenGLControlStack); + end; + FCanvas.Free; + FCanvas:=nil; + inherited Destroy; +end; + +procedure TCustomOpenGLControl.Paint; +begin + if IsVisible and HandleAllocated then begin + UpdateFrameTimeDiff; + if IsOpenGLRenderAllowed and ([csDestroying]*ComponentState=[]) then begin + if AutoResizeViewport then begin + if not MakeCurrent then exit; + LOpenGLViewport(Handle,0,0,Width,Height); + end; + end; + //LOpenGLClip(Handle); + DoOnPaint; + end; +end; + +procedure TCustomOpenGLControl.RealizeBounds; +begin + if IsVisible and HandleAllocated + and IsOpenGLRenderAllowed + and ([csDestroying]*ComponentState=[]) + and AutoResizeViewport then begin + if MakeCurrent then + LOpenGLViewport(Handle,0,0,Width,Height); + end; + inherited RealizeBounds; +end; + +procedure TCustomOpenGLControl.DoOnPaint; +begin + if Assigned(OnPaint) then begin + if not MakeCurrent then exit; + OnPaint(Self); + end; +end; + +procedure TCustomOpenGLControl.SwapBuffers; +begin + LOpenGLSwapBuffers(Handle); +end; + +function TCustomOpenGLControl.MakeCurrent(SaveOldToStack: boolean): boolean; +var + Allowed: Boolean; +begin + if not IsOpenGLRenderAllowed then exit(false); + if Assigned(FOnMakeCurrent) then begin + Allowed:=true; + OnMakeCurrent(Self,Allowed); + if not Allowed then begin + Result:=False; + exit; + end; + end; + // make current + Result:=LOpenGLMakeCurrent(Handle); + if Result and SaveOldToStack then begin + // on success push on stack + if OpenGLControlStack=nil then + OpenGLControlStack:=TList.Create; + OpenGLControlStack.Add(Self); + end; +end; + +function TCustomOpenGLControl.ReleaseContext: boolean; +begin + Result:=false; + if not HandleAllocated then exit; + Result:=LOpenGLReleaseContext(Handle); +end; + +function TCustomOpenGLControl.RestoreOldOpenGLControl: boolean; +var + RestoredControl: TCustomOpenGLControl; +begin + Result:=false; + // check if the current context is on stack + if (OpenGLControlStack=nil) or (OpenGLControlStack.Count=0) then exit; + // pop + OpenGLControlStack.Delete(OpenGLControlStack.Count-1); + // make old control the current control + if OpenGLControlStack.Count>0 then begin + RestoredControl:= + TCustomOpenGLControl(OpenGLControlStack[OpenGLControlStack.Count-1]); + if (not LOpenGLMakeCurrent(RestoredControl.Handle)) then + exit; + end else begin + FreeAndNil(OpenGLControlStack); + end; + Result:=true; +end; + +function TCustomOpenGLControl.SharingControlCount: integer; +begin + if FSharingOpenGlControls=nil then + Result:=0 + else + Result:=FSharingOpenGlControls.Count; +end; + +procedure TCustomOpenGLControl.Invalidate; +begin + if csCustomPaint in FControlState then exit; + inherited Invalidate; +end; + +{ TWSOpenGLControl } + +class function TWSOpenGLControl.CreateHandle(const AWinControl: TWinControl; + const AParams: TCreateParams): HWND; +var + OpenGlControl: TCustomOpenGLControl; + AttrControl: TCustomOpenGLControl; +begin + OpenGlControl:=AWinControl as TCustomOpenGLControl; + if not OpenGlControl.IsOpenGLRenderAllowed then + begin + // do not use "inherited CreateHandle", because the LCL changes the hierarchy at run time + Result:=TWSWinControlClass(ClassParent).CreateHandle(AWinControl,AParams); + end + else + begin + if OpenGlControl.SharedControl<>nil then + AttrControl:=OpenGlControl.SharedControl + else + AttrControl:=OpenGlControl; + Result:=LOpenGLCreateContext(OpenGlControl,WSPrivate, + OpenGlControl.SharedControl, + AttrControl.DoubleBuffered, + {$IFDEF HasMacRetinaMode} + ocoMacRetinaMode in OpenGlControl.Options, + {$ENDIF} + {$IFDEF HasRGBA} + AttrControl.RGBA, + {$ENDIF} + {$IFDEF HasDebugContext} + AttrControl.DebugContext, + {$ENDIF} + {$IFDEF HasRGBBits} + AttrControl.RedBits, + AttrControl.GreenBits, + AttrControl.BlueBits, + {$ENDIF} + {$IFDEF UsesModernGL} + AttrControl.OpenGLMajorVersion, + AttrControl.OpenGLMinorVersion, + {$ENDIF} + AttrControl.MultiSampling, + AttrControl.AlphaBits, + AttrControl.DepthBits, + AttrControl.StencilBits, + AttrControl.AUXBuffers, + AParams); + end; +end; + +class procedure TWSOpenGLControl.DestroyHandle(const AWinControl: TWinControl); +begin + LOpenGLDestroyContextInfo(AWinControl); + // do not use "inherited DestroyHandle", because the LCL changes the hierarchy at run time + TWSWinControlClass(ClassParent).DestroyHandle(AWinControl); +end; + +class function TWSOpenGLControl.GetDoubleBuffered(const AWinControl: TWinControl): Boolean; +begin + Result := False; + if AWinControl=nil then ; +end; +{~bk +initialization + RegisterWSComponent(TCustomOpenGLControl,TWSOpenGLControl); +} + +end. diff --git a/openglcontextex.res b/openglcontextex.res new file mode 100644 index 0000000..3eae7fe Binary files /dev/null and b/openglcontextex.res differ