mirror of
https://git.vladimir.cc/vladimir/lazopenglcontextex.git
synced 2026-08-25 17:37:31 +00:00
LazOpenGLContextEx: TOpenGLControl с Qt-бэкендом на QOpenGLWidget
Форк штатного пакета LazOpenGLContext (Lazarus components/opengl). Qt5/Qt6-бэкенд (glqtnativecontext.pas) использует собственный контекст настоящего QOpenGLWidget вместо ручного GLX на winId(): EGL на Wayland, GLX на X11, WGL/CGL на Windows/macOS под ws=qt6. QOpenGLWidget-наследник с paintGL-хуком живёт в маленькой C++-либе csrc/qlclglwidget.cpp (QLCLOpenGLWidget из libQt6Pas — не QOpenGLWidget, а голый QWidget под внешний GLX). Сборка: csrc/Makefile (linux/macos/windows-кросс mingw-w64/windows-native MSYS2, install, install-app) + build-msvc.bat для MSVC-Qt. Либа грузится в рантайме рядом с бинарником приложения. Бэкенды gtk2/gtk3/win32/cocoa скопированы из стока без изменений (юниты переименованы с суффиксом Ex). Детали и нюансы — в README.md. Проверено: EWSDR, спектр/водопад через GL в нативном Wayland (KDE, qt6), живой эфир QO-100. Co-Authored-By: Claude Fable 5 <noreply@anthropic.com>
This commit is contained in:
+11
@@ -0,0 +1,11 @@
|
||||
# Lazarus package output
|
||||
lib/
|
||||
backup/
|
||||
*.compiled
|
||||
|
||||
# built helper library artifacts
|
||||
*.so
|
||||
*.dylib
|
||||
*.dll
|
||||
*.dll.a
|
||||
csrc/*.obj
|
||||
@@ -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-заголовками).
|
||||
+144
@@ -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
|
||||
@@ -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
|
||||
@@ -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 <QOpenGLWidget>
|
||||
#include <QOpenGLContext>
|
||||
#include <QOpenGLFunctions>
|
||||
#include <QSurfaceFormat>
|
||||
|
||||
// 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"
|
||||
@@ -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.
|
||||
|
||||
@@ -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.
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -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.
|
||||
@@ -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.
|
||||
|
||||
@@ -0,0 +1,69 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<Package Version="4">
|
||||
<Name Value="LazOpenGLContextEx"/>
|
||||
<Type Value="RunAndDesignTime"/>
|
||||
<AddToProjectUsesSection Value="True"/>
|
||||
<Author Value="Mattias Gaertner (original), Vladimir (Qt native backend)"/>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<SearchPaths>
|
||||
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)/$(LCLWidgetType)"/>
|
||||
</SearchPaths>
|
||||
<Conditionals Value="if LCLWidgetType='cocoa' then begin
|
||||
UsageLinkerOptions := ' -framework OpenGL'
|
||||
+' ''-dylib_file'' ''/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib:/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib''';
|
||||
end;"/>
|
||||
</CompilerOptions>
|
||||
<Description Value="Cross-platform OpenGL control. Fork of LazOpenGLContext with a Qt5/Qt6 backend on top of QOpenGLWidget: works on Wayland and with the Qt widgetset on Windows/macOS."/>
|
||||
<License Value="modified LGPL-2"/>
|
||||
<Version Release="1"/>
|
||||
<Files Count="6">
|
||||
<Item1>
|
||||
<Filename Value="openglcontextex.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="OpenGLContextEx"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Filename Value="glgtkglxcontextex.pas"/>
|
||||
<AddToUsesPkgSection Value="False"/>
|
||||
<UnitName Value="GLGtkGlxContextEx"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<Filename Value="glgtk3glxcontextex.pas"/>
|
||||
<AddToUsesPkgSection Value="False"/>
|
||||
<UnitName Value="GLGtk3GlxContextEx"/>
|
||||
</Item3>
|
||||
<Item4>
|
||||
<Filename Value="glwin32wglcontextex.pas"/>
|
||||
<AddToUsesPkgSection Value="False"/>
|
||||
<UnitName Value="GLWin32WGLContextEx"/>
|
||||
</Item4>
|
||||
<Item5>
|
||||
<Filename Value="glcocoanscontextex.pas"/>
|
||||
<AddToUsesPkgSection Value="False"/>
|
||||
<UnitName Value="GLCocoaNSContextEx"/>
|
||||
</Item5>
|
||||
<Item6>
|
||||
<Filename Value="glqtnativecontext.pas"/>
|
||||
<AddToUsesPkgSection Value="False"/>
|
||||
<UnitName Value="GLQtNativeContext"/>
|
||||
</Item6>
|
||||
</Files>
|
||||
<RequiredPkgs Count="2">
|
||||
<Item1>
|
||||
<PackageName Value="FCL"/>
|
||||
<MinVersion Major="1" Valid="True"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<PackageName Value="LCL"/>
|
||||
</Item2>
|
||||
</RequiredPkgs>
|
||||
<UsageOptions>
|
||||
<UnitPath Value="$(PkgOutDir)"/>
|
||||
</UsageOptions>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
</PublishOptions>
|
||||
</Package>
|
||||
</CONFIG>
|
||||
@@ -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.
|
||||
@@ -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.
|
||||
Binary file not shown.
Reference in New Issue
Block a user