View Issue Details

IDProjectCategoryView StatusLast Update
0031943LazarusLCLpublic2020-07-13 00:02
Reportercordylus Assigned To 
PrioritynormalSeverityminorReproducibilityalways
Status newResolutionopen 
OSWindows 
Product Version1.6.4 
Summary0031943: TControl.SetDragCursor doesn't update cursor immediately
DescriptionYou can reproduce the problem easily by changing DragCursor on Shift KeyDown/KeyUp during dragging, the cursor will not be updated on the screen until the mouse moves.

Current code in LCL is just:

procedure TControl.SetDragCursor(const AValue: TCursor);
begin
  if FDragCursor=AValue then exit;
  FDragCursor:=AValue;
end;

First, I thought it should be fixed by analogy with TDragImageList.SetDragCursor:

procedure TControl.SetDragCursor(const AValue: TCursor);
begin
  if FDragCursor=AValue then exit;
  FDragCursor:=AValue;
  if DragManager.Dragging(Self) then
    WidgetSet.SetCursor(Screen.Cursors[DragCursor]);
end;

And it seemed to work until the cursor was set when it was in a NoDrop zone, then the cursor has changed anyway, although it shouldn't. (Wouldn't this be a bug in TDragImageList?)

Then, considering that pressing Control updates the cursor, I found TDragManagerDefault.KeyDown and took the approach from there:

procedure TControl.SetDragCursor(const AValue: TCursor);
begin
  if FDragCursor=AValue then exit;
  FDragCursor:=AValue;
  if DragManager.Dragging(Self) then
    DragManager.DragMove(Mouse.CursorPos);
end;

This works good, yet I'm not sure if it's OK to send a message (SendCmDragMsg in TDragPerformer.DragMove) when the cursor changes.

Alternatively, I suggest caching somewhere the latest result of SendCmDragMsg that is used as the "Accepted" parameter of TDragControlObject.GetDragCursor which decides whether it'll be the current drag cursor or crNoDrop.
TagsNo tags attached.
Fixed in Revision
LazTarget-
Widgetset
Attached Files

Activities

cordylus

2017-06-03 03:43

reporter  

cordylus

2017-06-03 04:05

reporter   ~0100811

Attached a demo project. Reproduces on trunk.

On Ctrl TDragManagerDefault.KeyDown and KeyUp are involved, yet it is buggy anyway. On Shift the cursor just doesn't change until mouse move.

Juha Manninen

2017-06-03 14:45

developer   ~0100830

Please attach a well tested patch.
 http://wiki.freepascal.org/Creating_A_Patch

cordylus

2017-06-03 19:26

reporter   ~0100840

I've investigated a bit. Now I believe the suggested code should not be used: internally DragMove sends a message that calls DragOver. So if you call SetDragCursor in the DragOver handler, the DragOver will be called again in the middle of the procedure. You can even deadlock the application if you are interleaving drag cursors on each DragOver call. Although it is unlikely to be done in the real world, it feels unsafe.
 
Therefore it should be implemented by caching the latest result of this call. And it is not that simple, it's all private, something will have to be exposed.

wp

2017-06-04 11:49

developer   ~0100849

By changing the standard Cursor along with the DragCursor I get immediate response to the keypress in your sample project:

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  if ssCtrl in Shift then begin
    Label1.DragCursor := crCross;
    Label1.Cursor := crCross; // <-- new
  end;
  if ssShift in Shift then begin
    Label1.DragCursor := crHandPoint;
    Label1.Cursor := crHandPoint; // <-- new
  end;
  DebugLn('d');
end;

procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  Label1.DragCursor := crDrag;
  Label1.Cursor := crDrag; // <-- new
  DebugLn('u');
end;

cordylus

2017-06-04 13:40

reporter   ~0100850

That seems to work because of oversimplified example, it works only when the receiver is the sender. Set Align of the label to alLeft and DragOver of the form to Label1DragOver and you'll see that it stops working when dragging over the form.

cordylus

2017-06-04 13:49

reporter   ~0100852

Also it ignores the Accepted state, so it doesn't solve the problem at all. Just change Accept to False in Label1DragOver, the cursor will change from crNoDrop when you press the key. This is the problem with "just set the cursor" solution that I wrote about in the bug description.

cordylus

2017-06-04 14:00

reporter   ~0100853

This state is not saved anywhere - it's passed through from DragOver to SendCmDragMsg to the system cursor in TDragPerformer.DragMove and TDockPerformer.DragMove, therefore it's impossible to fix this bug in a simple way.

cordylus

2017-06-04 17:02

reporter  

setdragcursor.patch (5,635 bytes)   
Index: lcl/controls.pp
===================================================================
--- lcl/controls.pp	(revision 55208)
+++ lcl/controls.pp	(working copy)
@@ -525,6 +525,7 @@
     FDragImmediate: Boolean;
     FDragThreshold: Integer;
   protected
+    function GetDragCursor: TCursor; virtual;abstract;
     //input capture
     procedure KeyUp(var Key: Word; Shift : TShiftState); virtual;abstract;
     procedure KeyDown(var Key: Word; Shift: TShiftState); virtual;abstract;
Index: lcl/include/control.inc
===================================================================
--- lcl/include/control.inc	(revision 55208)
+++ lcl/include/control.inc	(working copy)
@@ -3338,6 +3338,8 @@
 begin
   if FDragCursor=AValue then exit;
   FDragCursor:=AValue;
+  if Dragging then
+    WidgetSet.SetCursor(Screen.Cursors[DragManager.GetDragCursor]);
 end;
 
 procedure TControl.SetFont(Value: TFont);
Index: lcl/include/dragmanager.inc
===================================================================
--- lcl/include/dragmanager.inc	(revision 55208)
+++ lcl/include/dragmanager.inc	(working copy)
@@ -21,10 +21,12 @@
   private
     FManager: TDragManagerDefault;
     FDragImageList: TDragImageList;
+    FAccepted: Boolean;
     function SendCmDragMsg(ADragObject: TDragObject; ADragMsg: TDragMessage): Boolean;
     function SendDragMessage(AControl: TControl; Msg: TDragMessage; ADragObject: TDragObject; Target: TControl; const Position: TPoint): LRESULT;
   protected
     property Manager: TDragManagerDefault read FManager;
+    function GetDragCursor: TCursor; virtual;abstract;
     function Dragging(AControl: TControl): boolean; virtual;abstract;
     procedure DragStarted(APosition: TPoint); virtual;abstract;
     procedure DragMove(APosition: TPoint); virtual;abstract;
@@ -40,6 +42,7 @@
   private
     FDragObject: TDragObject;
   protected
+    function GetDragCursor: TCursor; override;
     function Dragging(AControl: TControl): boolean; override;
     procedure DragStarted(APosition: TPoint); override;
     procedure DragMove(APosition: TPoint); override;
@@ -56,6 +59,7 @@
   private
     FDockObject: TDragDockObject;
   protected
+    function GetDragCursor: TCursor; override;
     function Dragging(AControl: TControl): boolean; override;
     procedure DragStarted(APosition: TPoint); override;
     procedure DragMove(APosition: TPoint); override;
@@ -77,6 +81,7 @@
     FWaitForTreshold: boolean;//are we waiting on the treshold activation?
     FInDragStop: Boolean; // semaphore to prevent second execution of dragStop
   protected
+    function GetDragCursor: TCursor; override;
     //Support input capture
     procedure KeyUp(var Key: Word; Shift : TShiftState); override;
     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
@@ -119,7 +124,6 @@
     ADragObject is TDragDockObject);
 end;
 
-
 function TDragDockCommon.SendCmDragMsg(ADragObject: TDragObject; ADragMsg: TDragMessage): Boolean;
 //Send a CM_DRAG message to the window..
 begin
@@ -127,6 +131,7 @@
     ADragObject, ADragObject.DragTarget, ADragObject.DragPos) <> 0;
 end;
 
+
 { TDragPerformer }
 
 constructor TDragPerformer.Create(AManager: TDragManagerDefault; AControl: TControl);
@@ -147,6 +152,14 @@
   inherited Destroy;
 end;
 
+function TDragPerformer.GetDragCursor: TCursor;
+begin
+  if Assigned(FDragObject) then
+    Result := FDragObject.GetDragCursor(FAccepted, FDragObject.DragPos.X, FDragObject.DragPos.Y)
+  else
+    raise EInvalidOperation.Create('FDragObject is not assigned, can''t GetDragCursor from it');
+end;
+
 function TDragPerformer.Dragging(AControl: TControl): boolean;
 begin
   Result:= Assigned(FDragObject) and (FDragObject.Control=AControl);
@@ -185,7 +198,8 @@
   //TODO: Need to rewrite this(or even delete it, back to the roots)
   if FDragObject.DragTarget <> nil then
     FDragObject.DragTargetPos := FDragObject.DragTarget.ScreenToClient(APosition);
-  DragCursor := FDragObject.GetDragCursor(SendCmDragMsg(FDragObject, dmDragMove),APosition.X, APosition.Y);
+  FAccepted := SendCmDragMsg(FDragObject, dmDragMove);
+  DragCursor := FDragObject.GetDragCursor(FAccepted, APosition.X, APosition.Y);
   if FDragImageList <> nil then
   begin
     if (ATarget = nil) or (csDisplayDragImage in ATarget.ControlStyle) or
@@ -285,6 +299,14 @@
   inherited Destroy;
 end;
 
+function TDockPerformer.GetDragCursor: TCursor;
+begin
+  if Assigned(FDockObject) then
+    Result := FDockObject.GetDragCursor(FAccepted, FDockObject.DragPos.X, FDockObject.DragPos.Y)
+  else
+    raise EInvalidOperation.Create('FDockObject is not assigned, can''t GetDragCursor from it');
+end;
+
 function TDockPerformer.Dragging(AControl: TControl): boolean;
 begin
   Result:= Assigned(FDockObject) and (FDockObject.Control=AControl);
@@ -467,7 +489,8 @@
     SendCmDragMsg(FDockObject, dmDragEnter);
   end;
 
-  DragCursor := FDockObject.GetDragCursor(SendCmDragMsg(FDockObject, dmDragMove),APosition.X, APosition.Y);
+  FAccepted := SendCmDragMsg(FDockObject, dmDragMove);
+  DragCursor := FDockObject.GetDragCursor(FAccepted, APosition.X, APosition.Y);
   if FDragImageList <> nil then
   begin
     if (ATarget = nil) or (csDisplayDragImage in ATarget.ControlStyle) or
@@ -724,6 +747,14 @@
   end;
 end;
 
+function TDragManagerDefault.GetDragCursor: TCursor;
+begin
+  if Assigned(FPerformer) then
+    Result := FPerformer.GetDragCursor
+  else
+    raise EInvalidOperation.Create('DragManager.GetDragCursor may only be called during dragging');
+end;
+
 procedure TDragManagerDefault.KeyDown(var Key: Word; Shift: TShiftState);
 begin
   if Key = VK_CONTROL then
setdragcursor.patch (5,635 bytes)   

cordylus

2017-06-04 18:22

reporter   ~0100861

I've attached a patch for this bug.


wp, I think that the fact that your code additions affect something at all may be a bug in itself.

Some questions arose.

Does SetCursor (not SetDragCursor) should affect the displayed cursor when called during dragging? I think not.

What GetCursor should return during dragging? I think the normal cursor, not the drag cursor.

What GetDragCursor should return during dragging - should it return crNoDrop when dragging over a Accept = False zone? I think not, so in my patch I had to add a new method - DragManager.GetDragCursor that takes this into account.

Does CM_CURSORCHANGED should be performed when we SetCursor during dragging?

Does CM_CURSORCHANGED should be performed when we SetDragCursor during dragging?

cordylus

2017-06-13 14:06

reporter  

setdragcursor-alternative.patch (3,884 bytes)   
Index: lcl/include/control.inc
===================================================================
--- lcl/include/control.inc	(revision 55343)
+++ lcl/include/control.inc	(working copy)
@@ -3339,6 +3339,8 @@
 begin
   if FDragCursor=AValue then exit;
   FDragCursor:=AValue;
+  if DragManager.Dragging(Self) then
+    DragManager.DragMove(Mouse.CursorPos);
 end;
 
 procedure TControl.SetFont(Value: TFont);
Index: lcl/include/dragmanager.inc
===================================================================
--- lcl/include/dragmanager.inc	(revision 55343)
+++ lcl/include/dragmanager.inc	(working copy)
@@ -21,6 +21,7 @@
   private
     FManager: TDragManagerDefault;
     FDragImageList: TDragImageList;
+    FInDragMoveMsg: Boolean;
     function SendCmDragMsg(ADragObject: TDragObject; ADragMsg: TDragMessage): Boolean;
     function SendDragMessage(AControl: TControl; Msg: TDragMessage; ADragObject: TDragObject; Target: TControl; const Position: TPoint): LRESULT;
   protected
@@ -164,6 +165,7 @@
 procedure TDragPerformer.DragMove(APosition: TPoint);
 var 
   ATarget: TControl;
+  Accepted: Boolean;
   DragCursor: TCursor;
 begin
   if FDragObject = nil then
@@ -185,7 +187,15 @@
   //TODO: Need to rewrite this(or even delete it, back to the roots)
   if FDragObject.DragTarget <> nil then
     FDragObject.DragTargetPos := FDragObject.DragTarget.ScreenToClient(APosition);
-  DragCursor := FDragObject.GetDragCursor(SendCmDragMsg(FDragObject, dmDragMove),APosition.X, APosition.Y);
+  if FInDragMoveMsg then
+    Exit;
+  FInDragMoveMsg := True;
+  try
+    Accepted := SendCmDragMsg(FDragObject, dmDragMove);
+  finally
+    FInDragMoveMsg := False;
+  end;
+  DragCursor := FDragObject.GetDragCursor(Accepted, FDragObject.DragPos.X, FDragObject.DragPos.Y);
   if FDragImageList <> nil then
   begin
     if (ATarget = nil) or (csDisplayDragImage in ATarget.ControlStyle) or
@@ -193,9 +203,9 @@
     begin
       FDragImageList.DragCursor := DragCursor;
       if not FDragImageList.Dragging then
-        FDragImageList.BeginDrag(0, APosition.X, APosition.Y)
+        FDragImageList.BeginDrag(0, FDragObject.DragPos.X, FDragObject.DragPos.Y)
       else
-        FDragImageList.DragMove(APosition.X, APosition.Y);
+        FDragImageList.DragMove(FDragObject.DragPos.X, FDragObject.DragPos.Y);
     end
     else
       FDragImageList.EndDrag;
@@ -429,6 +439,7 @@
 
 var
   ATarget: TWinControl;
+  Accepted: Boolean;
   DragCursor: TCursor;
 begin
   if FDockObject = nil then
@@ -467,7 +478,15 @@
     SendCmDragMsg(FDockObject, dmDragEnter);
   end;
 
-  DragCursor := FDockObject.GetDragCursor(SendCmDragMsg(FDockObject, dmDragMove),APosition.X, APosition.Y);
+  if FInDragMoveMsg then
+    Exit;
+  FInDragMoveMsg := True;
+  try
+    Accepted := SendCmDragMsg(FDockObject, dmDragMove);
+  finally
+    FInDragMoveMsg := False;
+  end;
+  DragCursor := FDockObject.GetDragCursor(Accepted, FDockObject.DragPos.X, FDockObject.DragPos.Y);
   if FDragImageList <> nil then
   begin
     if (ATarget = nil) or (csDisplayDragImage in ATarget.ControlStyle) or
@@ -475,9 +494,9 @@
     begin
       FDragImageList.DragCursor := DragCursor;
       if not FDragImageList.Dragging then
-        FDragImageList.BeginDrag(0, APosition.X, APosition.Y)
+        FDragImageList.BeginDrag(0, FDockObject.DragPos.X, FDockObject.DragPos.Y)
       else
-        FDragImageList.DragMove(APosition.X, APosition.Y);
+        FDragImageList.DragMove(FDockObject.DragPos.X, FDockObject.DragPos.Y);
     end
     else
       FDragImageList.EndDrag;
@@ -488,7 +507,7 @@
   with FDockObject do
   begin
     if DragTarget = nil then //show as floating
-      FDockObject.Control.DockTrackNoTarget(FDockObject, APosition.X, APosition.Y);
+      FDockObject.Control.DockTrackNoTarget(FDockObject, FDockObject.DragPos.X, FDockObject.DragPos.Y);
 
     MoveDockImage;
   end;

cordylus

2017-06-13 14:07

reporter   ~0101090

Last edited: 2017-06-13 14:14

View 2 revisions

The alternative patch uses the simple method from the description plus a flag to prevent recursive DragMove message handler call (that goes to OnDragOver in the end) when the DragCursor is set from inside OnDragOver.

Edit: I forgot to add FInDragMoveMsg := False; to the TDragDockCommon constructor, although it's not that important.

Juha Manninen

2017-10-09 09:57

developer   ~0103268

wp, can you please look at the patches. I don't understand the issue well enough.

wp

2020-07-12 13:18

developer   ~0123921

Detaching myself.

Juha Manninen

2020-07-12 15:27

developer   ~0123931

Well, I tested the last patch and it improves things. The patch applies still after 3 years.
I know Delphi / VCL changes a drag cursor only after mouse moves, but what about other GUI libraries? We could improve over Delphi here.
This is not about Windows messages only. I tested with QT5 bindings. QT itself may implement a different bahavior but LCL bindings seem to work the same always in this case.

Issue History

Date Modified Username Field Change
2017-06-01 08:50 cordylus New Issue
2017-06-01 17:59 Juha Manninen Project Packages => Lazarus
2017-06-03 03:43 cordylus File Added: dragcursor_doesnt_change.zip
2017-06-03 04:05 cordylus Note Added: 0100811
2017-06-03 14:45 Juha Manninen Note Added: 0100830
2017-06-03 19:26 cordylus Note Added: 0100840
2017-06-04 11:49 wp Note Added: 0100849
2017-06-04 13:40 cordylus Note Added: 0100850
2017-06-04 13:49 cordylus Note Added: 0100852
2017-06-04 14:00 cordylus Note Added: 0100853
2017-06-04 17:02 cordylus File Added: setdragcursor.patch
2017-06-04 18:22 cordylus Note Added: 0100861
2017-06-13 14:06 cordylus File Added: setdragcursor-alternative.patch
2017-06-13 14:07 cordylus Note Added: 0101090
2017-06-13 14:14 cordylus Note Edited: 0101090 View Revisions
2017-10-09 09:56 Juha Manninen Assigned To => wp
2017-10-09 09:56 Juha Manninen Status new => assigned
2017-10-09 09:57 Juha Manninen Note Added: 0103268
2020-07-12 13:17 wp Assigned To wp =>
2020-07-12 13:18 wp Note Added: 0123921
2020-07-12 15:27 Juha Manninen Note Added: 0123931
2020-07-13 00:02 Maxim Ganetsky Status assigned => new
2020-07-13 00:02 Maxim Ganetsky LazTarget => -