uglcContext.pas

   1 unit uglcContext;
   2
   3 { Package:      OpenGLCore
   4   Prefix:       glc - OpenGL Core
   5   Beschreibung: diese Unit enthält eine abstrakte Klassen-Kapselung für OpenGL Kontexte
   6
   7
   8 Abstrakte Contextklasse zum Erstellen von Renderkontexten auf Windows & Linux(bzw X11/Gtk2)
   9 Für aktuelle Plattform passende Klasse kann per GetPlatformClass gefunden werden.
  10
  11 Bsp.:
  12   //muss im GUI/Main-Thread aufgerufen werden:
  13   pf := TglcContext.GetPlatformClass().MakePF();
  14   fContext := TglcContext.GetPlatformClass().Create(MyTWinControl, PF);
  15
  16   //_kann_ in Background Thread abgerufen werden:
  17   fContext.BuildContext();
  18   [Arbeit mit dem Context]
  19   fContext.CloseContext();
  20
  21   //im MainThread
  22   FreeAndNil(fContext)
  23
  24
  25 weitere Funktionen:
  26   MakePF()             erzeugt PixelFormatDescriptor mit Defaults
  27   BuildContext()       baut Kontext (kann in BackgrounThread aufgerufen werden)
  28   CloseContext()       gibt den Kontext frei (muss im selben Thread aufgerufen werden wie BuildContext;
  29                        wird der Kontext nur im MainThread genutzt, muss CloseContext nicht explizit aufgerufen
  30                        werden und wird beim zerstören des Kontext-Objekts ausgeführt)
  31   Activate/Deactiveate Kontext aktiv schalten oder nicht
  32   SwapBuffers          DoubleBuffering
  33   SetSwapInterval      VSync
  34   Share                ShareLists
  35   EnableDebugOutput    GL-Debug via ARB_debug_output oder AMD_debug_output de/aktivieren
  36 }
  37
  38 interface
  39
  40 uses
  41   SysUtils, Controls, dglOpenGL;
  42
  43 const
  44   GLC_CONTEXT_VERSION_UNKNOWN = -1;
  45
  46 type
  47 {$IFNDEF fpc}
  48   TThreadID = Cardinal;
  49 {$ENDIF}
  50
  51   TMultiSample = 1..high(byte);
  52   TglcContextPixelFormatSettings = packed record
  53     DoubleBuffered: boolean;
  54     Stereo: boolean;
  55     MultiSampling: TMultiSample;
  56     ColorBits: Integer;
  57     DepthBits: Integer;
  58     StencilBits: Integer;
  59     AccumBits: Integer;
  60     AuxBuffers: Integer;
  61     Layer: Integer;
  62   end;
  63   TglcContextVersionSettings = packed record
  64     Major: Integer;
  65     Minor: Integer;
  66     ForwardCompatible: Boolean;
  67   end;
  68   TSeverity = (svLow, svMedium, svHigh);
  69   TLogEvent = procedure(const aSender: TObject; const aSeverity: TSeverity; const aMsg: String) of Object;
  70
  71   TglcDisplayFlag = (
  72     dfFullscreen);
  73   TglcDisplayFlags = set of TglcDisplayFlag;
  74
  75   EGLError = class(Exception);
  76
  77   { TglcContext }
  78   TglcContextClass = class of TglcContext;
  79   TglcContext = class
  80   private
  81     fControl: TWinControl;
  82     fThreadID: TThreadID;
  83     fEnableVsync: Boolean;
  84     fLogEvent: TLogEvent;
  85
  86     function GetEnableVSync: Boolean;
  87     procedure SetEnableVSync(aValue: Boolean);
  88     procedure LogMsg(const aSeverity: TSeverity; const aMsg: String);
  89     procedure SetDebugMode(const aEnable: Boolean);
  90   protected
  91     fUseVersion: Boolean;
  92     fPixelFormatSettings: TglcContextPixelFormatSettings;
  93     fVersionSettings: TglcContextVersionSettings;
  94     procedure OpenContext; virtual;
  95
  96   public
  97     property PixelFormatSettings: TglcContextPixelFormatSettings read fPixelFormatSettings;
  98     property VersionSettings:     TglcContextVersionSettings     read fVersionSettings;
  99
 100     constructor Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings); overload; virtual;
 101     constructor Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings; const aVersionSettings: TglcContextVersionSettings); overload; virtual;
 102     destructor Destroy; override;
 103
 104     property ThreadID:    TThreadID read fThreadID;
 105     property EnableVSync: Boolean   read GetEnableVSync write SetEnableVSync;
 106
 107     procedure BuildContext;
 108     procedure EnableDebugOutput(const aLogEvent: TLogEvent);
 109     procedure DisableDebugOutput;
 110     procedure CloseContext; virtual;
 111     procedure Activate; virtual; abstract;
 112     procedure Deactivate; virtual; abstract;
 113     function IsActive: boolean; virtual; abstract;
 114     procedure SwapBuffers; virtual; abstract;
 115     procedure SetSwapInterval(const aInterval: GLint); virtual; abstract;
 116     function GetSwapInterval: GLint; virtual; abstract;
 117     procedure Share(const aContext: TglcContext); virtual; abstract;
 118 {$IFDEF fpc}
 119   private class var
 120     fMainContextThreadID: TThreadID;
 121   public
 122     class property MainContextThreadID: TThreadID read fMainContextThreadID;
 123 {$ENDIF}
 124   public
 125     class function MakePF(DoubleBuffered: boolean = true;
 126                           Stereo: boolean=false;
 127                           MultiSampling: TMultiSample=1;
 128                           ColorBits: Integer=32;
 129                           DepthBits: Integer=24;
 130                           StencilBits: Integer=0;
 131                           AccumBits: Integer=0;
 132                           AuxBuffers: Integer=0;
 133                           Layer: Integer=0): TglcContextPixelFormatSettings;
 134     class function MakeVersion(const aMajor, aMinor: Integer; const aForwardCompatible: Boolean): TglcContextVersionSettings;
 135     class function GetPlatformClass: TglcContextClass;
 136     class function ChangeDisplaySettings(const aWidth, aHeight,
 137       aBitPerPixel, aFreq: Integer; const aFlags: TglcDisplayFlags): Boolean; virtual; abstract;
 138     class function IsAnyContextActive: boolean; virtual;
 139   end;
 140
 141 implementation
 142
 143 uses
 144   {$IFDEF WINDOWS}
 145     uglcContextWGL
 146   {$ELSE}{$IFDEF WIN32}
 147     uglcContextWGL{$IFNDEF fpc}, Windows{$ENDIF}
 148   {$ENDIF}{$ENDIF}
 149
 150   {$IFDEF LINUX}
 151     uglcContextGtk2GLX
 152   {$ENDIF}
 153   ;
 154
 155 {$IFNDEF fpc}
 156 var
 157   fMainContextThreadID: TThreadID;
 158 {$ENDIF}
 159
 160 procedure GlDebugCallbackARB(source: GLenum; type_: GLenum; id: GLuint; severity: GLenum; {%H-}length: GLsizei; const message_: PGLchar; {%H-}userParam: PGLvoid); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF}
 161 var
 162   src, typ: String;
 163   sv: TSeverity;
 164 begin
 165   case source of
 166     GL_DEBUG_SOURCE_API_ARB            : src:= 'API';
 167     GL_DEBUG_SOURCE_WINDOW_SYSTEM_ARB  : src:= 'WINDOW';
 168     GL_DEBUG_SOURCE_SHADER_COMPILER_ARB: src:= 'SHADER';
 169     GL_DEBUG_SOURCE_THIRD_PARTY_ARB    : src:= '3RDPARTY';
 170     GL_DEBUG_SOURCE_APPLICATION_ARB    : src:= 'APPLICATION';
 171     GL_DEBUG_SOURCE_OTHER_ARB          : src:= 'OTHER';
 172   end;
 173   src:= 'GL_' + src;
 174
 175   case type_ of
 176     GL_DEBUG_TYPE_ERROR_ARB               : typ:= 'ERROR';
 177     GL_DEBUG_TYPE_DEPRECATED_BEHAVIOR_ARB : typ:= 'DEPRECATED';
 178     GL_DEBUG_TYPE_UNDEFINED_BEHAVIOR_ARB  : typ:= 'UNDEF BEHAV';
 179     GL_DEBUG_TYPE_PORTABILITY_ARB         : typ:= 'PORTABILITY';
 180     GL_DEBUG_TYPE_PERFORMANCE_ARB         : typ:= 'PERFORMANCE';
 181     GL_DEBUG_TYPE_OTHER_ARB               : typ:= 'OTHER';
 182   end;
 183
 184   case severity of
 185     GL_DEBUG_SEVERITY_LOW_ARB:    sv := svLow;
 186     GL_DEBUG_SEVERITY_MEDIUM_ARB: sv := svMedium;
 187     GL_DEBUG_SEVERITY_HIGH_ARB:   sv := svHigh;
 188   end;
 189
 190   TglcContext(userParam).LogMsg(sv, format('%s [%d] %s',[typ, id, message_]));
 191 end;
 192
 193 procedure GlDebugCallbackAMD(id: GLuint; category: GLenum; severity: GLenum; {%H-}length: GLsizei; const message_: PGLchar; {%H-}userParam: PGLvoid); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF}
 194 var
 195   src: String;
 196   sv: TSeverity;
 197 begin
 198   case category of
 199     GL_DEBUG_CATEGORY_API_ERROR_AMD            : src:= 'API';
 200     GL_DEBUG_CATEGORY_WINDOW_SYSTEM_AMD        : src:= 'WINDOW';
 201     GL_DEBUG_CATEGORY_DEPRECATION_AMD          : src:= 'SHADER';
 202     GL_DEBUG_CATEGORY_UNDEFINED_BEHAVIOR_AMD   : src:= 'UNDEF BEHAV';
 203     GL_DEBUG_CATEGORY_PERFORMANCE_AMD          : src:= 'PERFORMANCE';
 204     GL_DEBUG_CATEGORY_SHADER_COMPILER_AMD      : src:= 'SHADER';
 205     GL_DEBUG_CATEGORY_APPLICATION_AMD          : src:= 'APPLICATION';
 206     GL_DEBUG_CATEGORY_OTHER_AMD                : src:= 'OTHER';
 207   end;
 208   src:= 'GL_' + src;
 209
 210   case severity of
 211     GL_DEBUG_SEVERITY_LOW_AMD:    sv := svLow;
 212     GL_DEBUG_SEVERITY_MEDIUM_AMD: sv := svMedium;
 213     GL_DEBUG_SEVERITY_HIGH_AMD:   sv := svHigh;
 214   end;
 215
 216   TglcContext(userParam).LogMsg(sv, format('[%d] %s',[id, message_]));
 217 end;
 218
 219 function TglcContext.GetEnableVSync: Boolean;
 220 begin
 221   result := fEnableVsync;
 222 end;
 223
 224 procedure TglcContext.SetEnableVSync(aValue: Boolean);
 225 begin
 226   fEnableVsync := aValue;
 227   if IsActive then begin
 228     if fEnableVsync then
 229       SetSwapInterval(1)
 230     else
 231       SetSwapInterval(0);
 232   end;
 233 end;
 234
 235 procedure TglcContext.LogMsg(const aSeverity: TSeverity; const aMsg: String);
 236 begin
 237   if Assigned(fLogEvent) then
 238     fLogEvent(self, aSeverity, aMsg);
 239 end;
 240
 241 procedure TglcContext.SetDebugMode(const aEnable: Boolean);
 242 begin
 243   // ARB Debug Output
 244   if GL_ARB_debug_output then begin
 245     glDebugMessageCallbackARB(@GlDebugCallbackARB, self);
 246     glDebugMessageControlARB(GL_DONT_CARE, GL_DONT_CARE, GL_DONT_CARE, 0, nil, aEnable);
 247     if aEnable then begin
 248       glEnable(GL_DEBUG_OUTPUT_SYNCHRONOUS_ARB);
 249       glDebugMessageInsertARB(GL_DEBUG_SOURCE_APPLICATION_ARB, GL_DEBUG_TYPE_OTHER_ARB, 0, GL_DEBUG_SEVERITY_LOW_ARB, -1, PGLchar('Attached ARB_debug_output'));
 250     end;
 251
 252   // AMD Debug Output
 253   end else if GL_AMD_debug_output then begin
 254     glDebugMessageCallbackAMD(@GlDebugCallbackAMD, self);
 255     glDebugMessageEnableAMD(GL_DONT_CARE, GL_DONT_CARE, 0, nil, aEnable);
 256     if aEnable then
 257       glDebugMessageInsertAMD(GL_DEBUG_CATEGORY_OTHER_AMD, GL_DEBUG_SEVERITY_LOW_ARB, 0, -1, PGLchar('Attached ARB_debug_output'));
 258   end;
 259 end;
 260
 261 procedure TglcContext.OpenContext;
 262 begin
 263   fThreadID := GetCurrentThreadId;
 264   if fMainContextThreadID = 0 then
 265     fMainContextThreadID := fThreadID;
 266 end;
 267
 268 class function TglcContext.MakePF(DoubleBuffered: boolean; Stereo: boolean; MultiSampling: TMultiSample; ColorBits: Integer;
 269   DepthBits: Integer; StencilBits: Integer; AccumBits: Integer; AuxBuffers: Integer; Layer: Integer): TglcContextPixelFormatSettings;
 270 begin
 271   Result.DoubleBuffered:= DoubleBuffered;
 272   Result.Stereo:= Stereo;
 273   Result.MultiSampling:= MultiSampling;
 274   Result.ColorBits:= ColorBits;
 275   Result.DepthBits:= DepthBits;
 276   Result.StencilBits:= StencilBits;
 277   Result.AccumBits:= AccumBits;
 278   Result.AuxBuffers:= AuxBuffers;
 279   Result.Layer:= Layer;
 280 end;
 281
 282 class function TglcContext.MakeVersion(const aMajor, aMinor: Integer; const aForwardCompatible: Boolean): TglcContextVersionSettings;
 283 begin
 284   result.Major := aMajor;
 285   result.Minor := aMinor;
 286   result.ForwardCompatible := aForwardCompatible;
 287 end;
 288
 289 class function TglcContext.GetPlatformClass: TglcContextClass;
 290 begin
 291   Result := nil;
 292   {$IFDEF WINDOWS}
 293   Result:= TglcContextWGL;
 294   {$ELSE}{$IFDEF WIN32}
 295   Result:= TglcContextWGL;
 296   {$ENDIF}{$ENDIF}
 297   {$IFDEF LINUX}
 298   Result:= TglcContextGtk2GLX;
 299   {$ENDIF}
 300   if not Assigned(result) then
 301     raise EGLError.Create('unable to find suitabe context class');
 302 end;
 303
 304 class function TglcContext.IsAnyContextActive: boolean;
 305 begin
 306   Result:= GetPlatformClass.IsAnyContextActive;
 307 end;
 308
 309 constructor TglcContext.Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings);
 310 begin
 311   inherited Create;
 312   fPixelFormatSettings := aPixelFormatSettings;
 313   FControl             := aControl;
 314   fThreadID            := 0;
 315   fEnableVsync         := false;
 316   fUseVersion          := false;
 317   InitOpenGL();
 318 end;
 319
 320 constructor TglcContext.Create(const aControl: TWinControl; const aPixelFormatSettings: TglcContextPixelFormatSettings; const aVersionSettings: TglcContextVersionSettings);
 321 begin
 322   Create(aControl, aPixelFormatSettings);
 323   fVersionSettings := aVersionSettings;
 324   fUseVersion      := true;
 325 end;
 326
 327 destructor TglcContext.Destroy;
 328 begin
 329   if (GetCurrentThreadId = fMainContextThreadID) then
 330     fMainContextThreadID := 0;
 331   CloseContext;
 332   inherited Destroy;
 333 end;
 334
 335 procedure TglcContext.BuildContext;
 336 begin
 337   OpenContext;
 338   Activate;
 339   ReadImplementationProperties;
 340   ReadExtensions;
 341   SetEnableVSync(fEnableVsync);
 342 end;
 343
 344 procedure TglcContext.EnableDebugOutput(const aLogEvent: TLogEvent);
 345 begin
 346   fLogEvent := aLogEvent;
 347   SetDebugMode(true);
 348 end;
 349
 350 procedure TglcContext.DisableDebugOutput;
 351 begin
 352   SetDebugMode(false);
 353 end;
 354
 355 procedure TglcContext.CloseContext;
 356 begin
 357   if fMainContextThreadID = fThreadID then
 358     fMainContextThreadID := 0;
 359 end;
 360
 361 initialization
 362   {$IFDEF fpc}TglcContext.{$ENDIF}fMainContextThreadID := 0;
 363
 364 end.
 365