paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-17 22:09:28 +02:00
Code Issues Packages Projects Releases Wiki Activity

Merged revision(s) 61059-61060 #59587a0452-#59587a0452, 61107 #9c59e031fc, 61135 #2b46c6d5e0, 61536 #9bf589f433, 61739 #f13e53bf2f, 61767 #159d5cc8cc, 62188 #7ec219a05b from trunk:

Browse Source 
opengl: adding support for Cocoa mouseMove events for Right and Middle mouse buttons. Based on the patch by Chris Rorden. bug 
........
opengl: forcing painting even with NSgraphicContext currentContext assigned. Seems to be Mojave specific behaviour not to provide context. bug 
........
opengl: update cocoa compilation for the latest update with keyhandling
........
opengl: prevent double mouse-down events for cocoa. bug 
........
opengl: fix cocoa compilation
........
opengl: cocoa: removing Dummy type declarations as they are not in the code. Yet the type declarations changed in trunk FPC version (3.2.0). bug 
........
opengl: getting rid of cocoa GetNSObjectView
........
opengl: remove gl unit used from glcocoanscontext unit
........

git-svn-id: branches/fixes_2_0@62469 -
This commit is contained in:
dmitry 2019-12-30 06:46:56 +00:00
parent 9e2610ab5d
commit c9d2229b7b
4 changed files with 110 additions and 59 deletions

16
components/opengl/example/mainunit.lfm
View File

@ -1,10 +1,22 @@
object Form1: TForm1
Left = 419
Left = 302
Height = 300
Top = 287
Top = 181
Width = 400
HorzScrollBar.Page = 399
VertScrollBar.Page = 299
Caption = 'Form1'
ClientHeight = 300
ClientWidth = 400
OnCreate = FormCreate
LCLVersion = '2.1.0.0'
object Panel1: TPanel
Left = 97
Height = 50
Top = 49
Width = 170
Caption = 'Panel1'
TabOrder = 0
OnMouseMove = Panel1MouseMove
end
end

24
components/opengl/example/mainunit.pas
View File

@ -15,25 +15,32 @@ interface
uses
Classes, SysUtils, LCLProc, LResources, Forms, Controls, Graphics, Dialogs,
OpenGLContext, GL, GLU;
ExtCtrls, OpenGLContext, GL, GLU, CocoaInt
,CocoaWSCommon, CocoaPrivate;
type
{ TForm1 }
TForm1 = class(TForm)
Panel1: TPanel;
procedure FormCreate(Sender: TObject);
procedure OpenGLControl1Paint(Sender: TObject);
procedure OpenGLControl1Resize(Sender: TObject);
procedure OnAppIdle(Sender: TObject; var Done: Boolean);
procedure Panel1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer
);
private
public
cube_rotationx: GLFloat;
cube_rotationy: GLFloat;
cube_rotationz: GLFloat;
OpenGLControl1: TOpenGLControl;
procedure OpenGLMouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
end;
var
Form1: TForm1;
@ -52,16 +59,24 @@ begin
Parent:=Self;
OnPaint:=@OpenGLControl1Paint;
OnResize:=@OpenGLControl1Resize;
OnMouseMove:=@OpenGLMouseMove;
AutoResizeViewport:=true;
end;
Application.AddOnIdleHandler(@OnAppIdle);
end;
procedure TForm1.OpenGLMouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
begin
Caption:=Format('%d %d',[x,y]);
end;
procedure TForm1.OpenGLControl1Paint(Sender: TObject);
var
Speed: Double;
begin
writeln('paint');
glClearColor(1.0, 1.0, 1.0, 1.0);
glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);
glEnable(GL_DEPTH_TEST);
@ -139,8 +154,15 @@ procedure TForm1.OnAppIdle(Sender: TObject; var Done: Boolean);
begin
Done:=false;
//DebugLn(['TForm1.OnAppIdle ']);
//OpenGLControl1.Paint;
OpenGLControl1.Invalidate;
end;
procedure TForm1.Panel1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
Caption:=Format('panel: %d %d',[x,y]);
end;
end.

22
components/opengl/example/testopenglcontext1.lpi
View File

@ -1,14 +1,14 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<Version Value="12"/>
<PathDelim Value="\"/>
<General>
<Flags>
<LRSInOutputDirectory Value="False"/>
<CompatibilityMode Value="True"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<ResourceType Value="res"/>
</General>
<BuildModes Count="1">
@ -16,15 +16,19 @@
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="\usr\X11R6\bin\xterm -T 'Lazarus Run Output' -e $(LazarusDir)\tools\runwait.sh $(TargetCmdLine)"/>
<LaunchingApplication PathPlusParams="\usr\X11R6\bin\xterm -T &apos;Lazarus Run Output&apos; -e $(LazarusDir)\tools\runwait.sh $(TargetCmdLine)"/>
</local>
<FormatVersion Value="2"/>
<Modes Count="1">
<Mode0 Name="default">
<local>
<LaunchingApplication PathPlusParams="\usr\X11R6\bin\xterm -T &apos;Lazarus Run Output&apos; -e $(LazarusDir)\tools\runwait.sh $(TargetCmdLine)"/>
</local>
</Mode0>
</Modes>
</RunParams>
<RequiredPackages Count="2">
<Item1>
@ -44,6 +48,7 @@
<Filename Value="mainunit.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="MainUnit"/>
</Unit1>
@ -57,6 +62,9 @@
</SyntaxOptions>
</Parsing>
<Linking>
<Debugging>
<DebugInfoType Value="dsDwarf2"/>
</Debugging>
<Options>
<Win32>
<GraphicApplication Value="True"/>

107
components/opengl/glcocoanscontext.pas
View File

@ -24,8 +24,9 @@ unit GLCocoaNSContext;
interface
uses
Classes, SysUtils, types, CocoaWSCommon, CocoaPrivate, CocoaUtils, LCLType,
Controls, LazLoggerBase, WSLCLClasses, gl, MacOSAll, CocoaAll;
Classes, SysUtils, types, CocoaWSCommon, CocoaPrivate, CocoaUtils, LCLType, Cocoa_Extra,
LMessages, LCLMessageGlue,
Controls, LazLoggerBase, WSLCLClasses, MacOSAll, CocoaAll;
function LBackingScaleFactor(Handle: HWND): single;
procedure LSetWantsBestResolutionOpenGLSurface(const AValue: boolean; Handle: HWND);
@ -60,8 +61,6 @@ type
NSScreenFix = objccategory external (NSScreen)
function backingScaleFactor: CGFloat ; message 'backingScaleFactor';
end;
TDummyNoWarnObjCNotUsed = objc.BOOL;
TDummyNoWarnObjCBaseNotUsed = objcbase.NSInteger;
{ TCocoaOpenGLView }
@ -84,17 +83,15 @@ type
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;
// key
procedure keyDown(event: NSEvent); override;
procedure keyUp(event: NSEvent); override;
procedure flagsChanged(event: NSEvent); override;
// other
procedure resetCursorRects; override;
end;
@ -198,7 +195,7 @@ begin
Result:=0;
p := nil;
if (AParams.WndParent <> 0) then
p := CocoaUtils.GetNSObjectView(NSObject(AParams.WndParent));
p := NSObject(AParams.WndParent).lclContentView;
if Assigned(p) then
LCLToNSRect(types.Bounds(AParams.X, AParams.Y, AParams.Width, AParams.Height),
p.frame.size.height, ns)
@ -430,44 +427,54 @@ end;
procedure TCocoaOpenGLView.mouseDown(event: NSEvent);
begin
if Assigned(callback)
then callback.MouseUpDownEvent(event)
else inherited mouseDown(event);
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 Assigned(callback)
then callback.MouseUpDownEvent(event)
else inherited mouseUp(event);
if not Assigned(callback) or not callback.MouseUpDownEvent(event) then
inherited mouseUp(event);
end;
procedure TCocoaOpenGLView.rightMouseDown(event: NSEvent);
begin
if Assigned(callback)
then callback.MouseUpDownEvent(event)
else inherited rightMouseDown(event);
if not Assigned(callback) or not callback.MouseUpDownEvent(event) then
inherited rightMouseDown(event);
end;
procedure TCocoaOpenGLView.rightMouseUp(event: NSEvent);
begin
if Assigned(callback)
then callback.MouseUpDownEvent(event)
else inherited rightMouseUp(event);
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 Assigned(callback)
then callback.MouseUpDownEvent(event)
else inherited otherMouseDown(event);
if not Assigned(callback) or not callback.MouseUpDownEvent(event) then
inherited otherMouseDown(event);
end;
procedure TCocoaOpenGLView.otherMouseUp(event: NSEvent);
begin
if Assigned(callback)
then callback.MouseUpDownEvent(event)
else inherited otherMouseUp(event);
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);
@ -489,9 +496,8 @@ end;
procedure TCocoaOpenGLView.mouseMoved(event: NSEvent);
begin
if Assigned(callback)
then callback.MouseMove(event)
else inherited mouseMoved(event);
if not Assigned(callback) or not callback.MouseMove(event) then
inherited mouseMoved(event);
end;
procedure TCocoaOpenGLView.scrollWheel(event: NSEvent);
@ -501,24 +507,6 @@ begin
else inherited scrollWheel(event);
end;
procedure TCocoaOpenGLView.keyDown(event: NSEvent);
begin
if not Assigned(callback) or not callback.KeyEvent(event) then
inherited keyDown(event);
end;
procedure TCocoaOpenGLView.keyUp(event: NSEvent);
begin
if not Assigned(callback) or not callback.KeyEvent(event) then
inherited keyUp(event);
end;
procedure TCocoaOpenGLView.flagsChanged(event: NSEvent);
begin
if not Assigned(callback) or not callback.KeyEvent(event) then
inherited flagsChanged(event);
end;
procedure TCocoaOpenGLView.resetCursorRects;
begin
if not Assigned(callback) or not callback.resetCursorRects then
@ -526,10 +514,31 @@ begin
end;
procedure TCocoaOpenGLView.drawRect(dirtyRect: NSRect);
var
ctx : NSGraphicsContext;
PS : TPaintStruct;
r : NSRect;
begin
ctx := NSGraphicsContext.currentContext;
inherited drawRect(dirtyRect);
if CheckMainThread and Assigned(callback) then
callback.Draw(NSGraphicsContext.currentContext, bounds, dirtyRect);
begin
if ctx = nil then
begin
// In macOS 10.14 (mojave) current context is nil
// we still can paint anything releated 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 := NSRectToRect(r);
LCLSendPaintMsg(Owner, HDC(0), @PS);
end
else
callback.Draw(ctx, bounds, dirtyRect);
end;
end;
end.