From ac46e3d13a54682f38ee3780a29a2fff51730ae4 Mon Sep 17 00:00:00 2001 From: Vladimir Date: Fri, 3 Jul 2026 15:00:26 +0300 Subject: [PATCH] =?UTF-8?q?LazOpenGLContextEx:=20TOpenGLControl=20=D1=81?= =?UTF-8?q?=20Qt-=D0=B1=D1=8D=D0=BA=D0=B5=D0=BD=D0=B4=D0=BE=D0=BC=20=D0=BD?= =?UTF-8?q?=D0=B0=20QOpenGLWidget?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Форк штатного пакета 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 --- .gitignore | 11 + README.md | 110 +++++ csrc/Makefile | 144 ++++++ csrc/build-msvc.bat | 43 ++ csrc/qlclglwidget.cpp | 124 +++++ glcocoanscontextex.pas | 539 +++++++++++++++++++++ glgtk3glxcontextex.pas | 143 ++++++ glgtkglxcontextex.pas | 1018 +++++++++++++++++++++++++++++++++++++++ glqtnativecontext.pas | 371 ++++++++++++++ glwin32wglcontextex.pas | 699 +++++++++++++++++++++++++++ lazopenglcontextex.lpk | 69 +++ lazopenglcontextex.pas | 22 + openglcontextex.pas | 748 ++++++++++++++++++++++++++++ openglcontextex.res | Bin 0 -> 3891 bytes 14 files changed, 4041 insertions(+) create mode 100644 .gitignore create mode 100644 README.md create mode 100644 csrc/Makefile create mode 100644 csrc/build-msvc.bat create mode 100644 csrc/qlclglwidget.cpp create mode 100644 glcocoanscontextex.pas create mode 100644 glgtk3glxcontextex.pas create mode 100644 glgtkglxcontextex.pas create mode 100644 glqtnativecontext.pas create mode 100644 glwin32wglcontextex.pas create mode 100644 lazopenglcontextex.lpk create mode 100644 lazopenglcontextex.pas create mode 100644 openglcontextex.pas create mode 100644 openglcontextex.res 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 0000000000000000000000000000000000000000..3eae7fef5c0c16feaa416ab34619520963f5a174 GIT binary patch literal 3891 zcmb`JXHZk!*2fQ_7Xj%~1S3sUnuIQ)gep=aRY>T)cMu4@JxB8Y$#0Tlru zAfWUjQly3&dVAyZ&OCGPr+Yu#HM92G>pyGHnKN_#zkL7z0QiV`aq<62-2PkKBLx6O zqH=LT1Hb`&zyMGO^Z-pj7f>U1dPL2LSatt7!^rs07DzJC)4W8(NkddFX=}lZh?V0{ zQc)1s*`T|J#6sq$stu~GL}E|vt!3^90Q4Pyk|g6MJr_~D;;(MzZ|vphA7ta} z00adEiMn{Y`PtccJBWJuI=$FXC@#u9bvOzwZnWV)+tz0QKs$w-G3mju^P_ zUWXS1KiDFziL+QPFvI;-*y)_Fm0v_6GZ@>A8iWOT>Qq+V7QC)oRBr&bGD}pIAn_`E48b`L_s+l0x;=Y7BMSENcSl zy(~sTi=wWkE3y<64OxGL`4pEcA9#KNi@|T7v+wNw5FB4pKD)j+sXQ?Y&8Pl~t0u>0 z0=?uh6q?37eJkddY!jF_X~QX79;*Bl_b(_Jn9b@>d()p4XFr(J!4+R0>^|fQ?lKOu zJBT*=P+Gictc@_m&PdxK1e*yjcDEa7ftr~PjgWvCYf3JN6T(^KQI^(5@|vEfULd46 z%HJQ!w{X!T1B{ZQDyNHQB*#r1e5U<}6uzcrx)oB?@9jfE-}ps~UY@`YtQIurUXptj z6R+BxaBs87wg&9Y!v}cx2ax3NI95Q$YwRqzm1pX%WuN8O9xbb_>IYZX%Guq#!Z(u9 zkncW?ehM|wtZ;~r2MVT>AhJB5&hDBeABw8yl3cvy%?-d01op$b}J?kg9)Z9>F`7xT>lIiYsB?l8=tbgIiT#P*;Ps6UjFvu-jYub6c zZf#QMypIgGXRvX<5@ANLQhLY1)oa~)SQ09`gFj8oZRmpCtUko-kTLY{B9f?`9HZrR z(Tq3Apb4tyT5mr%yca1Lm)Fs>wpw%8%qqQXM{awqFgF|Xajgg^svyOJZT1em*xwfV za=`tKZ-aCx5S%u};ABDk@BwXgJy?}0G8$+k0{|FN_)k7W01^NM5dU-b@AwaX#&dMMN)+qS@v%`2bxco(Dt`Kk3A~KiQDb~ z6~nKi%15>m^o^JB1;{im`r-{a18tAV>o@Lug3KA3XcnS;EWGl#*%#jh#J(Jp8t!;;bzb|GwD0@lFVGJ-^?=)Mm(5AJ5zl2$n&xHM+QUx@X_fB|zD?Sp zv+w?iXkVVE9vHFyP^b_Sej8Qtj_%W`r2|Qx;%{>R*4k&!=D>zZ-ltdM5@tW4IJfpM z2cv~R_Cq9JYOf{<$h@-L3q3|Rs-<-h3RXcXEwvFre0F_e)-fi8(!Ufx1p(3VhOB^$ zMIf$HG?Mk5SAn>i^0qyKeZ?253wogzaJ#ol5}}9NgdMVCAitiEOmnRr=p_)o&_20y zB`@Ff0eq5)wXoApPv($zs%%T(4UpfIxoFnPZxwdSn*>XGh}xVk>t6jRzhKk0Vxk`J zfzFpt&%GF>q(TH^GgS)QcKb&(KcJ?1x=YP4@QdvAurZ8d4)zXl5hIG$#FCpwk_y3ZayK;t9>PPYk1f zZ48gpO*$Lr_w8@eJM5{Jt-*?gh~_v|+}gTQOXE~HfXNdj?Ri7qEmGBIbw%?A z0V`j1p9)Pcv~A4@`59?Ev+TXq(a-I^Q^Q{|=BASe)9-#J?&@wd?@|==`q(2 zWNl0?78w3RuYc$V0Gh;qhX0O#l0^Fb*Zli4DE>G9OhHEp|4aUncl_a>a}*vMPUIhF zLhb<_kFb;l(maMl-3}RKgO=cW8zI&y=C4BTDC|KAaT9O$Y%)}f9qN2h$jg|4H3Uy{ zkWbM27df;sxq&$$y`oVNH)(fetGb(cUtP&=QQ-(Vqfp19cb{?DS#zVjyZl0T4rUHc z`!_!vjwbCjqV4{)= z>N9?oMsv!<0p)x~?h8kjqg^&VO5~PV%?vE2g`(X}t_J}7e)=#DGNj>Y8W$+O!_&r-4^f+sjEnUB2&sc(5DJzPi**SKbYvLO$- zm!XuqdM~gj5^;;eAFUOfn1RPTXhO@ex8o<_5CERE^IGs!4@ccetHU=?j~9doqIAE0 zp8>#PW>g1NrDsT~_}!Y%OLx7|r-v-h_b&yy)xJ}_g+;i#*ZF{Tuk^fw<>Y=|r8LFCEjE(3MP!TNT~o8ttw z*w1!CFJHDe|K+y7?))$!(VZg3gXbQ69CYYw!M<-M!9b|0I?}ItEYLR@;rQ3ltAg*6 zBKjtUJxfd$jP!^hQ$%E^)3i_3FGs*`Ed5^Xo7QtWM$7RT>r5pXa8!F!s(IO*i#0sw zBJy+&(YAr(#j(~_1gz93EJ%;wDPLNB6d z(wZ>NYJEDeALS%yFTaVFnyDYtX3b7xi_>*_OM*OW+p%b*aMbK^71xhdG2evMlldO0 zH%AV)Cx4q^bLAiYoHlC^x>M9!dSdGz`0Webcx_;uX`V>irdi#by^;$1Q|UC;6-8*+ z(UpCgthJ}R8qx&aMno9xWtPu`bleKg1~M?@gXZuXek?MbE}i3oVxtsl7*Mh8GOYNzzFqr(d+tP7=kWd}g^0e?Tw? zCIE@pm2e!W+kjB%gN&oBYT}zL%U(3-2c?`C_6#y7ulN2STnUOiu)9fbpTipp8jNq6 z=2v(i>NuMQ-IUdviD0&3o~Y7d{%YgFS%xoZSt>iZrfS-wn76b~?vPQUaR*)J=u=;h z>n1(8_QbO7;jPKdwz;@pZkUGzsUOni!)vH){sxT8aa3Z-)KxdCGYVzce7mK!`mJ1h zx22bZ0%H?C4dA=Mw|_s5w8%j0RaG7ZwZev`mRe*zDK5|osdluLPton2&LQiV*&E$8 zFX`X;kMOyZv~2jRBGnXgf>-tX&${|Y;n&EdHG1W;&0OQASF|M$;)@`@*T;mnJ}Wi} zvD6=Xf1bW{(0UTUsb@Uh65h0TX{K0Y)Xa1>?1gK>aq1Eot8*dK>*8#&_X- literal 0 HcmV?d00001